1 ! Copyright (C) 2009, 2010 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators compiler.cfg.def-use
4 compiler.cfg.instructions compiler.cfg.registers fry kernel
5 locals namespaces sequences sets sorting math.vectors
6 make math combinators.short-circuit vectors ;
7 FROM: namespaces => set ;
8 IN: compiler.cfg.dependence
10 ! Dependence graph construction
19 ! Nodes in the dependency graph
20 ! These need to be numbered so that the same instruction
21 ! will get distinct nodes if it occurs multiple times
23 number insn precedes follows
25 registers parent-index ;
27 M: node equal? [ number>> ] bi@ = ;
29 M: node hashcode* nip number>> ;
31 : <node> ( insn -- node )
33 node-number counter >>number
36 V{ } clone >>follows ;
38 : ready? ( node -- ? ) precedes>> assoc-empty? ;
40 :: precedes ( first second how -- )
41 how second first precedes>> set-at ;
43 :: add-data-edges ( nodes -- )
44 ! This builds up def-use information on the fly, since
45 ! we only care about local def-use
46 H{ } clone :> definers
48 node insn>> defs-vreg [ node swap definers set-at ] when*
49 node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
52 UNION: stack-insn ##peek ##replace ##replace-imm ;
58 ##load-memory ##load-memory-imm
59 ##store-memory ##store-memory-imm ;
61 UNION: alien-call-insn
63 ##alien-invoke ##alien-indirect ##alien-callback
64 ##unary-float-function ##binary-float-function ;
66 : chain ( node var -- )
68 pick +control+ precedes
72 GENERIC: add-control-edge ( node insn -- )
74 M: stack-insn add-control-edge
77 M: memory-insn add-control-edge
78 drop memory-insn chain ;
80 M: slot-insn add-control-edge
81 drop slot-insn chain ;
83 M: alien-call-insn add-control-edge
84 drop alien-call-insn chain ;
86 M: object add-control-edge 2drop ;
88 : add-control-edges ( nodes -- )
90 [ dup insn>> add-control-edge ] each
93 : set-follows ( nodes -- )
100 : set-roots ( nodes -- )
101 [ ready? ] V{ } filter-as roots set ;
103 : build-dependence-graph ( instructions -- )
105 [ add-control-edges ]
112 ! Sethi-Ulmann numbering
113 :: calculate-registers ( node -- registers )
114 node children>> [ 0 ] [
115 [ [ calculate-registers ] map natural-sort ]
119 node insn>> temp-vregs length +
120 dup node (>>registers) ;
122 ! Constructing fan-in trees
124 : attach-parent ( node parent -- )
126 [ [ ?push ] change-children drop ] 2bi ;
128 : keys-for ( assoc value -- keys )
129 '[ nip _ = ] assoc-filter keys ;
131 : choose-parent ( node -- )
132 ! If a node has control dependences, it has to be a root
133 ! Otherwise, choose one of the data dependences for a parent
134 dup precedes>> +control+ keys-for empty? [
135 dup precedes>> +data+ keys-for [ drop ] [
140 : make-trees ( -- trees )
142 [ [ choose-parent ] each ]
143 [ [ parent>> not ] filter ] bi ;
145 ERROR: node-missing-parent trees nodes ;
146 ERROR: node-missing-children trees nodes ;
148 : flatten-tree ( node -- nodes )
149 [ children>> [ flatten-tree ] map concat ] keep
152 : verify-parents ( trees -- trees )
153 nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
154 [ nodes get node-missing-parent ] unless ;
156 : verify-children ( trees -- trees )
157 dup [ flatten-tree ] map concat
159 { [ [ length ] bi@ = ] [ set= ] } 2&&
160 [ nodes get node-missing-children ] unless ;
162 : verify-trees ( trees -- trees )
163 verify-parents verify-children ;
165 : build-fan-in-trees ( -- )
166 make-trees verify-trees [
168 calculate-registers drop