! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg.predecessors
-compiler.cfg.rpo deques dlists functors kernel lexer locals
-namespaces sequences ;
+USING: accessors assocs combinators.short-circuit compiler.cfg.predecessors
+compiler.cfg.rpo compiler.cfg.utilities deques dlists functors kernel lexer
+locals namespaces sequences ;
IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets bb dfa -- set )
bb in-sets dfa compute-out-set
bb out-sets maybe-set-at ; inline
-:: dfa-step ( bb in-sets out-sets dfa work-list -- )
- bb in-sets out-sets dfa update-in-set [
- bb in-sets out-sets dfa update-out-set [
- bb dfa successors work-list push-all-front
- ] when
- ] when ; inline
+: update-in/out-set ( bb in-sets out-sets dfa -- ? )
+ { [ update-in-set ] [ update-out-set ] } 4 n&& ;
+
+:: dfa-step ( bb in-sets out-sets dfa -- bbs )
+ bb in-sets out-sets dfa update-in/out-set bb dfa successors { } ? ;
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
- cfg needs-predecessors
H{ } clone :> in-sets
H{ } clone :> out-sets
- cfg dfa <dfa-worklist> :> work-list
- work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+ cfg needs-predecessors
+ cfg dfa <dfa-worklist>
+ [ in-sets out-sets dfa dfa-step ] slurp/replenish-deque
in-sets
out-sets ; inline
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
-compiler.cfg.utilities kernel accessors sequences sets tools.test namespaces ;
+USING: accessors compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+compiler.cfg.linearization.private compiler.cfg.utilities dlists kernel make
+namespaces sequences tools.test ;
IN: compiler.cfg.linearization.tests
+! linearization-order
V{ } 0 test-bb
V{ } 1 test-bb
{ { 0 1 2 } } [
0 get block>cfg linearization-order [ number>> ] map
] unit-test
+
+! process-block
+{ { } V{ 10 } } [
+ HS{ } clone visited set
+ V{ } 10 insns>block [ process-block ] V{ } make
+ [ number>> ] map
+] unit-test
+
+! process-successor
+{ V{ 10 } } [
+ <dlist> work-list set
+ HS{ } clone visited set
+ V{ } 10 insns>block process-successor
+ work-list get dlist>sequence [ number>> ] map
+] unit-test
<PRIVATE
-SYMBOLS: work-list loop-heads visited ;
+SYMBOLS: loop-heads visited ;
: visited? ( bb -- ? ) visited get in? ;
-: add-to-work-list ( bb -- )
- dup visited? [ drop ] [
- work-list get push-back
- ] if ;
-
-: init-linearization-order ( cfg -- )
- <dlist> work-list set
- HS{ } clone visited set
- entry>> add-to-work-list ;
-
: (find-alternate-loop-head) ( bb -- bb' )
dup {
[ predecessor visited? not ]
[ 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 ;
-
: sorted-successors ( bb -- seq )
successors>> <reversed> [ loop-nesting-at ] sort-with ;
-: process-block ( bb -- )
- dup visited get ?adjoin [
- [ , ]
- [ sorted-successors [ process-successor ] each ]
- bi
- ] [ drop ] 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? not ] filter ;
: (linearization-order) ( cfg -- bbs )
- init-linearization-order
-
- [ work-list get [ process-block ] slurp-deque ] { } make ;
+ HS{ } clone visited set
+ entry>> <dlist> [ push-back ] keep
+ [ [ process-block ] slurp/replenish-deque ] { } make ;
PRIVATE>
compiler.cfg compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.registers
compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities cpu.architecture
-namespaces sequences kernel tools.test vectors alien math
+dlists namespaces sequences kernel tools.test vectors alien math
compiler.cfg.comparisons cpu.x86.assembler.operands assocs ;
IN: compiler.cfg.liveness.tests
QUALIFIED: sets
H{ { 37 37 } { 3 3 } } dup T{ ##peek f 2 D 0 0 } kill-defs
] unit-test
+! liveness-step
+{ 3 } [
+ init-liveness
+ 3 iota [ <basic-block> swap >>number ] map <basic-block>
+ [ connect-Nto1-bbs ] keep liveness-step length
+] unit-test
+
! lookup-base-pointer
{ 84 } [
H{ { 84 84 } } clone base-pointers set 84 lookup-base-pointer
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg.def-use
-compiler.cfg.instructions compiler.cfg.predecessors
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo
compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities
cpu.architecture deques dlists fry kernel locals namespaces
} case ;
: gc-roots ( live-set -- derived-roots gc-roots )
- V{ } clone HS{ } clone
- [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
- members ;
+ keys V{ } clone HS{ } clone
+ [ '[ _ _ visit-gc-root ] each ] 2keep members ;
: fill-gc-map ( live-set gc-map -- )
- [ representations get [ gc-roots ] [ drop f f ] if ] dip
- [ gc-roots<< ] [ derived-roots<< ] bi ;
+ [ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ;
M: gc-map-insn visit-insn ( live-set insn -- )
[ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
: transfer-liveness ( live-set insns -- )
<reversed> [ visit-insn ] with each ;
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
- work-list get push-all-front ;
-
: compute-live-in ( basic-block -- live-in )
[ live-out clone dup ] keep instructions>> transfer-liveness ;
[ compute-live-out ] keep
live-outs get maybe-set-at ;
-: liveness-step ( basic-block -- )
- dup update-live-out [
- dup update-live-in
- [ predecessors>> add-to-work-list ] [ drop ] if
- ] [ drop ] if ;
+: update-live-out/in ( basic-block -- changed? )
+ { [ update-live-out ] [ update-live-in ] } 1&& ;
-: compute-live-sets ( cfg -- )
- <hashed-dlist> work-list set
+: liveness-step ( basic-block -- basic-blocks )
+ [ update-live-out/in ] keep predecessors>> { } ? ;
+
+: init-liveness ( -- )
H{ } clone live-ins set
H{ } clone edge-live-ins set
H{ } clone live-outs set
- H{ } clone base-pointers set
+ H{ } clone base-pointers set ;
- [ needs-predecessors ]
- [ compute-insns ]
- [ post-order add-to-work-list ] tri
- work-list get [ liveness-step ] slurp-deque ;
+: compute-live-sets ( cfg -- )
+ init-liveness
+ dup needs-predecessors dup compute-insns
+ post-order <hashed-dlist> [ push-all-front ] keep
+ [ liveness-step ] slurp/replenish-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
-USING: compiler.cfg compiler.cfg.loop-detection compiler.cfg.debugger
-compiler.cfg.predecessors compiler.cfg.utilities tools.test kernel namespaces
-accessors ;
+USING: accessors compiler.cfg compiler.cfg.loop-detection
+compiler.cfg.loop-detection.private compiler.cfg.debugger
+compiler.cfg.predecessors compiler.cfg.utilities tools.test dlists kernel
+namespaces sequences ;
IN: compiler.cfg.loop-detection.tests
+QUALIFIED: sets
+
+{ V{ 0 } { 1 } } [
+ V{ } 0 insns>block V{ } 1 insns>block [ connect-bbs ] keep
+ f f <natural-loop> [ process-loop-block ] keep
+ blocks>> sets:members
+ [ [ number>> ] map ] bi@
+] unit-test
+
+! process-loop-ends
+{ } [
+ f f <natural-loop> process-loop-ends
+] unit-test
+
V{ } 0 test-bb
V{ } 1 test-bb
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg compiler.cfg.predecessors
-deques dlists fry kernel namespaces sequences sets ;
+USING: accessors assocs combinators.short-circuit compiler.cfg
+compiler.cfg.predecessors compiler.cfg.utilities deques dlists fry kernel
+namespaces sequences sets ;
FROM: namespaces => set ;
IN: compiler.cfg.loop-detection
2tri
] [ drop ] if ;
-SYMBOL: work-list
-
-: process-loop-block ( bb loop -- )
- 2dup blocks>> ?adjoin [
- 2dup header>> eq? [ 2drop ] [
- drop predecessors>> work-list get push-all-front
- ] if
- ] [ 2drop ] if ;
+: process-loop-block ( bb loop -- bbs )
+ dupd { [ blocks>> ?adjoin ] [ header>> eq? not ] } 2&&
+ swap predecessors>> { } ? ;
: process-loop-ends ( loop -- )
- [ ends>> members <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
- '[ _ process-loop-block ] slurp-deque ;
+ dup ends>> members <dlist> [ push-all-front ] keep
+ swap '[ _ process-loop-block ] slurp/replenish-deque ;
: process-loop-headers ( -- )
loops get values [ process-loop-ends ] each ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators.short-circuit compiler.cfg
-compiler.cfg.instructions compiler.cfg.rpo cpu.architecture fry
+compiler.cfg.instructions compiler.cfg.rpo cpu.architecture deques fry
kernel locals make math namespaces sequences sets ;
IN: compiler.cfg.utilities
: <copy> ( dst src -- insn )
any-rep ##copy new-insn ;
-: apply-passes ( obj passes -- )
- [ execute( x -- ) ] with each ;
-
: connect-bbs ( from to -- )
[ [ successors>> ] dip suffix! drop ]
[ predecessors>> swap suffix! drop ] 2bi ;
: make-edges ( block-map edgelist -- )
[ [ of ] with map first2 connect-bbs ] with each ;
+
+! Abstract generic stuff
+: apply-passes ( obj passes -- )
+ [ execute( x -- ) ] with each ;
+
+: slurp/replenish-deque ( ... deque quot: ( ... obj -- ... seq ) -- ... )
+ over '[ @ _ push-all-front ] slurp-deque ; inline