X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=0516308c5d91ba05a0c3e5134e1b810edac24f29;hb=6bb651084a0ebd572739ab9319c800c6ad83eb56;hp=30718c298e256b7715016a00b80aa919c58cf49f;hpb=54fa96ad5bd53058c0da9b9f3eb4b321f2ddbc16;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 30718c2..0516308 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -950,8 +950,10 @@ bindIrredsR loc qtvs co_vars reft givens irreds
   | null irreds
   = return emptyBag
   | otherwise
-  = do	{ let givens' = filter isDict givens
-		-- The givens can include methods
+  = do	{ let givens' = filter isAbstractableInst givens
+		-- The givens can (redundantly) include methods
+		-- We want to retain both EqInsts and Dicts
+		-- There should be no implicadtion constraints
 		-- See Note [Pruning the givens in an implication constraint]
 
 	   -- If there are no 'givens' *and* the refinement is empty
@@ -987,7 +989,8 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -> Refinement
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs reft
-		    givens 	-- Guaranteed all Dicts (TOMDO: true?)
+		    givens 	-- Guaranteed all Dicts
+				-- or EqInsts
 		    irreds
  | null irreds			-- If there are no irreds, we are done
  = return ([], emptyBag)
@@ -1786,7 +1789,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 +2369,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}
 
 
@@ -3118,10 +3113,6 @@ mkMonomorphismMsg tidy_env inst_tvs
 		nest 2 (vcat docs),
 		monomorphism_fix dflags]
 
-isRuntimeUnk :: TcTyVar -> Bool
-isRuntimeUnk x | SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
-               | otherwise = False
-
 monomorphism_fix :: DynFlags -> SDoc
 monomorphism_fix dflags
   = ptext SLIT("Probable fix:") <+> vcat