1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors classes classes.algebra combinators
4 compiler.tree compiler.tree.combinators
5 compiler.tree.propagation.branches
6 compiler.tree.propagation.info compiler.utilities fry kernel
7 layouts math math.intervals math.partial-dispatch math.private
8 namespaces sequences stack-checker.branches
9 stack-checker.dependencies words ;
10 IN: compiler.tree.cleanup
12 GENERIC: delete-node ( node -- )
14 M: #call-recursive delete-node
15 dup label>> calls>> [ node>> eq? not ] with filter! drop ;
17 M: #return-recursive delete-node
18 label>> f >>return drop ;
20 M: node delete-node drop ;
22 : delete-nodes ( nodes -- ) [ delete-node ] each-node ;
24 GENERIC: cleanup* ( node -- node/nodes )
26 : cleanup ( nodes -- nodes' )
27 #! We don't recurse into children here, instead the methods
28 #! do it since the logic is a bit more involved
29 [ cleanup* ] map-flat ;
32 : cleanup-folding? ( #call -- ? )
34 [ f ] [ [ literal?>> ] all? ] if-empty ;
36 : (cleanup-folding) ( #call -- nodes )
37 #! Replace a #call having a known result with a #drop of its
38 #! inputs followed by #push nodes for the outputs.
40 [ node-output-infos ] [ out-d>> ] bi
41 [ [ literal>> ] dip <#push> ] 2map
46 : >predicate-folding< ( #call -- value-info class result )
47 [ node-input-infos first ]
48 [ word>> "predicating" word-prop ]
49 [ node-output-infos first literal>> ] tri ;
51 : record-predicate-folding ( #call -- )
52 >predicate-folding< pick literal?>>
53 [ [ literal>> ] 2dip add-depends-on-instance-predicate ]
54 [ [ class>> ] 2dip add-depends-on-class-predicate ]
57 : record-folding ( #call -- )
59 [ record-predicate-folding ]
60 [ word>> add-depends-on-definition ]
63 : cleanup-folding ( #call -- nodes )
64 [ (cleanup-folding) ] [ record-folding ] bi ;
67 : add-method-dependency ( #call -- )
69 [ [ class>> ] [ word>> ] bi add-depends-on-generic ]
70 [ [ class>> ] [ word>> ] [ method>> ] tri add-depends-on-method ]
74 : record-inlining ( #call -- )
76 [ add-method-dependency ]
77 [ word>> add-depends-on-definition ] if ;
79 : cleanup-inlining ( #call -- nodes )
80 [ record-inlining ] [ body>> cleanup ] bi ;
82 ! Removing overflow checks
83 : (remove-overflow-check?) ( #call -- ? )
84 node-output-infos first class>> fixnum class<= ;
86 : small-shift? ( #call -- ? )
87 node-input-infos second interval>>
88 cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
90 : remove-overflow-check? ( #call -- ? )
92 { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
93 { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
97 : remove-overflow-check ( #call -- #call )
98 [ no-overflow-variant ] change-word cleanup* ;
102 { [ dup body>> ] [ cleanup-inlining ] }
103 { [ dup cleanup-folding? ] [ cleanup-folding ] }
104 { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
108 : delete-unreachable-branches ( #branch -- )
109 dup live-branches>> '[
111 [ [ [ drop ] [ delete-nodes ] if ] 2each ]
114 ] change-children drop ;
116 : fold-only-branch ( #branch -- node/nodes )
117 #! If only one branch is live we don't need to branch at
118 #! all; just drop the condition value.
119 dup live-children sift dup length {
120 { 0 [ drop in-d>> <#drop> ] }
121 { 1 [ first swap in-d>> <#drop> prefix ] }
125 SYMBOL: live-branches
127 : cleanup-children ( #branch -- )
128 [ [ cleanup ] map ] change-children drop ;
132 [ delete-unreachable-branches ]
135 [ live-branches>> live-branches set ]
138 : output-fs ( values -- nodes )
139 [ f swap <#push> ] map ;
141 : eliminate-single-phi ( #phi -- node )
142 [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
143 [ [ drop ] [ output-fs ] bi* ]
147 : eliminate-phi ( #phi -- node )
148 live-branches get sift length {
149 { 0 [ out-d>> output-fs ] }
150 { 1 [ eliminate-single-phi ] }
155 #! Remove #phi function inputs which no longer exist.
157 [ '[ _ sift-children ] change-phi-in-d ]
158 [ '[ _ sift-children ] change-phi-info-d ]
159 [ '[ _ sift-children ] change-terminated ] tri
163 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
165 : flatten-recursive ( #recursive -- nodes )
166 #! convert #enter-recursive and #return-recursive into
170 unclip-last >copy suffix ;
172 M: #recursive cleanup*
173 #! Inline bodies of #recursive blocks with no calls left.
174 [ cleanup ] change-child
175 dup label>> calls>> empty? [ flatten-recursive ] when ;
177 M: #alien-callback cleanup*
178 [ cleanup ] change-child ;