-! 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
-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
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-: emit-branch ( bb successor -- )
- 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
-
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
+<PRIVATE
-: successors ( bb -- first second ) successors>> first2 ; inline
+SYMBOLS: loop-heads visited ;
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+: visited? ( bb -- ? ) visited get in? ;
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- [ (binary-conditional) ]
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
+: 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 ;
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors block-number ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+: 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 ;
-M: ##fixnum-add linearize-insn
- overflow-conditional _fixnum-add emit-branch ;
+: (linearization-order) ( cfg -- bbs )
+ HS{ } clone visited set
+ entry>> <dlist> [ push-back ] keep
+ [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
-M: ##fixnum-sub linearize-insn
- overflow-conditional _fixnum-sub emit-branch ;
+PRIVATE>
-M: ##fixnum-mul linearize-insn
- overflow-conditional _fixnum-mul 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: ##dispatch linearize-insn
- swap
- [ [ src>> ] [ temp>> ] bi _dispatch ]
- [ successors>> [ block-number _dispatch-label ] each ]
- bi* ;
+SYMBOL: numbers
-: gc-root-offsets ( registers -- alist )
- ! Outputs a sequence of { offset register/spill-slot } pairs
- [ length iota [ cell * ] map ] keep zip ;
+: block-number ( bb -- n ) numbers get at ;
-M: ##gc linearize-insn
- nip
- {
- [ temp1>> ]
- [ temp2>> ]
- [ data-values>> ]
- [ tagged-values>> gc-root-offsets ]
- [ uninitialized-locs>> ]
- } cleave
- _gc ;
-
-: 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