From a118f208dca35c09530364507a20b6c5e9d6185d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Feb 2010 02:50:59 +1300
Subject: [PATCH] compiler.tree.propagation, compiler.tree.escape-analysis:
 make these passes handle constants in a more robust way in compilation units
 involving tuple reshaping

---
 .../tree/escape-analysis/simple/simple.factor |  7 +++++--
 .../tree/propagation/slots/slots.factor       | 21 ++++++++++++++-----
 core/classes/tuple/tuple-tests.factor         | 18 ++++++++++++++++
 core/classes/tuple/tuple.factor               |  4 ++++
 4 files changed, 43 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 50fa7ef0a8..5be206f2f8 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
@@ -50,7 +50,10 @@ DEFER: record-literal-allocation
     if* ;
 
 M: #push escape-analysis*
-    [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
+    dup literal>> layout-up-to-date?
+    [ [ out-d>> first ] [ literal>> ] bi record-literal-allocation ]
+    [ out-d>> unknown-allocations ]
+    if ;
 
 : record-unknown-allocation ( #call -- )
     [ in-d>> add-escaping-values ]
diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 11a4cdc4c6..18d31985d6 100644
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
-words math math.private combinators sequences.private namespaces
-slots.private classes compiler.tree.propagation.info ;
+combinators.short-circuit words math math.private combinators
+sequences.private namespaces slots.private classes
+compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
@@ -52,8 +53,18 @@ UNION: fixed-length-sequence array byte-array string ;
     dup [ read-only>> ] when ;
 
 : literal-info-slot ( slot object -- info/f )
-    2dup class read-only-slot?
-    [ swap slot <literal-info> ] [ 2drop f ] if ;
+    #! literal-info-slot makes an unsafe call to 'slot'.
+    #! Check that the layout is up to date to avoid accessing the
+    #! wrong slot during a compilation unit where reshaping took
+    #! place. This could happen otherwise because the "slots" word
+    #! property would reflect the new layout, but instances in the
+    #! heap would use the old layout since instances are updated
+    #! immediately after compilation.
+    {
+        [ class read-only-slot? ]
+        [ nip layout-up-to-date? ]
+        [ swap slot <literal-info> ]
+    } 2&& ;
 
 : length-accessor? ( slot info -- ? )
     [ 1 = ] [ length>> ] bi* and ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index fe55365f46..f452d8fb28 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -746,3 +746,21 @@ TUPLE: g < a-g ;
 [ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
 
 [ t ] [ g new layout-of "g" get layout-of eq? ] unit-test
+
+! Joe Groff discovered this bug
+DEFER: factor-crashes-anymore
+
+[ ] [
+    "IN: classes.tuple.tests
+    TUPLE: unsafe-slot-access ;
+    CONSTANT: unsafe-slot-access' T{ unsafe-slot-access }" eval( -- )
+] unit-test
+
+[ ] [
+    "IN: classes.tuple.tests
+    USE: accessors
+    TUPLE: unsafe-slot-access { x read-only initial: 31337 } ;
+    : factor-crashes-anymore ( -- x ) unsafe-slot-access' x>> ;" eval( -- )
+] unit-test
+
+[ 31337 ] [ factor-crashes-anymore ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ee49980f4d..363c2879e9 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -32,6 +32,10 @@ M: tuple class layout-of 2 slot { word } declare ; inline
 : tuple-size ( tuple -- size )
     layout-of 3 slot { fixnum } declare ; inline
 
+: layout-up-to-date? ( object -- ? )
+    dup tuple?
+    [ [ layout-of ] [ class tuple-layout ] bi eq? ] [ drop t ] if ;
+
 : check-tuple ( object -- tuple )
     dup tuple? [ not-a-tuple ] unless ; inline