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: #shuffle compute-live-values*
43 mapping>> at look-at-value ;
45 M: #alien-invoke compute-live-values* nip look-at-inputs ;
47 M: #alien-indirect compute-live-values* nip look-at-inputs ;
49 : filter-mapping ( assoc -- assoc' )
50 live-values get '[ drop _ key? ] assoc-filter ;
52 : filter-corresponding ( new old -- old' )
53 #! Remove elements from 'old' if the element with the same
54 #! index in 'new' is dead.
55 zip filter-mapping values ;
57 : filter-live ( values -- values' )
58 dup empty? [ [ live-value? ] filter ] unless ;
60 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
66 filter-corresponding zip #data-shuffle ; inline
68 :: drop-dead-values ( outputs -- #shuffle )
69 [let* | new-outputs [ outputs make-values ]
70 live-outputs [ outputs filter-live ] |
78 : drop-dead-outputs ( node -- #shuffle )
79 dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
81 : some-outputs-dead? ( #call -- ? )
82 out-d>> [ live-value? not ] any? ;
84 : maybe-drop-dead-outputs ( node -- nodes )
85 dup some-outputs-dead? [
86 dup drop-dead-outputs 2array
89 M: #introduce remove-dead-code* ( #introduce -- nodes )
90 maybe-drop-dead-outputs ;
92 M: #push remove-dead-code*
93 dup out-d>> first live-value? [ drop f ] unless ;
95 : dead-flushable-call? ( #call -- ? )
97 out-d>> [ live-value? not ] all?
100 : remove-flushable-call ( #call -- node )
101 [ word>> flushed-dependency depends-on ]
102 [ in-d>> #drop remove-dead-code* ]
105 M: #call remove-dead-code*
106 dup dead-flushable-call?
107 [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
109 M: #shuffle remove-dead-code*
110 [ filter-live ] change-in-d
111 [ filter-live ] change-out-d
112 [ filter-live ] change-in-r
113 [ filter-live ] change-out-r
114 [ filter-mapping ] change-mapping
115 dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
117 M: #copy remove-dead-code*
118 [ in-d>> ] [ out-d>> ] bi
119 2dup swap zip #data-shuffle
122 M: #terminate remove-dead-code*
123 [ filter-live ] change-in-d
124 [ filter-live ] change-in-r ;
126 M: #alien-invoke remove-dead-code*
127 maybe-drop-dead-outputs ;
129 M: #alien-indirect remove-dead-code*
130 maybe-drop-dead-outputs ;