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 IN: compiler.cfg.linearization
9 ! This is RPO except loops are rotated and unlikely blocks go
10 ! at the end. Based on SBCL's src/compiler/control.lisp
14 SYMBOLS: loop-heads visited ;
16 : visited? ( bb -- ? ) visited get in? ;
18 : predecessors-ready? ( bb -- ? )
19 [ predecessors>> ] keep '[
21 [ 2drop t ] [ drop visited? ] if
24 : (find-alternate-loop-head) ( bb -- bb' )
26 [ predecessor visited? not ]
27 [ predecessors>> length 1 = ]
28 [ predecessor successors>> length 1 = ]
29 [ [ number>> ] [ predecessor number>> ] bi > ]
30 } 1&& [ predecessor (find-alternate-loop-head) ] when ;
32 : find-back-edge ( bb -- pred )
33 [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
35 : find-alternate-loop-head ( bb -- bb' )
36 dup find-back-edge dup visited? [ drop ] [
37 nip (find-alternate-loop-head)
40 : sorted-successors ( bb -- seq )
41 successors>> <reversed> [ loop-nesting-at ] sort-with ;
43 : process-block ( bb -- bbs )
44 dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
45 [ predecessors-ready? ] filter
46 [ dup loop-entry? [ find-alternate-loop-head ] when ] map
49 : (linearization-order) ( cfg -- bbs )
50 HS{ } clone visited set
51 entry>> <dlist> [ push-back ] keep
52 [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
56 : linearization-order ( cfg -- bbs )
60 [ needs-predecessors ]
62 dup linear-order>> [ ] [
63 dup (linearization-order)
64 >>linear-order linear-order>>
71 : block-number ( bb -- n ) numbers get at ;
73 : number-blocks ( bbs -- )
74 H{ } zip-index-as numbers set ;
76 : blocks>insns ( bbs -- insns )
77 [ instructions>> ] map concat ;
79 : cfg>insns ( cfg -- insns )
80 linearization-order blocks>insns ;
82 : cfg>insns-rpo ( cfg -- insns )
83 reverse-post-order blocks>insns ;