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 <simo...@microsoft.com> 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 } } _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
