-! 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 layouts hashtables
-cpu.architecture generalizations
-compiler.cfg
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
+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
-<PRIVATE
-
-SYMBOL: numbers
-
-: block-number ( bb -- n ) numbers get at ;
-
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
-
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
-
-: linearize-basic-block ( bb -- )
- [ block-number _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
- ! If our successor immediately follows us in linearization
- ! order then we don't need to branch.
- [ block-number ] bi@ 1 - = ; inline
-
-: emit-branch ( bb successor -- )
- 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
-
-: successors ( bb -- first second ) successors>> first2 ; inline
-
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
- bb insn
- conditional-quot
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap block-number ] n ndip ]
- [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
-
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+<PRIVATE
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- 3 [ (binary-conditional) ] [ negate-cc ] conditional ;
+SYMBOLS: loop-heads visited ;
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
- [ dup successors ]
- [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
+: visited? ( bb -- ? ) visited get in? ;
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
- 4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
-M: ##compare-branch linearize-insn
- binary-conditional _compare-branch emit-branch ;
+: (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: ##compare-imm-branch linearize-insn
- binary-conditional _compare-imm-branch emit-branch ;
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-M: ##compare-float-ordered-branch linearize-insn
- binary-conditional _compare-float-ordered-branch emit-branch ;
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
-M: ##compare-float-unordered-branch linearize-insn
- binary-conditional _compare-float-unordered-branch emit-branch ;
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
-M: ##test-vector-branch linearize-insn
- test-vector-conditional _test-vector-branch emit-branch ;
+: 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 ;
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors block-number ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+: (linearization-order) ( cfg -- bbs )
+ HS{ } clone visited set
+ entry>> <dlist> [ push-back ] keep
+ [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
-M: ##fixnum-add linearize-insn
- overflow-conditional _fixnum-add emit-branch ;
+PRIVATE>
-M: ##fixnum-sub linearize-insn
- overflow-conditional _fixnum-sub emit-branch ;
+: linearization-order ( cfg -- bbs )
+ {
+ [ needs-post-order ]
+ [ needs-loops ]
+ [ needs-predecessors ]
+ [
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if
+ ]
+ } cleave ;
-M: ##fixnum-mul linearize-insn
- overflow-conditional _fixnum-mul emit-branch ;
+SYMBOL: numbers
-M: ##dispatch linearize-insn
- swap
- [ [ src>> ] [ temp>> ] bi _dispatch ]
- [ successors>> [ block-number _dispatch-label ] each ]
- bi* ;
+: block-number ( bb -- n ) numbers get at ;
-: linearize-basic-blocks ( cfg -- insns )
- [
- [
- linearization-order
- [ number-blocks ]
- [ [ linearize-basic-block ] each ] bi
- ] [ spill-area-size>> _spill-area-size ] bi
- ] { } make ;
+: number-blocks ( bbs -- )
+ H{ } zip-index-as numbers set ;
-PRIVATE>
-
-: flatten-cfg ( cfg -- mr )
- [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
- <mr> ;
+: cfg>insns ( cfg -- insns )
+ linearization-order [ instructions>> ] map concat ;
projects / factor.git / blobdiff