[commit: ghc] master: Remember to zonk when taking free variables in simpl_top (1d07cc0)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/1d07cc04ebcaa2df69824aeb1406557946e6dd19

>---------------------------------------------------------------

commit 1d07cc04ebcaa2df69824aeb1406557946e6dd19
Author: Simon Peyton Jones <[email protected]>
Date:   Mon Dec 24 09:46:55 2012 +0000

    Remember to zonk when taking free variables in simpl_top
    
    Forgetting this meant that we were upating the same
    meta-tyvar twice.  Fixes Trac #7525.

>---------------------------------------------------------------

 compiler/typecheck/TcSMonad.lhs   |    4 ++++
 compiler/typecheck/TcSimplify.lhs |   24 ++++++++++++------------
 2 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 7541cd7..b0e4ef2 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -84,6 +84,7 @@ module TcSMonad (
     compatKind, mkKindErrorCtxtTcS,
 
     Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe,
+    zonkTyVarsAndFV,
 
     getDefaultInfo, getDynFlags,
 
@@ -1303,6 +1304,9 @@ isFilledMetaTyVar_maybe tv
                   Indirect ty -> return (Just ty)
                   Flexi       -> return Nothing }
      _ -> return Nothing 
+
+zonkTyVarsAndFV :: TcTyVarSet -> TcS TcTyVarSet
+zonkTyVarsAndFV tvs = wrapTcS (TcM.zonkTyVarsAndFV tvs)
 \end{code}
 
 Note [Do not add duplicate derived insolubles]
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 406fd3a..18615f9 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -18,9 +18,9 @@ module TcSimplify(
 import TcRnTypes
 import TcRnMonad
 import TcErrors
-import TcMType
+import TcMType as TcM
 import TcType 
-import TcSMonad 
+import TcSMonad as TcS
 import TcInteract 
 import Inst
 import Type     ( classifyPredType, PredTree(..), getClassPredTys_maybe )
@@ -75,13 +75,13 @@ simplifyTop wanteds
     simpl_top :: WantedConstraints -> TcS WantedConstraints
     simpl_top wanteds
       = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds)
-           ; let meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfWC wc_first_go))
-                   -- tyVarsOfWC: post-simplification the WC should reflect
-                   --             all unifications that have happened
+           ; free_tvs <- TcS.zonkTyVarsAndFV (tyVarsOfWC wc_first_go) 
+           ; let meta_tvs = filterVarSet isMetaTyVar free_tvs
+                   -- zonkTyVarsAndFV: the wc_first_go is not yet zonked
                    -- filter isMetaTyVar: we might have runtime-skolems in GHCi, 
                    -- and we definitely don't want to try to assign to those!
 
-           ; mapM_ defaultTyVar meta_tvs   -- Has unification side effects
+           ; mapM_ defaultTyVar (varSetElems meta_tvs)   -- Has unification side effects
            ; simpl_top_loop wc_first_go }
     
     simpl_top_loop wc
@@ -406,7 +406,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
        -- NB: quant_pred_candidates is already the fixpoint of any 
        --     unifications that may have happened
        ; gbl_tvs        <- tcGetGlobalTyVars
-       ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
+       ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
        ; let init_tvs  = zonked_tau_tvs `minusVarSet` gbl_tvs
              poly_qtvs = growThetaTyVars quant_pred_candidates init_tvs 
                          `minusVarSet` gbl_tvs
@@ -450,7 +450,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
        ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs)
 
             -- Step 7) Emit an implication
-       ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds
+       ; minimal_bound_ev_vars <- mapM TcM.newEvVar minimal_flat_preds
        ; let implic = Implic { ic_untch    = pushUntouchables untch
                              , ic_skols    = qtvs_to_return
                              , ic_fsks     = []  -- wanted_tansformed arose only from solveWanteds
@@ -847,7 +847,7 @@ floatEqualities skols can_given wanteds@(WC { wc_flat = flats })
   = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
   | otherwise 
   = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats
-       ; untch <- TcSMonad.getUntouchables
+       ; untch <- TcS.getUntouchables
        ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs))
        ; ty_binds <- getTcSTyBindsMap
        ; traceTcS "floatEqualities" (vcat [ text "Floated eqs =" <+> ppr float_eqs
@@ -877,7 +877,7 @@ promoteTyVar :: Untouchables -> TcTyVar  -> TcS ()
 -- invariant (MetaTvInv) in Note [Untouchable type variables] in TcType
 promoteTyVar untch tv 
   | isFloatedTouchableMetaTyVar untch tv
-  = do { cloned_tv <- TcSMonad.cloneMetaTyVar tv
+  = do { cloned_tv <- TcS.cloneMetaTyVar tv
        ; let rhs_tv = setMetaTyVarUntouchables cloned_tv untch
        ; setWantedTyBind tv (mkTyVarTy rhs_tv) }
   | otherwise
@@ -896,7 +896,7 @@ defaultTyVar :: TcTyVar -> TcS TcTyVar
 -- See Note [DefaultTyVar]
 defaultTyVar the_tv
   | not (k `eqKind` default_k)
-  = do { tv' <- TcSMonad.cloneMetaTyVar the_tv
+  = do { tv' <- TcS.cloneMetaTyVar the_tv
        ; let new_tv = setTyVarKind tv' default_k
        ; traceTcS "defaultTyVar" (ppr the_tv <+> ppr new_tv)
        ; setWantedTyBind the_tv (mkTyVarTy new_tv)
@@ -1269,7 +1269,7 @@ newFlatWanteds orig theta
        ; mapM (inst_to_wanted loc) theta }
   where 
     inst_to_wanted loc pty 
-          = do { v <- TcMType.newWantedEvVar pty 
+          = do { v <- TcM.newWantedEvVar pty 
                ; return $ mkNonCanonical loc $
                  CtWanted { ctev_evar = v
                           , ctev_pred = pty } }