From f6f3819f37d73eeaaffa7bf45126ce73fb53e72b Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 6 Dec 2004 10:51:36 +0000
Subject: [PATCH] [project @ 2004-12-06 10:51:36 by simonpj]
 ------------------------------------ 	Bug in loop
 detection in TcSimplify 
 ------------------------------------

The type-class context simplifier has been able to
build recursive dictionaries for some time: co-induction.
That is, you can build a proof for constraint C by assuming
that C holds when proving the preconditions of C.

You need to be in -fallow-undecidable-instances land to
make use of this: see comments with [RECURSIVE DICTIONARIES]
in TcSimplify.lhs.

Anyway, this is all fine, but I'd implemented it wrong!  You need
to be very careful with superclasses, or you can make a bogus
loop by mistake.  This commit fixes it; tests LoopOfTheDay{1,2,3}
will test it (thanks Ralf Laemmel).
---
 ghc/compiler/typecheck/TcSimplify.lhs |   19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f24b5de..beecfb4 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -1754,7 +1754,7 @@ addAvailAndSCs avails inst avail
     avails1 	 = addToFM avails inst avail
     is_loop inst = any (`tcEqType` idType (instToId inst)) dep_tys
 			-- Note: this compares by *type*, not by Unique
-    deps         = findAllDeps emptyVarSet avail
+    deps         = findAllDeps (unitVarSet (instToId inst)) avail
     dep_tys	 = map idType (varSetElems deps)
 
     findAllDeps :: IdSet -> Avail -> IdSet
@@ -1762,12 +1762,17 @@ addAvailAndSCs avails inst avail
     -- See Note [SUPERCLASS-LOOP]
     -- Watch out, though.  Since the avails may contain loops 
     -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
-    findAllDeps so_far (Rhs _ kids) 
-      = foldl findAllDeps
-    	      (extendVarSetList so_far (map instToId kids))	-- Add the kids to so_far
-              [a | Just a <- map (lookupFM avails) kids]	-- Find the kids' Avail
-    findAllDeps so_far other = so_far
-
+    findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
+    findAllDeps so_far other	    = so_far
+
+    find_all :: IdSet -> Inst -> IdSet
+    find_all so_far kid
+      | kid_id `elemVarSet` so_far	  = so_far
+      | Just avail <- lookupFM avails kid = findAllDeps so_far' avail
+      | otherwise			  = so_far'
+      where
+	so_far' = extendVarSet so_far kid_id	-- Add the new kid to so_far
+	kid_id = instToId kid
 
 addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
 	-- Add all the superclasses of the Inst to Avails
-- 
1.7.10.4