1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs deques dlists hashtables kernel
4 make sorting namespaces sequences combinators
5 combinators.short-circuit fry math compiler.cfg.rpo
6 compiler.cfg.utilities compiler.cfg.loop-detection
7 compiler.cfg.predecessors sets hash-sets ;
8 FROM: namespaces => set ;
9 IN: compiler.cfg.linearization
11 ! This is RPO except loops are rotated and unlikely blocks go
12 ! at the end. Based on SBCL's src/compiler/control.lisp
16 SYMBOLS: work-list loop-heads visited ;
18 : visited? ( bb -- ? ) visited get in? ;
20 : add-to-work-list ( bb -- )
21 dup visited? [ drop ] [
22 work-list get push-back
25 : init-linearization-order ( cfg -- )
27 HS{ } clone visited set
28 entry>> add-to-work-list ;
30 : (find-alternate-loop-head) ( bb -- bb' )
32 [ predecessor visited? not ]
33 [ predecessors>> length 1 = ]
34 [ predecessor successors>> length 1 = ]
35 [ [ number>> ] [ predecessor number>> ] bi > ]
36 } 1&& [ predecessor (find-alternate-loop-head) ] when ;
38 : find-back-edge ( bb -- pred )
39 [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
41 : find-alternate-loop-head ( bb -- bb' )
42 dup find-back-edge dup visited? [ drop ] [
43 nip (find-alternate-loop-head)
46 : predecessors-ready? ( bb -- ? )
47 [ predecessors>> ] keep '[
49 [ 2drop t ] [ drop visited? ] if
52 : process-successor ( bb -- )
53 dup predecessors-ready? [
54 dup loop-entry? [ find-alternate-loop-head ] when
58 : sorted-successors ( bb -- seq )
59 successors>> <reversed> [ loop-nesting-at ] sort-with ;
61 : process-block ( bb -- )
62 dup visited? [ drop ] [
64 [ visited get adjoin ]
65 [ sorted-successors [ process-successor ] each ]
69 : (linearization-order) ( cfg -- bbs )
70 init-linearization-order
72 [ work-list get [ process-block ] slurp-deque ] { } make
73 ! [ unlikely?>> not ] partition append
78 : linearization-order ( cfg -- bbs )
79 needs-post-order needs-loops needs-predecessors
81 dup linear-order>> [ ] [
82 dup (linearization-order)
83 >>linear-order linear-order>>
88 : block-number ( bb -- n ) numbers get at ;
90 : number-blocks ( bbs -- )
91 [ 2array ] map-index >hashtable numbers set ;