From e01fc938123b0bdef2aef0211f6bb40b56cf46b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 1 Aug 2009 23:34:14 -0500
Subject: [PATCH] compiler.tree.propagation.call-effect: fix case where
 quotation inlining could enter an infinite loop: [ dup call( quot -- ) ] dup
 call( quot -- ) etc

---
 .../propagation/call-effect/call-effect-tests.factor   |  4 ++++
 .../tree/propagation/call-effect/call-effect.factor    | 10 ++++++----
 .../compiler/tree/propagation/inlining/inlining.factor |  8 ++++++--
 3 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
index 5964bcee35..0c4bf9040c 100644
--- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
@@ -49,3 +49,7 @@ IN: compiler.tree.propagation.call-effect.tests
 [ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
 [ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
 [ f ] [ [ dup drop ] final-info first infer-value ] unit-test
+
+! This should not hang
+[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index bc18aa6ec1..ec2a4b1ece 100644
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -3,7 +3,8 @@
 USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
 words math stack-checker stack-checker.transforms
-compiler.tree.propagation.info slots.private ;
+compiler.tree.propagation.info
+compiler.tree.propagation.inlining ;
 IN: compiler.tree.propagation.call-effect
 
 ! call( and execute( have complex expansions.
@@ -130,8 +131,9 @@ ERROR: uninferable ;
 : (infer-value) ( value-info -- effect )
     dup class>> {
         { \ quotation [
-            literal>> [ uninferable ] unless* cached-effect
-            dup +unknown+ = [ uninferable ] when
+            literal>> [ uninferable ] unless*
+            dup already-inlined? [ uninferable ] when
+            cached-effect dup +unknown+ = [ uninferable ] when
         ] }
         { \ curry [
             slots>> third (infer-value)
@@ -151,7 +153,7 @@ ERROR: uninferable ;
 
 : (value>quot) ( value-info -- quot )
     dup class>> {
-        { \ quotation [ literal>> '[ drop @ ] ] }
+        { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
         { \ curry [
             slots>> third (value>quot)
             '[ [ obj>> ] [ quot>> @ ] bi ]
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 6be3bed8d3..4d54dc5e39 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -163,13 +163,17 @@ DEFER: (flat-length)
 
 SYMBOL: history
 
+: already-inlined? ( obj -- ? ) history get memq? ;
+
+: add-to-history ( obj -- ) history [ swap suffix ] change ;
+
 : remember-inlining ( word -- )
     [ inlining-count get inc-at ]
-    [ history [ swap suffix ] change ]
+    [ add-to-history ]
     bi ;
 
 :: inline-word ( #call word -- ? )
-    word history get memq? [ f ] [
+    word already-inlined? [ f ] [
         #call word splicing-body [
             [
                 word remember-inlining