1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators combinators.short-circuit
4 compiler.cfg.loop-detection compiler.cfg.predecessors
5 compiler.cfg.rpo compiler.cfg.utilities deques dlists fry kernel
6 make math namespaces sequences sets sorting ;
7 FROM: namespaces => set ;
8 IN: compiler.cfg.linearization
10 ! This is RPO except loops are rotated and unlikely blocks go
11 ! at the end. Based on SBCL's src/compiler/control.lisp
15 SYMBOLS: loop-heads visited ;
17 : visited? ( bb -- ? ) visited get in? ;
19 : predecessors-ready? ( bb -- ? )
20 [ predecessors>> ] keep '[
22 [ 2drop t ] [ drop visited? ] if
25 : (find-alternate-loop-head) ( bb -- bb' )
27 [ predecessor visited? not ]
28 [ predecessors>> length 1 = ]
29 [ predecessor successors>> length 1 = ]
30 [ [ number>> ] [ predecessor number>> ] bi > ]
31 } 1&& [ predecessor (find-alternate-loop-head) ] when ;
33 : find-back-edge ( bb -- pred )
34 [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
36 : find-alternate-loop-head ( bb -- bb' )
37 dup find-back-edge dup visited? [ drop ] [
38 nip (find-alternate-loop-head)
41 : sorted-successors ( bb -- seq )
42 successors>> <reversed> [ loop-nesting-at ] sort-with ;
44 : process-block ( bb -- bbs )
45 dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
46 [ predecessors-ready? ] filter
47 [ dup loop-entry? [ find-alternate-loop-head ] when ] map
50 : (linearization-order) ( cfg -- bbs )
51 HS{ } clone visited set
52 entry>> <dlist> [ push-back ] keep
53 [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
57 : linearization-order ( cfg -- bbs )
61 [ needs-predecessors ]
63 dup linear-order>> [ ] [
64 dup (linearization-order)
65 >>linear-order linear-order>>
72 : block-number ( bb -- n ) numbers get at ;
74 : number-blocks ( bbs -- )
75 H{ } zip-index-as numbers set ;
77 : cfg>insns ( cfg -- insns )
78 linearization-order [ instructions>> ] map concat ;