Fix escape analysis bug; speedup on fib4 benchmark

basis/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -103,6 +103,9 @@ DEFER: copy-value
     [ [ allocation copy-allocation ] dip record-allocation ]
     2bi ;
 
+: copy-values ( from to -- )
+    [ copy-value ] 2each ;
+
 : copy-slot-value ( out slot# in -- )
     allocation {
         { [ dup not ] [ 3drop ] }

basis/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -42,24 +42,26 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
+    [ label>> return>> in-d>> introduce-values ]
+    [
         [
             child>>
             [ first out-d>> introduce-values ]
             [ first analyze-recursive-phi ]
             [ (escape-analysis) ]
             tri
-    ] until-fixed-point ;
+        ] until-fixed-point
+    ] bi ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive
     drop ;
 
-: return-allocations ( node -- allocations )
-    label>> return>> node-input-allocations ;
-
 M: #call-recursive escape-analysis* ( #call-label -- )
-    [ ] [ return-allocations ] [ node-output-allocations ] tri
-    [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
+    [ ] [ label>> return>> ] [ node-output-allocations ] tri
+    [ [ node-input-allocations ] dip check-fixed-point ]
+    [ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ]
+    3bi ;
 
 M: #return-recursive escape-analysis* ( #return-recursive -- )
     [ call-next-method ]

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -13,7 +13,7 @@ IN: compiler.tree.escape-analysis.simple
 
 M: #terminate escape-analysis* drop ;
 
-M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+M: #renaming escape-analysis* inputs/outputs copy-values ;
 
 M: #introduce escape-analysis* out-d>> unknown-allocations ;
 

basis/compiler/tree/normalization/normalization.factor

@@ -204,5 +204,6 @@ M: node normalize* ;
     H{ } clone rename-map set
     dup [ collect-label-info ] each-node
     dup count-introductions make-values
-    [ (normalize) ] [ nip #introduce ] 2bi prefix
+    [ (normalize) ] [ nip ] 2bi
+    dup empty? [ drop ] [ #introduce prefix ] if
     rename-node-values ;

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -46,3 +46,10 @@ TUPLE: empty-tuple ;
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
 
 [ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
+
+TUPLE: box { i read-only } ;
+
+: box-test ( m -- n )
+    dup box-test i>> swap box-test drop box boa ; inline recursive
+
+[ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test

extra/benchmark/fib4/fib4.factor

@@ -1,7 +1,7 @@
 USING: accessors math kernel debugger ;
 IN: benchmark.fib4
 
-TUPLE: box i ;
+TUPLE: box { i read-only } ;
 
 C: <box> box
 
@@ -15,8 +15,8 @@ C: <box> box
         i>> 1- <box>
         tuple-fib
         swap i>> swap i>> + <box>
-    ] if ;
+    ] if ; inline recursive
 
-: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
+: fib-main ( -- ) T{ box f 34 } tuple-fib i>> 9227465 assert= ;
 
 MAIN: fib-main