1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes.algebra combinators
4 combinators.short-circuit compiler.tree
5 compiler.tree.dead-code.liveness compiler.tree.propagation.info
6 fry kernel locals math math.private namespaces sequences
7 stack-checker.backend stack-checker.dependencies words ;
8 IN: compiler.tree.dead-code.simple
10 : flushable-call? ( #call -- ? )
11 dup word>> dup flushable? [
13 [ node-input-infos ] dip
14 [ value-info<= ] 2all?
18 M: #call mark-live-values*
19 dup flushable-call? [ drop ] [ look-at-inputs ] if ;
21 M: #alien-node mark-live-values* look-at-inputs ;
23 M: #return mark-live-values* look-at-inputs ;
25 : look-at-mapping ( value inputs outputs -- )
26 [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
28 M: #copy compute-live-values*
29 ! If the output of a copy is live, then the corresponding
31 [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
33 M: #call compute-live-values* nip look-at-inputs ;
35 M: #shuffle compute-live-values*
36 mapping>> at look-at-value ;
38 M: #alien-node compute-live-values* nip look-at-inputs ;
40 : filter-mapping ( assoc -- assoc' )
41 live-values get '[ drop _ key? ] assoc-filter ;
43 : filter-corresponding ( new old -- old' )
44 zip filter-mapping values ;
46 : filter-live ( values -- values' )
47 dup empty? [ live-values get '[ _ at ] filter ] unless ;
49 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
55 filter-corresponding zip <#data-shuffle> ; inline
57 :: drop-dead-values ( outputs -- #shuffle )
58 outputs length make-values :> new-outputs
59 outputs filter-live :> live-outputs
66 : drop-dead-outputs ( node -- #shuffle )
67 dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
69 : some-outputs-dead? ( #call -- ? )
70 out-d>> [ live-value? not ] any? ;
72 : maybe-drop-dead-outputs ( node -- nodes )
73 dup some-outputs-dead? [
74 dup drop-dead-outputs 2array
77 M: #introduce remove-dead-code* ( #introduce -- nodes )
78 maybe-drop-dead-outputs ;
80 M: #push remove-dead-code*
81 dup out-d>> first live-value? [ drop f ] unless ;
83 : dead-flushable-call? ( #call -- ? )
85 out-d>> [ live-value? not ] all?
88 : remove-flushable-call ( #call -- node )
89 [ word>> add-depends-on-flushable ]
90 [ in-d>> <#drop> remove-dead-code* ]
93 : define-simplifications ( word seq -- )
94 "simplifications" set-word-prop ;
100 } define-simplifications
104 { { t f } fixnum-mod }
105 } define-simplifications
109 { { t f } bignum-mod }
110 } define-simplifications
112 : out-d-matches? ( out-d seq -- ? )
113 [ swap live-value? xor ] 2all? ;
115 : (simplify-call) ( #call -- new-word/f )
116 [ out-d>> ] [ word>> "simplifications" word-prop ] bi
117 [ first out-d-matches? ] with find nip dup [ second ] when ;
119 : simplify-call ( #call -- nodes )
120 dup (simplify-call) [
121 >>word [ filter-live ] change-out-d
123 maybe-drop-dead-outputs
126 M: #call remove-dead-code*
128 { [ dup dead-flushable-call? ] [ remove-flushable-call ] }
129 { [ dup word>> "simplifications" word-prop ] [ simplify-call ] }
130 [ maybe-drop-dead-outputs ]
133 M: #shuffle remove-dead-code*
134 [ filter-live ] change-in-d
135 [ filter-live ] change-out-d
136 [ filter-live ] change-in-r
137 [ filter-live ] change-out-r
138 [ filter-mapping ] change-mapping
139 dup { [ in-d>> empty? ] [ in-r>> empty? ] } 1&& [ drop f ] when ;
141 M: #copy remove-dead-code*
142 [ in-d>> ] [ out-d>> ] bi
143 2dup swap zip <#data-shuffle>
146 M: #terminate remove-dead-code*
147 [ filter-live ] change-in-d
148 [ filter-live ] change-in-r ;
150 M: #alien-node remove-dead-code*
151 maybe-drop-dead-outputs ;
153 M: #alien-callback remove-dead-code*
154 [ (remove-dead-code) ] change-child ;