From 6717d3743e1e3ed43d9cf8ff5e0e0da601ff6b17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 09:03:03 -0500
Subject: [PATCH] Fix escape analysis bug; speedup on fib4 benchmark

---
 .../allocations/allocations.factor            |  3 +++
 .../recursive/recursive.factor                | 24 ++++++++++---------
 .../tree/escape-analysis/simple/simple.factor |  2 +-
 .../tree/normalization/normalization.factor   |  3 ++-
 .../tuple-unboxing-tests.factor               |  7 ++++++
 extra/benchmark/fib4/fib4.factor              |  6 ++---
 6 files changed, 29 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 100ced5acd..4c197d7fc0 100644
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/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 ] }
diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
index 3d8d15e5ec..059ac1de02 100644
--- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/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 ;
+        [
+            child>>
+            [ first out-d>> introduce-values ]
+            [ first analyze-recursive-phi ]
+            [ (escape-analysis) ]
+            tri
+        ] 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 ]
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 58d721b602..d69f6cab9e 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/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 ;
 
diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor
index 98ec4ee3f0..12c7a60ec8 100644
--- a/basis/compiler/tree/normalization/normalization.factor
+++ b/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 ;
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 8135572bb1..334fcb11f0 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/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
diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor
index 580be0d0ec..c988e5722e 100644
--- a/extra/benchmark/fib4/fib4.factor
+++ b/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