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 classes.algebra generic
5 stack-checker.dependencies
8 compiler.tree.propagation.info
9 compiler.tree.dead-code.liveness ;
10 IN: compiler.tree.dead-code.simple
12 GENERIC: flushable? ( word -- ? )
14 M: predicate flushable? drop t ;
16 M: word flushable? "flushable" word-prop ;
18 M: method-body flushable? "method-generic" word-prop flushable? ;
20 : flushable-call? ( #call -- ? )
21 dup word>> dup flushable? [
22 "input-classes" word-prop dup [
23 [ node-input-infos ] dip
24 [ [ class>> ] dip class<= ] 2all?
28 M: #call mark-live-values*
29 dup flushable-call? [ drop ] [ look-at-inputs ] if ;
31 M: #alien-invoke mark-live-values* look-at-inputs ;
33 M: #alien-indirect mark-live-values* look-at-inputs ;
35 M: #return mark-live-values* look-at-inputs ;
37 : look-at-mapping ( value inputs outputs -- )
38 [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
40 M: #copy compute-live-values*
41 #! If the output of a copy is live, then the corresponding
42 #! input is live also.
43 [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
45 M: #call compute-live-values* nip look-at-inputs ;
47 M: #shuffle compute-live-values*
48 mapping>> at look-at-value ;
50 M: #alien-invoke compute-live-values* nip look-at-inputs ;
52 M: #alien-indirect compute-live-values* nip look-at-inputs ;
54 : filter-mapping ( assoc -- assoc' )
55 live-values get '[ drop _ key? ] assoc-filter ;
57 : filter-corresponding ( new old -- old' )
58 #! Remove elements from 'old' if the element with the same
59 #! index in 'new' is dead.
60 zip filter-mapping values ;
62 : filter-live ( values -- values' )
63 dup empty? [ [ live-value? ] filter ] unless ;
65 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
71 filter-corresponding zip #data-shuffle ; inline
73 :: drop-dead-values ( outputs -- #shuffle )
74 outputs make-values :> new-outputs
75 outputs filter-live :> live-outputs
82 : drop-dead-outputs ( node -- #shuffle )
83 dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
85 : some-outputs-dead? ( #call -- ? )
86 out-d>> [ live-value? not ] any? ;
88 : maybe-drop-dead-outputs ( node -- nodes )
89 dup some-outputs-dead? [
90 dup drop-dead-outputs 2array
93 M: #introduce remove-dead-code* ( #introduce -- nodes )
94 maybe-drop-dead-outputs ;
96 M: #push remove-dead-code*
97 dup out-d>> first live-value? [ drop f ] unless ;
99 : dead-flushable-call? ( #call -- ? )
100 dup flushable-call? [
101 out-d>> [ live-value? not ] all?
104 : remove-flushable-call ( #call -- node )
105 [ word>> flushed-dependency depends-on ]
106 [ in-d>> #drop remove-dead-code* ]
109 M: #call remove-dead-code*
110 dup dead-flushable-call?
111 [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
113 M: #shuffle remove-dead-code*
114 [ filter-live ] change-in-d
115 [ filter-live ] change-out-d
116 [ filter-live ] change-in-r
117 [ filter-live ] change-out-r
118 [ filter-mapping ] change-mapping
119 dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
121 M: #copy remove-dead-code*
122 [ in-d>> ] [ out-d>> ] bi
123 2dup swap zip #data-shuffle
126 M: #terminate remove-dead-code*
127 [ filter-live ] change-in-d
128 [ filter-live ] change-in-r ;
130 M: #alien-invoke remove-dead-code*
131 maybe-drop-dead-outputs ;
133 M: #alien-indirect remove-dead-code*
134 maybe-drop-dead-outputs ;