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? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ;
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-vregs [ node swap definers set-at ] each
49 node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
52 UNION: stack-insn ##peek ##replace ##replace-imm ;
59 ##load-memory ##load-memory-imm
60 ##store-memory ##store-memory-imm
61 ##write-barrier ##write-barrier-imm
65 : chain ( node var -- )
67 pick +control+ precedes
71 GENERIC: add-control-edge ( node insn -- )
73 M: stack-insn add-control-edge loc>> chain ;
75 M: memory-insn add-control-edge drop memory-insn chain ;
77 M: object add-control-edge 2drop ;
79 : add-control-edges ( nodes -- )
80 [ [ dup insn>> add-control-edge ] each ] with-scope ;
82 : set-follows ( nodes -- )
89 : set-roots ( nodes -- )
90 [ ready? ] V{ } filter-as roots set ;
92 : build-dependence-graph ( instructions -- )
101 ! Sethi-Ulmann numbering
102 :: calculate-registers ( node -- registers )
103 node children>> [ 0 ] [
104 [ [ calculate-registers ] map natural-sort ]
108 node insn>> temp-vregs length +
109 dup node registers<< ;
111 ! Constructing fan-in trees
113 : attach-parent ( node parent -- )
115 [ [ ?push ] change-children drop ] 2bi ;
117 : keys-for ( assoc value -- keys )
118 '[ nip _ = ] assoc-filter keys ;
120 : choose-parent ( node -- )
121 ! If a node has control dependences, it has to be a root
122 ! Otherwise, choose one of the data dependences for a parent
123 dup precedes>> +control+ keys-for empty? [
124 dup precedes>> +data+ keys-for [ drop ] [
129 : make-trees ( -- trees )
131 [ [ choose-parent ] each ]
132 [ [ parent>> not ] filter ] bi ;
134 ERROR: node-missing-parent trees nodes ;
135 ERROR: node-missing-children trees nodes ;
137 : flatten-tree ( node -- nodes )
138 [ children>> [ flatten-tree ] map concat ] keep
141 : verify-parents ( trees -- trees )
142 nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
143 [ nodes get node-missing-parent ] unless ;
145 : verify-children ( trees -- trees )
146 dup [ flatten-tree ] map concat
148 { [ [ length ] bi@ = ] [ set= ] } 2&&
149 [ nodes get node-missing-children ] unless ;
151 : verify-trees ( trees -- trees )
152 verify-parents verify-children ;
154 : build-fan-in-trees ( -- )
155 make-trees verify-trees [
157 calculate-registers drop