1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel accessors words assocs sequences arrays namespaces
4 fry locals definitions classes.algebra
8 compiler.tree.propagation.info
9 compiler.tree.dead-code.liveness ;
10 IN: compiler.tree.dead-code.simple
12 : flushable? ( word -- ? )
13 [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
15 : flushable-call? ( #call -- ? )
16 dup word>> dup flushable? [
17 "input-classes" word-prop dup [
18 [ node-input-infos ] dip
19 [ [ class>> ] dip class<= ] 2all?
23 M: #call mark-live-values*
24 dup flushable-call? [ drop ] [ look-at-inputs ] if ;
26 M: #alien-invoke mark-live-values* look-at-inputs ;
28 M: #alien-indirect mark-live-values* look-at-inputs ;
30 M: #return mark-live-values* look-at-inputs ;
32 : look-at-mapping ( value inputs outputs -- )
33 [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
35 M: #copy compute-live-values*
36 #! If the output of a copy is live, then the corresponding
37 #! input is live also.
38 [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
40 M: #call compute-live-values* nip look-at-inputs ;
42 M: #>r compute-live-values*
43 [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
45 M: #r> compute-live-values*
46 [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
48 M: #shuffle compute-live-values*
49 mapping>> at look-at-value ;
51 M: #alien-invoke compute-live-values* nip look-at-inputs ;
53 M: #alien-indirect compute-live-values* nip look-at-inputs ;
55 : filter-mapping ( assoc -- assoc' )
56 live-values get '[ drop _ key? ] assoc-filter ;
58 : filter-corresponding ( new old -- old' )
59 #! Remove elements from 'old' if the element with the same
60 #! index in 'new' is dead.
61 zip filter-mapping values ;
63 : filter-live ( values -- values' )
64 [ live-value? ] filter ;
66 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
72 filter-corresponding zip #shuffle ; inline
74 :: drop-dead-values ( outputs -- #shuffle )
75 [let* | new-outputs [ outputs make-values ]
76 live-outputs [ outputs filter-live ] |
84 : drop-dead-outputs ( node -- #shuffle )
85 dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
87 : some-outputs-dead? ( #call -- ? )
88 out-d>> [ live-value? not ] contains? ;
90 : maybe-drop-dead-outputs ( node -- nodes )
91 dup some-outputs-dead? [
92 dup drop-dead-outputs 2array
95 M: #introduce remove-dead-code* ( #introduce -- nodes )
96 maybe-drop-dead-outputs ;
98 M: #>r remove-dead-code*
99 [ filter-live ] change-out-r
100 [ filter-live ] change-in-d
101 dup in-d>> empty? [ drop f ] when ;
103 M: #r> remove-dead-code*
104 [ filter-live ] change-out-d
105 [ filter-live ] change-in-r
106 dup in-r>> empty? [ drop f ] when ;
108 M: #push remove-dead-code*
109 dup out-d>> first live-value? [ drop f ] unless ;
111 : dead-flushable-call? ( #call -- ? )
112 dup flushable-call? [
113 out-d>> [ live-value? not ] all?
116 : remove-flushable-call ( #call -- node )
117 [ word>> flushed-dependency depends-on ]
118 [ in-d>> #drop remove-dead-code* ]
121 M: #call remove-dead-code*
122 dup dead-flushable-call?
123 [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
125 M: #shuffle remove-dead-code*
126 [ filter-live ] change-in-d
127 [ filter-live ] change-out-d
128 [ filter-mapping ] change-mapping
129 dup in-d>> empty? [ drop f ] when ;
131 M: #copy remove-dead-code*
132 [ in-d>> ] [ out-d>> ] bi
133 2dup swap zip #shuffle
136 M: #terminate remove-dead-code*
137 [ filter-live ] change-in-d
138 [ filter-live ] change-in-r ;
140 M: #alien-invoke remove-dead-code*
141 maybe-drop-dead-outputs ;
143 M: #alien-indirect remove-dead-code*
144 maybe-drop-dead-outputs ;