-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals cpu.architecture
-compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities ;
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg.loop-detection compiler.cfg.predecessors
+compiler.cfg.rpo compiler.cfg.utilities deques dlists fry kernel
+make math namespaces sequences sets sorting ;
+FROM: namespaces => set ;
IN: compiler.cfg.linearization
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-: linearize-basic-block ( bb -- )
- [ number>> _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
+<PRIVATE
-M: insn linearize-insn , drop ;
+SYMBOLS: loop-heads visited ;
-: useless-branch? ( basic-block successor -- ? )
- #! If our successor immediately follows us in RPO, then we
- #! don't need to branch.
- [ number>> ] bi@ 1 - = ; inline
+: visited? ( bb -- ? ) visited get in? ;
-: emit-loop-entry? ( bb successor -- ? )
- [ back-edge? not ]
- [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ;
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
-: emit-branch ( bb successor -- )
- 2dup emit-loop-entry? [ _loop-entry ] when
- 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
+: (find-alternate-loop-head) ( bb -- bb' )
+ dup {
+ [ predecessor visited? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor successors>> length 1 = ]
+ [ [ number>> ] [ predecessor number>> ] bi > ]
+ } 1&& [ predecessor (find-alternate-loop-head) ] when ;
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-: successors ( bb -- first second ) successors>> first2 ; inline
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- [ (binary-conditional) ]
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
+: process-block ( bb -- bbs )
+ dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
+ [ predecessors-ready? ] filter
+ [ dup loop-entry? [ find-alternate-loop-head ] when ] map
+ [ visited? ] reject ;
-: with-regs ( insn quot -- )
- over regs>> [ call ] dip building get last (>>regs) ; inline
+: (linearization-order) ( cfg -- bbs )
+ HS{ } clone visited set
+ entry>> <dlist> [ push-back ] keep
+ [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
-M: ##compare-branch linearize-insn
- [ binary-conditional _compare-branch ] with-regs emit-branch ;
+PRIVATE>
-M: ##compare-imm-branch linearize-insn
- [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
-
-M: ##compare-float-branch linearize-insn
- [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
-
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors number>> ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
-
-M: ##fixnum-add linearize-insn
- [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
-
-M: ##fixnum-sub linearize-insn
- [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
-
-M: ##fixnum-mul linearize-insn
- [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
-
-M: ##dispatch linearize-insn
- swap
- [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
- [ successors>> [ number>> _dispatch-label ] each ]
- bi* ;
-
-: (compute-gc-roots) ( n live-values -- n )
- [
- [ nip 2array , ]
- [ drop reg-class>> reg-size + ]
- 3bi
- ] assoc-each ;
-
-: oop-values ( regs -- regs' )
- [ drop reg-class>> int-regs eq? ] assoc-filter ;
+: linearization-order ( cfg -- bbs )
+ {
+ [ needs-post-order ]
+ [ needs-loops ]
+ [ needs-predecessors ]
+ [
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if
+ ]
+ } cleave ;
-: data-values ( regs -- regs' )
- [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
+SYMBOL: numbers
-: compute-gc-roots ( live-values -- alist )
- [
- [ 0 ] dip
- ! we put float registers last; the GC doesn't actually scan them
- [ oop-values (compute-gc-roots) ]
- [ data-values (compute-gc-roots) ] bi
- drop
- ] { } make ;
+: block-number ( bb -- n ) numbers get at ;
-: count-gc-roots ( live-values -- n )
- ! Size of GC root area, minus the float registers
- oop-values assoc-size ;
+: number-blocks ( bbs -- )
+ H{ } zip-index-as numbers set ;
-M: ##gc linearize-insn
- nip
- [
- [ temp1>> ]
- [ temp2>> ]
- [
- live-values>>
- [ compute-gc-roots ]
- [ count-gc-roots ]
- [ gc-roots-size ]
- tri
- ] tri
- _gc
- ] with-regs ;
-
-: linearize-basic-blocks ( cfg -- insns )
- [
- [ [ linearize-basic-block ] each-basic-block ]
- [ spill-counts>> _spill-counts ]
- bi
- ] { } make ;
-
-: flatten-cfg ( cfg -- mr )
- [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
- <mr> ;
+: cfg>insns ( cfg -- insns )
+ linearization-order [ instructions>> ] map concat ;
projects / factor.git / blobdiff