From d3e977c632ebb2e490f2bf46e59cb9b8c38d98dc Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 12 Oct 2007 16:23:25 +0000
Subject: [PATCH] Fix DoCon: Another try at getting extractResults right

For some reason TcSimplify.extractResults is quite difficult to get right.
This is another attempt; finally I think I have it.

Strangely enough, it's only Sergey's DoCon program that shows up the
bug, which manifested as a failure in the Simplifier

        lookupRecBndr $dGCDRing{v a1Lz} [lid]

But it was due to extractResults producing multiple bindings for
the same dictionary.

Please merge this to the stable branch (after previous patches to
TcSimplify though).
---
 compiler/typecheck/TcSimplify.lhs |   80 +++++++++++++++++--------------------
 1 file changed, 36 insertions(+), 44 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 30718c2..4670a15 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1786,7 +1786,7 @@ reduceContext env wanteds
 	  --    This may expose some further equational constraints...
 	; wanted_dicts' <- zonkInsts wanted_dicts
 	; avails <- reduceList env wanted_dicts' init_state
-	; (binds, irreds0, needed_givens) <- extractResults avails wanted_dicts'
+	; let (binds, irreds0, needed_givens) = extractResults avails wanted_dicts'
 	; traceTc $ text "reduceContext extractresults" <+> vcat
 		      [ppr avails,ppr wanted_dicts',ppr binds,ppr needed_givens]
 
@@ -2366,64 +2366,56 @@ We assume that they'll be wrapped in a big Rec, so that the
 dependency analyser can sort them out later
 
 \begin{code}
+type DoneEnv = FiniteMap Inst [Id]
+-- Tracks which things we have evidence for
+
 extractResults :: Avails
 	       -> [Inst]		-- Wanted
-	       -> TcM (	TcDictBinds, 	-- Bindings
-			[Inst],		-- Irreducible ones
-			[Inst])		-- Needed givens, i.e. ones used in the bindings
+	       -> (TcDictBinds, 	-- Bindings
+		   [Inst],		-- Irreducible ones
+		   [Inst])		-- Needed givens, i.e. ones used in the bindings
 			-- Postcondition: needed-givens = free vars( binds ) \ irreds
 			--		  needed-gives is subset of Givens in incoming Avails
 			-- Note [Reducing implication constraints]
 
 extractResults (Avails _ avails) wanteds
-  = go avails emptyBag [] [] wanteds
+  = go emptyBag [] [] emptyFM wanteds
   where
-    go :: AvailEnv -> TcDictBinds -> [Inst] -> [Inst] -> [Inst]
-	-> TcM (TcDictBinds, [Inst], [Inst])
-    go avails binds irreds givens [] 
-      = returnM (binds, irreds, givens)
-
-    go avails binds irreds givens (w:ws)
+    go	:: TcDictBinds 	-- Bindings for dicts
+	-> [Inst]	-- Irreds
+	-> [Inst]	-- Needed givens
+	-> DoneEnv	-- Has an entry for each inst in the above three sets
+	-> [Inst]	-- Wanted
+	-> (TcDictBinds, [Inst], [Inst])
+    go binds irreds givens done [] 
+      = (binds, irreds, givens)
+
+    go binds irreds givens done (w:ws)
+      | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w
+      = if w_id `elem` done_ids then
+	   go binds irreds givens done ws
+	else
+	   go (add_bind (nlHsVar done_id)) irreds givens 
+	      (addToFM done w (done_id : w_id : rest_done_ids)) ws
+
+      | otherwise	-- Not yet done
       = case findAvailEnv avails w of
 	  Nothing -> pprTrace "Urk: extractResults" (ppr w) $
-		     go avails binds irreds givens ws
-
-	  Just (Given g) -> go (avails_with g g_id)
-			       (add_triv_bind g_id)
-			       irreds (g:givens) ws 
-			-- avail_with g ensures that we don't emit the
-			-- same given twice into needed-givens
-		where
-		  g_id = instToId g
+		     go binds irreds givens done ws
 
-	  Just IsIrred -> go (avails_with w w_id) binds (w:irreds) givens ws
+	  Just IsIrred -> go binds (w:irreds) givens done' ws
 
-		-- The avails_with_w handles the case where we want (Ord a, Eq a), and we
-		-- don't want to emit *two* Irreds for Ord a, one via the superclass chain
-		-- This showed up in a dupliated Ord constraint in the error message for 
-		--	test tcfail043
-		-- More generally, we don't want to emit two irreds with 
-		-- the same type
+	  Just (Rhs rhs ws') -> go (add_bind rhs) irreds givens done' (ws' ++ ws)
 
-	  Just (Rhs rhs@(L _ (HsVar g_id)) ws') 
-		-> go avails (add_triv_bind g_id) irreds givens (ws' ++ ws)
-
-	  Just (Rhs rhs ws') 
-		-> go (avails_with w w_id) (add_bind rhs)
-		      irreds givens (ws' ++ ws)
-	  -- The avails-with w replaces a complex RHS with a simple one
-	  -- for the benefit of subsequent lookups
+	  Just (Given g) -> go binds' irreds (g:givens) (addToFM done w [g_id]) ws 
+		where
+		  g_id = instToId g
+		  binds' | w_id == g_id = binds
+			 | otherwise    = add_bind (nlHsVar g_id)
       where
-	w_id = instToId w	
-
-	add_triv_bind rhs_id | rhs_id == w_id = binds
-			     | otherwise = add_bind (nlHsVar rhs_id)
-		-- The sought Id can be one of the givens, via a
-		-- superclass chain and then we definitely don't 
-		-- want to generate an x=x binding!
-
+	w_id  = instToId w	
+	done' = addToFM done w [w_id]
 	add_bind rhs = addInstToDictBind binds w rhs
-        avails_with w w_id = extendAvailEnv avails w (Rhs (nlHsVar w_id) [])
 \end{code}
 
 
-- 
1.7.10.4