-IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization math.functions
-compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math math.private
-kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple
-compiler.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors kernel.private ;
-
-\ escape-analysis must-infer
+compiler.tree.recursive compiler.tree.normalization
+math.functions compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.combinators compiler.tree sequences math
+math.private kernel tools.test accessors slots.private
+quotations.private prettyprint classes.tuple.private classes
+classes.tuple namespaces
+compiler.tree.propagation.info stack-checker.errors
+compiler.tree.checker
+kernel.private vectors ;
+IN: compiler.tree.escape-analysis.tests
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
- out-d>> first escaping-allocation? [ 1+ ] unless ;
+ out-d>> first escaping-allocation? [ 1 + ] unless ;
M: #call count-unboxed-allocations*
- dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
+ dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
dup literal>> class immutable-tuple-class?
[ (count-unboxed-allocations) ] [ drop ] if ;
+M: #introduce count-unboxed-allocations*
+ out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
+
M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
+ analyze-recursive
normalize
propagate
cleanup
escape-analysis
+ dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup tuple-fib
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
tuple-fib
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: tuple-fib' ( m -- n )
- dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+ dup 1 <= [ 1 - tuple-fib' i>> ] when <ro-box> ; inline recursive
[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-1
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-1 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-2
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-2
+ 1 - dup tuple-fib-2
swap
- 1- tuple-fib-2
+ 1 - tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-3
+ 1 - dup tuple-fib-3
swap
- 1- tuple-fib-3 dup .
+ 1 - tuple-fib-3 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup bad-tuple-fib-3
+ 1 - dup bad-tuple-fib-3
swap
- 1- bad-tuple-fib-3
+ 1 - bad-tuple-fib-3
2drop f
] if ; inline recursive
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
-[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
- dup slip impeach-node ; inline recursive
+ [ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
-[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
[ 0 ] [
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
] unit-test
+
+! Doug found a regression
+
+TUPLE: empty-tuple ;
+
+[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! New feature!
+
+[ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [
+ [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ { vector } declare length>> ]
+ count-unboxed-allocations
+] unit-test