X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=d0bdb69ea3ec5250ce034c12fe103595dc864863;hb=b5a8dd88e3939cf547be50ab62bae84f5bf0398d;hp=3212e53407c1692288cbd4ab5422372607d6662b;hpb=288213d7c2c65fa68ca466c1a1a3378e24fa1151;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 3212e53..d0bdb69 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1754,12 +1754,12 @@ reduceContext env wanteds
 	; let givens 		 	   = red_givens env
 	      (given_eqs0, given_dicts0)   = partition isEqInst givens
 	      (wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds
-	      (wanted_implics0, wanted_dicts0) = partition isImplicInst wanted_non_eqs
+	      (wanted_implics0, wanted_dicts) = partition isImplicInst wanted_non_eqs
 
           -- We want to add as wanted equalities those that (transitively) 
           -- occur in superclass contexts of wanted class constraints.
           -- See Note [Ancestor Equalities]
-	; ancestor_eqs <- ancestorEqualities wanted_dicts0
+	; ancestor_eqs <- ancestorEqualities wanted_dicts
         ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs
 	; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
 
@@ -1780,61 +1780,51 @@ reduceContext env wanteds
 	-- *** ToDo: what to do with the "extra_givens"?  For the
 	-- moment I'm simply discarding them, which is probably wrong
 
-	  -- 7. Normalise the *wanted* *dictionary* constraints
-	  --    wrt. the toplevel and given equations
-	  -- NB: normalisation includes zonking as part of what it does
-	  --     so it's important to do it after any unifications
-	  --     that happened as a result of the addGivens
-	; (wanted_dicts,normalise_binds1) <- normaliseWantedDicts given_eqs wanted_dicts0
-
           -- 6. Solve the *wanted* *dictionary* constraints (not implications)
 	  --    This may expose some further equational constraints...
 	; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
-	; (dict_binds, bound_dicts, dict_irreds) <- extractResults avails wanted_dicts
+	; (dict_binds, bound_dicts, dict_irreds) 
+            <- extractResults avails wanted_dicts
 	; traceTc $ text "reduceContext extractresults" <+> vcat
-		      [ppr avails,ppr wanted_dicts,ppr dict_binds]
-
-	-- *** ToDo: what to do with the "extra_eqs"?  For the
-	-- moment I'm simply discarding them, which is probably wrong
+		      [ppr avails, ppr wanted_dicts, ppr dict_binds]
 
 	  -- Solve the wanted *implications*.  In doing so, we can provide
 	  -- as "given"   all the dicts that were originally given, 
 	  --		  *or* for which we now have bindings, 
 	  --		  *or* which are now irreds
-	; let implic_env = env { red_givens = givens ++ bound_dicts ++ dict_irreds }
-	; (implic_binds_s, implic_irreds_s) <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
+	; let implic_env = env { red_givens = givens ++ bound_dicts 
+                                              ++ dict_irreds }
+	; (implic_binds_s, implic_irreds_s) 
+            <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
 	; let implic_binds  = unionManyBags implic_binds_s
 	      implic_irreds = concat implic_irreds_s
 
-	  -- 3. Solve the *wanted* *equation* constraints
-	; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
-
-	  -- 4. Normalise the *wanted* equality constraints with respect to
-	  --    each other 
-	; eq_irreds <- normaliseWantedEqs eq_irreds0
+	  -- Normalise the wanted equality constraints
+	; eq_irreds <- normaliseWantedEqs given_eqs (wanted_eqs ++ extra_eqs)
 
-	  -- 8. Substitute the wanted *equations* in the wanted *dictionaries*
+	  -- Normalise the wanted dictionaries
 	; let irreds = dict_irreds ++ implic_irreds
-	; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-}
-                                                                eq_irreds irreds
+              eqs    = eq_irreds ++ given_eqs
+	; (norm_irreds, normalise_binds) <- normaliseWantedDicts eqs irreds
 		
-	  -- 9. eliminate the artificial skolem constants introduced in 1.
---	; eliminate_skolems	
-
-	  -- Figure out whether we should go round again
-  	  -- My current plan is to see if any of the mutable tyvars in
-	  -- givens or irreds has been filled in by improvement.  
-	  -- If so, there is merit in going around again, because
-	  -- we may make further progress
+	  -- Figure out whether we should go round again.  We do so in either
+          -- two cases:
+          -- (1) If any of the mutable tyvars in givens or irreds has been
+          --     filled in by improvement, there is merit in going around 
+          --     again, because we may make further progress.
+          -- (2) If we managed to normalise any dicts, there is merit in going
+          --     around gain, because reduceList may be able to get further.
 	  -- 
-	  -- ToDo: is it only mutable stuff?  We may have exposed new
+	  -- ToDo: We may have exposed new
 	  --	   equality constraints and should probably go round again
 	  --	   then as well.  But currently we are dropping them on the
 	  --	   floor anyway.
 
 	; let all_irreds = norm_irreds ++ eq_irreds
-	; improved <- anyM isFilledMetaTyVar $ varSetElems $
-		      tyVarsOfInsts (givens ++ all_irreds)
+	; improvedMetaTy <- anyM isFilledMetaTyVar $ varSetElems $
+		            tyVarsOfInsts (givens ++ all_irreds)
+        ; let improvedDicts = not $ isEmptyBag normalise_binds
+              improved      = improvedMetaTy || improvedDicts
 
 	-- The old plan (fragile)
 	-- improveed   = availsImproved avails 
@@ -1859,8 +1849,7 @@ reduceContext env wanteds
 	     ]))
 
 	; return (improved, 
-                  given_binds `unionBags` normalise_binds1 
-                              `unionBags` normalise_binds2 
+                  given_binds `unionBags` normalise_binds
                               `unionBags` dict_binds 
                               `unionBags` implic_binds, 
                   all_irreds,