1 IN: compiler.tree.escape-analysis.tests
2 USING: compiler.tree.escape-analysis
3 compiler.tree.escape-analysis.allocations compiler.tree.builder
4 compiler.tree.normalization math.functions
5 compiler.tree.propagation compiler.tree.cleanup
6 compiler.tree.combinators compiler.tree sequences math math.private
7 kernel tools.test accessors slots.private quotations.private
8 prettyprint classes.tuple.private classes classes.tuple
9 compiler.tree.intrinsics namespaces compiler.tree.propagation.info
10 stack-checker.errors kernel.private ;
12 \ escape-analysis must-infer
14 GENERIC: count-unboxed-allocations* ( m node -- n )
16 : (count-unboxed-allocations) ( m node -- n )
17 out-d>> first escaping-allocation? [ 1+ ] unless ;
19 M: #call count-unboxed-allocations*
20 dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
21 [ (count-unboxed-allocations) ] [ drop ] if ;
23 M: #push count-unboxed-allocations*
24 dup literal>> class immutable-tuple-class?
25 [ (count-unboxed-allocations) ] [ drop ] if ;
27 M: node count-unboxed-allocations* drop ;
29 : count-unboxed-allocations ( quot -- sizes )
35 0 swap [ count-unboxed-allocations* ] each-node ;
37 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
39 [ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
41 [ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
43 [ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
45 [ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
47 [ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
49 [ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
51 [ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
54 [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
58 [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
62 [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
66 [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
70 [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
73 TUPLE: cons { car read-only } { cdr read-only } ;
84 ] count-unboxed-allocations
98 ] count-unboxed-allocations
110 ] count-unboxed-allocations
124 ] count-unboxed-allocations
138 ] count-unboxed-allocations
143 [ dup cons boa ] [ drop 1 2 cons boa ] if car>>
144 ] count-unboxed-allocations
150 [ cons boa ] [ cons boa 3 cons boa ] if
151 [ car>> ] [ cdr>> ] bi
152 ] count-unboxed-allocations
157 3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
158 [ car>> ] [ cdr>> ] bi
159 ] count-unboxed-allocations
163 [ [ 3 cons boa ] [ "A" throw ] if car>> ]
164 count-unboxed-allocations
168 [ 10 [ drop ] each-integer ] count-unboxed-allocations
173 1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
174 ] count-unboxed-allocations
179 1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
180 ] count-unboxed-allocations
183 : infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
187 1 2 cons boa infinite-cons-loop
188 ] count-unboxed-allocations
195 [ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
197 : fake-fib ( m -- n )
198 dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
200 [ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
202 TUPLE: ro-box { i read-only } ;
206 : tuple-fib ( m -- n )
215 swap i>> swap i>> + <ro-box>
216 ] if ; inline recursive
218 [ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
220 [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
222 : tuple-fib' ( m -- n )
223 dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
225 [ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
227 : bad-tuple-fib-1 ( m -- n )
235 bad-tuple-fib-1 dup .
236 swap i>> swap i>> + <ro-box>
237 ] if ; inline recursive
239 [ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
241 : bad-tuple-fib-2 ( m -- n )
251 swap i>> swap i>> + <ro-box>
252 ] if ; inline recursive
254 [ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
256 : tuple-fib-2 ( m -- n )
263 swap i>> swap i>> + <ro-box>
264 ] if ; inline recursive
266 [ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
268 : tuple-fib-3 ( m -- n )
275 swap i>> swap i>> + <ro-box>
276 ] if ; inline recursive
278 [ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
280 : bad-tuple-fib-3 ( m -- n )
284 1- dup bad-tuple-fib-3
288 ] if ; inline recursive
290 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
292 [ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
294 [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
296 [ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
298 [ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
300 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
302 : impeach-node ( quot: ( node -- ) -- )
303 dup slip impeach-node ; inline recursive
305 : bleach-node ( quot: ( node -- ) -- )
306 [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
308 [ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
311 [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
312 count-unboxed-allocations
316 [ \ too-many->r boa f f \ inference-error boa ]
317 count-unboxed-allocations
321 [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations