From b963d56aacf9f85b26f0c19cb804197da05ae093 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 16 Feb 2010 14:44:13 +1300
Subject: [PATCH] compiler.tree.escape-analysis: fix bug that comes up when
 inheritance is used

---
 .../escape-analysis-tests.factor              | 15 +++++++++++++
 .../tree/escape-analysis/simple/simple.factor | 22 ++++++++++++-------
 2 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 6c50347c3a..ca2f5ed197 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -329,3 +329,18 @@ TUPLE: empty-tuple ;
     [ { vector } declare length>> ]
     count-unboxed-allocations
 ] unit-test
+
+! Bug found while tweaking benchmark.raytracer-simd
+
+TUPLE: point-2d { x read-only } { y read-only } ;
+TUPLE: point-3d < point-2d { z read-only } ;
+
+[ 0 ] [
+    [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
+    count-unboxed-allocations
+] unit-test
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 5be206f2f8..9634bdf259 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -61,22 +61,28 @@ M: #push escape-analysis*
 
 : record-tuple-allocation ( #call -- )
     dup immutable-tuple-boa?
-    [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+    [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
     [ record-unknown-allocation ]
     if ;
 
 : slot-offset ( #call -- n/f )
-    dup in-d>>
-    [ second node-value-info literal>> ]
-    [ first node-value-info class>> ] 2bi
-    2dup [ fixnum? ] [ tuple class<= ] bi* and [
-        over 2 >= [ drop 2 - ] [ 2drop f ] if
+    dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
+
+: valid-slot-offset? ( slot# in -- ? )
+    over [
+        allocation dup [
+            dup array? [ bounds-check? ] [ 2drop f ] if
+        ] [ 2drop t ] if
     ] [ 2drop f ] if ;
 
+: unknown-slot-call ( out slot# in -- )
+    [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
+
 : record-slot-call ( #call -- )
-    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+    2dup valid-slot-offset?
     [ [ record-slot-access ] [ copy-slot-value ] 3bi ]
-    [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+    [ unknown-slot-call ]
     if ;
 
 M: #call escape-analysis*