X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=97976a2c956b83f3823a882bda20d89be51f71a6;hb=61182b3262baaa532c9f1c4730e255c8e2250ad7;hp=9b192ece5383a90488f17bac3e73513381043c95;hpb=32a5c61dc1df5e12aaf1f21e5928fbb261d62043;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 9b192ec..97976a2 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -861,7 +861,7 @@ Note [NO TYVARS]
 
 The excitement comes when simplifying the bindings for h.  Initially
 try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
-From this we get t1:=:t2, but also various bindings.  We can't forget
+From this we get t1~t2, but also various bindings.  We can't forget
 the bindings (because of [LOOP]), but in fact t1 is what g is
 polymorphic in.  
 
@@ -977,7 +977,7 @@ makeImplicationBind :: InstLoc -> [TcTyVar]
 --	(ir1, .., irn) = f qtvs givens
 -- where f is (evidence for) the new implication constraint
 --	f :: forall qtvs. givens => (ir1, .., irn)
--- qtvs includes coercion variables.
+-- qtvs includes coercion variables
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs
@@ -997,7 +997,7 @@ makeImplicationBind loc all_tvs
 	      name = mkInternalName uniq (mkVarOcc "ic") span
 	      implic_inst = ImplicInst { tci_name = name,
 					 tci_tyvars = all_tvs, 
-					 tci_given = (eq_givens ++ dict_givens),
+					 tci_given = eq_givens ++ dict_givens,
                                                        -- same order as binders
 					 tci_wanted = irreds, 
                                          tci_loc = loc }
@@ -1412,7 +1412,7 @@ tcSimplifyRestricted 	-- Used for restricted binding groups
 tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- Zonk everything in sight
   = do	{ traceTc (text "tcSimplifyRestricted")
-	; wanteds' <- zonkInsts wanteds
+	; wanteds_z <- zonkInsts wanteds
 
    	-- 'ReduceMe': Reduce as far as we can.  Don't stop at
 	-- dicts; the idea is to get rid of as many type
@@ -1424,7 +1424,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- HOWEVER, some unification may take place, if we instantiate
 	-- 	    a method Inst with an equality constraint
 	; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe)
-	; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds'
+	; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds_z
 
 	-- Next, figure out the tyvars we will quantify over
 	; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
@@ -1452,6 +1452,13 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 		ppr _binds,
 		ppr constrained_tvs', ppr tau_tvs', ppr qtvs ])
 
+          -- Zonk wanteds again!  The first call to reduceContext may have
+          -- instantiated some variables. 
+          -- FIXME: If red_improve would work, we could propagate that into
+          --        the equality solver, too, to prevent instantating any
+          --        variables.
+	; wanteds_zz <- zonkInsts wanteds_z
+
 	-- The first step may have squashed more methods than
 	-- necessary, so try again, this time more gently, knowing the exact
 	-- set of type variables to quantify over.
@@ -1473,7 +1480,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 			   (is_nested_group || isDict inst) = Stop
 		          | otherwise  	                    = ReduceMe 
 	      env = mkNoImproveRedEnv doc try_me
-	; (_imp, binds, irreds) <- reduceContext env wanteds'
+	; (_imp, binds, irreds) <- reduceContext env wanteds_zz
 
 	-- See "Notes on implicit parameters, Question 4: top level"
 	; ASSERT( all (isFreeWrtTyVars qtvs) irreds )	-- None should be captured
@@ -1915,22 +1922,24 @@ reduceContext env wanteds0
           -- go round again.  We do so in either of two cases:
           -- (1) If dictionary reduction or equality solving led to
           --     improvement (i.e., instantiated type variables).
-          -- (2) If we uncovered extra equalities.  We will try to solve them
-          --     in the next iteration.
-          -- (3) If we reduced dictionaries (i.e., got dictionary bindings),
+          -- (2) If we reduced dictionaries (i.e., got dictionary bindings),
           --     they may have exposed further opportunities to normalise
           --     family applications.  See Note [Dictionary Improvement]
+          --
+          -- NB: We do *not* go around for new extra_eqs.  Morally, we should,
+          --     but we can't without risking non-termination (see #2688).  By
+          --     not going around, we miss some legal programs mixing FDs and
+          --     TFs, but we never claimed to support such programs in the
+          --     current implementation anyway.
 
 	; let all_irreds       = dict_irreds ++ implic_irreds ++ extra_eqs
       	      avails_improved  = availsImproved avails
               improvedFlexible = avails_improved || eq_improved
-              extraEqs         = (not . null) extra_eqs
               reduced_dicts    = not (isEmptyBag dict_binds)
-              improved         = improvedFlexible || extraEqs || reduced_dicts
+              improved         = improvedFlexible || reduced_dicts
               --
               improvedHint  = (if avails_improved then " [AVAILS]" else "") ++
-                              (if eq_improved then " [EQ]" else "") ++
-                              (if extraEqs then " [EXTRA EQS]" else "")
+                              (if eq_improved then " [EQ]" else "")
 
 	; traceTc (text "reduceContext end" <+> (vcat [
 	     text "----------------------",