1 ! Copyright (C) 2008, 2010 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-node mark-live-values* look-at-inputs ;
33 M: #return mark-live-values* look-at-inputs ;
35 : look-at-mapping ( value inputs outputs -- )
36 [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
38 M: #copy compute-live-values*
39 #! If the output of a copy is live, then the corresponding
40 #! input is live also.
41 [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
43 M: #call compute-live-values* nip look-at-inputs ;
45 M: #shuffle compute-live-values*
46 mapping>> at look-at-value ;
48 M: #alien-node compute-live-values* nip look-at-inputs ;
50 : filter-mapping ( assoc -- assoc' )
51 live-values get '[ drop _ key? ] assoc-filter ;
53 : filter-corresponding ( new old -- old' )
54 #! Remove elements from 'old' if the element with the same
55 #! index in 'new' is dead.
56 zip filter-mapping values ;
58 : filter-live ( values -- values' )
59 dup empty? [ [ live-value? ] filter ] unless ;
61 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
67 filter-corresponding zip #data-shuffle ; inline
69 :: drop-dead-values ( outputs -- #shuffle )
70 outputs length make-values :> new-outputs
71 outputs filter-live :> live-outputs
78 : drop-dead-outputs ( node -- #shuffle )
79 dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
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-node remove-dead-code*
127 maybe-drop-dead-outputs ;