From f2ec59d6589d8bf94032ba26a9ad2c01fa8068b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 May 2009 09:36:53 -0500
Subject: [PATCH] Fix infinite loop when compiling a word containing a tuple
 literal with circular structure in it. This was triggered by call( inline
 caching in core-foundation.fsevents on Mac OS X

---
 basis/compiler/tree/propagation/info/info.factor  | 15 ++++++---------
 .../tree/propagation/propagation-tests.factor     |  7 ++++++-
 .../compiler/tree/propagation/slots/slots.factor  |  7 ++++++-
 3 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 2776ed914f..4d4b22218d 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
 
 : <value-info> ( -- info ) \ value-info new ;
 
-: read-only-slots ( values class -- slots )
-    all-slots
-    [ read-only>> [ drop f ] unless ] 2map
-    f prefix ;
-
 DEFER: <literal-info>
 
+: tuple-slot-infos ( tuple -- slots )
+    [ tuple-slots ] [ class all-slots ] bi
+    [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+    f prefix ;
+
 : init-literal-info ( info -- info )
     dup literal>> class >>class
     dup literal>> dup real? [ [a,a] >>interval ] [
         [ [-inf,inf] >>interval ] dip
-        dup tuple? [
-            [ tuple-slots [ <literal-info> ] map ] [ class ] bi
-            read-only-slots >>slots
-        ] [ drop ] if
+        dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
     ] if ; inline
 
 : init-value-info ( info -- info )
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index ed8d2983b5..eba41dbfdf 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
 
 [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 89c2bada8b..86114772f7 100644
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ;
     [ [ literal>> ] map ] dip prefix >tuple
     <literal-info> ;
 
+: read-only-slots ( values class -- slots )
+    all-slots
+    [ read-only>> [ value-info ] [ drop f ] if ] 2map
+    f prefix ;
+
 : (propagate-tuple-constructor) ( values class -- info )
-    [ [ value-info ] map ] dip [ read-only-slots ] keep
+    [ read-only-slots ] keep
     over rest-slice [ dup [ literal?>> ] when ] all? [
         [ rest-slice ] dip fold-<tuple-boa>
     ] [