From e6a15c0b336df2c522a92bc00531ea29cf6b4a82 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 26 Mar 2010 22:44:56 -0400
Subject: [PATCH] compiler.tree.propagation: don't constant-fold boa
 constructors of identity-tuple subclasses

---
 .../tree/propagation/propagation-tests.factor   |  6 ++++++
 .../tree/propagation/slots/slots.factor         | 17 +++++++++--------
 2 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 444a424766..ad8a75ecdd 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -467,6 +467,12 @@ TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
 [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
 unit-test
 
+TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
+
+[ V{ f } ]
+[ [ don't-fold-boa-test-tuple boa ] final-literals ]
+unit-test
+
 TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 
 [ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 2602d6d59a..14546f0237 100644
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -34,17 +34,18 @@ IN: compiler.tree.propagation.slots
     [ read-only>> [ value-info ] [ drop f ] if ] 2map
     f prefix ;
 
-: (propagate-tuple-constructor) ( values class -- info )
-    [ read-only-slots ] keep
-    over rest-slice [ dup [ literal?>> ] when ] all? [
-        [ rest-slice ] dip fold-<tuple-boa>
-    ] [
-        <tuple-info>
-    ] if ;
+: fold-<tuple-boa>? ( values class -- ? )
+    [ rest-slice [ dup [ literal?>> ] when ] all? ]
+    [ identity-tuple class<= not ]
+    bi* and ;
+
+: (propagate-<tuple-boa>) ( values class -- info )
+    [ read-only-slots ] keep 2dup fold-<tuple-boa>?
+    [ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
 
 : propagate-<tuple-boa> ( #call -- infos )
     in-d>> unclip-last
-    value-info literal>> first (propagate-tuple-constructor) 1array ;
+    value-info literal>> first (propagate-<tuple-boa>) 1array ;
 
 : read-only-slot? ( n class -- ? )
     all-slots [ offset>> = ] with find nip