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 ;
+compiler.cfg.utilities
+compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
: linearize-basic-block ( bb -- )
- [ number>> _label ]
+ [ 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 RPO, then we
- #! don't need to branch.
- [ number>> ] bi@ 1 - = ; inline
-
-: emit-loop-entry? ( bb successor -- ? )
- [ back-edge? not ] [ nip loop-entry? ] 2bi and ;
+ ! 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 emit-loop-entry? [ _loop-entry ] when
- 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
+ 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: 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 ;
+ [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
: with-regs ( insn quot -- )
over regs>> [ call ] dip building get last (>>regs) ; inline
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors number>> ]
+ [ dup successors block-number ]
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
M: ##fixnum-add linearize-insn
M: ##dispatch linearize-insn
swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
- [ successors>> [ number>> _dispatch-label ] each ]
+ [ successors>> [ block-number _dispatch-label ] each ]
bi* ;
: (compute-gc-roots) ( n live-values -- n )
: linearize-basic-blocks ( cfg -- insns )
[
- [ [ linearize-basic-block ] each-basic-block ]
+ [ linearization-order [ linearize-basic-block ] each ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel make
+namespaces sequences combinators combinators.short-circuit
+fry math sets compiler.cfg.utilities ;
+IN: compiler.cfg.linearization.order
+
+! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+
+<PRIVATE
+
+SYMBOLS: work-list loop-heads visited numbers next-number ;
+
+: visited? ( bb -- ? ) visited get key? ;
+
+: add-to-work-list ( bb -- )
+ dup visited get key? [ drop ] [
+ work-list get push-back
+ ] 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 ;
+
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
+
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
+
+: process-successor ( bb -- )
+ dup predecessors-ready? [
+ dup loop-entry? [ find-alternate-loop-head ] when
+ add-to-work-list
+ ] [ drop ] if ;
+
+: assign-number ( bb -- )
+ next-number [ get ] [ inc ] bi swap numbers get set-at ;
+
+: process-block ( bb -- )
+ {
+ [ , ]
+ [ assign-number ]
+ [ visited get conjoin ]
+ [ successors>> <reversed> [ process-successor ] each ]
+ } cleave ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+ <dlist> work-list set
+ H{ } clone visited set
+ H{ } clone numbers set
+ 0 next-number set
+ entry>> add-to-work-list
+ [ work-list get [ process-block ] slurp-deque ] { } make ;
+
+: block-number ( bb -- n ) numbers get at ;