Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / compiler / tree / escape-analysis / escape-analysis-tests.factor

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index bcb8b2f80a2b4c5c4d0b1a92d2b13195f86b6e79..debb66b8d42044589aee98489e6d00b849b95a39 100644 (file)
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -1,4 +1,3 @@
-IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
 compiler.tree.recursive compiler.tree.normalization
@@ -9,21 +8,25 @@ quotations.private prettyprint classes.tuple.private classes
 classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
 compiler.tree.checker
-kernel.private ;
+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 )
@@ -209,10 +212,10 @@ C: <ro-box> ro-box
     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
@@ -222,7 +225,7 @@ C: <ro-box> ro-box
 [ 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
 
@@ -230,10 +233,10 @@ C: <ro-box> ro-box
     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
@@ -245,10 +248,10 @@ C: <ro-box> ro-box
     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
@@ -259,9 +262,9 @@ C: <ro-box> ro-box
     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
 
@@ -271,9 +274,9 @@ C: <ro-box> ro-box
     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
 
@@ -283,15 +286,15 @@ C: <ro-box> ro-box
     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
 
@@ -302,7 +305,7 @@ C: <ro-box> ro-box
 [ 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
@@ -322,3 +325,23 @@ C: <ro-box> ro-box
 [ 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