1 USING: namespaces assocs sequences compiler.tree.builder
2 compiler.tree.dead-code compiler.tree.def-use compiler.tree
3 compiler.tree.combinators compiler.tree.propagation
4 compiler.tree.cleanup compiler.tree.escape-analysis
5 compiler.tree.tuple-unboxing compiler.tree.debugger
6 compiler.tree.recursive compiler.tree.normalization
7 compiler.tree.checker tools.test kernel math stack-checker.state
8 accessors combinators io prettyprint words sequences.deep
9 sequences.private arrays classes kernel.private shuffle
11 IN: compiler.tree.dead-code.tests
13 : count-live-values ( quot -- n )
25 [ #push? ] [ #introduce? ] bi or
26 [ out-d>> length + ] [ drop ] if
29 [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
31 [ 1 ] [ [ drop ] count-live-values ] unit-test
33 [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
35 [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
37 [ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
39 [ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
41 [ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
43 [ 2 ] [ [ 1 + ] count-live-values ] unit-test
45 [ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
47 [ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
49 [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
51 [ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
53 [ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
55 [ 0 ] [ [ [ ] call ] count-live-values ] unit-test
57 [ 1 ] [ [ [ 1 ] call ] count-live-values ] unit-test
59 [ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
61 [ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
63 [ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
65 : optimize-quot ( quot -- quot' )
75 "no-check" get [ dup check-nodes ] unless nodes>quot ;
77 [ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
79 [ [ stream-read1 drop 1 2 ] ] [ [ stream-read1 [ 1 2 ] dip drop ] optimize-quot ] unit-test
81 [ [ over >R + R> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
83 [ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
85 : flushable-1 ( a b -- c ) 2drop f ; flushable
86 : flushable-2 ( a b -- c ) 2drop f ; flushable
88 [ [ 2nip [ ] [ ] if ] ] [
89 [ [ flushable-1 ] [ flushable-2 ] if drop ] optimize-quot
92 : non-flushable-3 ( a b -- c ) 2drop f ;
94 [ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [
95 [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
98 [ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
100 [ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
102 [ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
104 [ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
106 [ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
108 : boo ( a b -- c ) 2drop f ;
110 [ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
112 : squish ( quot -- quot' )
115 { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
116 { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
121 : call-recursive-dce-1 ( a -- b )
122 [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
124 [ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
125 [ call-recursive-dce-1 ] optimize-quot squish
128 : produce-a-value ( -- a ) f ;
130 : call-recursive-dce-2 ( a -- b )
132 produce-a-value dup . call-recursive-dce-2 ; inline recursive
134 [ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
135 [ f call-recursive-dce-2 drop ] optimize-quot squish
138 [ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
139 [ f call-recursive-dce-2 ] optimize-quot squish
142 : call-recursive-dce-3 ( a -- )
143 call-recursive-dce-3 ; inline recursive
145 [ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
146 [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
149 [ [ drop "WRAP" [ "REC" ] label ] ] [
150 [ call-recursive-dce-3 ] optimize-quot squish
153 : call-recursive-dce-4 ( a -- b )
154 call-recursive-dce-4 ; inline recursive
156 [ [ drop "WRAP" [ "REC" ] label ] ] [
157 [ call-recursive-dce-4 ] optimize-quot squish
160 [ [ drop "WRAP" [ "REC" ] label ] ] [
161 [ call-recursive-dce-4 drop ] optimize-quot squish
164 [ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
166 : call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
168 [ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
170 [ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
172 : call-recursive-dce-6 ( i quot: ( ..a -- ..b ) -- i )
173 dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
175 [ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
177 [ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
179 [ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
181 [ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
183 [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
185 [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
187 : call-recursive-dce-7 ( obj -- elt ? )
188 dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
190 [ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test
192 [ [ /i ] ] [ [ /mod drop ] optimize-quot ] unit-test
194 [ [ mod ] ] [ [ /mod nip ] optimize-quot ] unit-test
196 [ [ fixnum/i ] ] [ [ { fixnum fixnum } declare /mod drop ] optimize-quot ] unit-test
198 [ [ fixnum-mod ] ] [ [ { fixnum fixnum } declare /mod nip ] optimize-quot ] unit-test
200 [ [ bignum/i ] ] [ [ { bignum bignum } declare /mod drop ] optimize-quot ] unit-test
202 [ [ bignum-mod ] ] [ [ { bignum bignum } declare /mod nip ] optimize-quot ] unit-test
204 [ [ /i ] ] [ [ /mod drop ] optimize-quot ] unit-test
206 [ [ mod ] ] [ [ /mod nip ] optimize-quot ] unit-test