From 5de363ca9ebdb7d85e3c353c1cffdf0a1c11128e Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 6 Oct 2010 10:28:30 +0000 Subject: [PATCH] Refactoring: mainly rename ic_env_tvs to ic_untch Plus remember to zonk the free_tvs in TcUnify.newImplication --- compiler/typecheck/TcMType.lhs | 12 ++++++------ compiler/typecheck/TcRnMonad.lhs | 4 ++-- compiler/typecheck/TcRnTypes.lhs | 10 +++++----- compiler/typecheck/TcRules.lhs | 2 +- compiler/typecheck/TcSimplify.lhs | 16 ++++++++-------- compiler/typecheck/TcUnify.lhs | 14 +++++++------- 6 files changed, 29 insertions(+), 29 deletions(-) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index dd91b06..84fb1b8 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -469,7 +469,7 @@ tcGetGlobalTyVars :: TcM TcTyVarSet tcGetGlobalTyVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs) + ; gbl_tvs' <- zonkTcTyVarsAndFV gbl_tvs ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } \end{code} @@ -480,8 +480,8 @@ tcGetGlobalTyVars zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars -zonkTcTyVarsAndFV :: [TcTyVar] -> TcM TcTyVarSet -zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar tyvars +zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet +zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars) ----------------- Types @@ -601,12 +601,12 @@ zonkQuantifiedTyVar tv \begin{code} zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_env_tvs = env_tvs, ic_given = given +zonkImplication implic@(Implic { ic_untch = env_tvs, ic_given = given , ic_wanted = wanted }) - = do { env_tvs' <- zonkTcTyVarsAndFV (varSetElems env_tvs) + = do { env_tvs' <- zonkTcTyVarsAndFV env_tvs ; given' <- mapM zonkEvVar given ; wanted' <- mapBagM zonkWanted wanted - ; return (implic { ic_env_tvs = env_tvs', ic_given = given' + ; return (implic { ic_untch = env_tvs', ic_given = given' , ic_wanted = wanted' }) } zonkEvVar :: EvVar -> TcM EvVar diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index b1d963e..f171336 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -964,8 +964,8 @@ setUntouchables untch_tvs thing_inside = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside getUntouchables :: TcM TcTyVarSet -getUntouchables - = do { env <- getLclEnv; return (tcl_untch env) } +getUntouchables = do { env <- getLclEnv; return (tcl_untch env) } + -- NB: no need to zonk this TcTyVarSet: they are, after all, untouchable! isUntouchable :: TcTyVar -> TcM Bool isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index fce06d1..253a5c0 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -703,11 +703,11 @@ type GivenLoc = CtLoc SkolemInfo data Implication = Implic { - ic_env_tvs :: Untouchables, -- Untouchables: unification variables + ic_untch :: Untouchables, -- Untouchables: unification variables -- free in the environment - ic_env :: TcTypeEnv, -- The type environment + ic_env :: TcTypeEnv, -- The type environment -- Used only when generating error messages - -- Generally, ic_env_tvs = tvsof(ic_env) + -- Generally, ic_untch is a superset of tvsof(ic_env) -- However, we don't zonk ic_env when zonking the Implication -- Instead we do that when generating a skolem-escape error message @@ -813,10 +813,10 @@ pprWantedEvVarWithLoc (WantedEvVar v loc) = hang (pprEvVarWithType v) pprWantedEvVar (WantedEvVar v _) = pprEvVarWithType v instance Outputable Implication where - ppr (Implic { ic_env_tvs = env_tvs, ic_skols = skols, ic_given = given + ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given , ic_wanted = wanted, ic_binds = binds, ic_loc = loc }) = ptext (sLit "Implic") <+> braces - (sep [ ptext (sLit "Untouchables = ") <+> ppr env_tvs + (sep [ ptext (sLit "Untouchables = ") <+> ppr untch , ptext (sLit "Skolems = ") <+> ppr skols , ptext (sLit "Given = ") <+> pprEvVars given , ptext (sLit "Wanted = ") <+> ppr wanted diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 83ec995..71c5399 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -89,7 +89,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Now figure out what to quantify over -- c.f. TcSimplify.simplifyInfer - ; zonked_forall_tvs <- zonkTcTyVarsAndFV (varSetElems forall_tvs) + ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs)) diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 0e7acdd..d8be2d1 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -185,7 +185,7 @@ simplifyInfer :: Bool -- Apply monomorphism restriction TcEvBinds) -- ... binding these evidence variables simplifyInfer apply_mr tau_tvs wanted | isEmptyBag wanted -- Trivial case is quite common - = do { zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs) + = do { zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_tau_tvs `minusVarSet` gbl_tvs)) ; return (qtvs, [], emptyTcEvBinds) } @@ -202,7 +202,7 @@ simplifyInfer apply_mr tau_tvs wanted <- simplifyAsMuchAsPossible SimplInfer zonked_wanted ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs) + ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs ; zonked_simples <- mapBagM zonkWantedEvVar simple_wanted ; let qtvs = findQuantifiedTyVars apply_mr zonked_simples zonked_tau_tvs gbl_tvs (bound, free) | apply_mr = (emptyBag, zonked_simples) @@ -512,7 +512,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds ; loc <- getCtLoc (RuleSkol name) ; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $ - Implic { ic_env_tvs = emptyVarSet -- No untouchables + Implic { ic_untch = emptyVarSet -- No untouchables , ic_env = emptyNameEnv , ic_skols = mkVarSet tv_bndrs , ic_scoped = panic "emitImplication" @@ -642,12 +642,12 @@ solveImplication :: InertSet -- Given -- -- Precondition: everything is zonked by now solveImplication inert - imp@(Implic { ic_env_tvs = untch - , ic_binds = ev_binds - , ic_skols = skols - , ic_given = givens + imp@(Implic { ic_untch = untch + , ic_binds = ev_binds + , ic_skols = skols + , ic_given = givens , ic_wanted = wanteds - , ic_loc = loc }) + , ic_loc = loc }) = nestImplicTcS ev_binds untch $ do { traceTcS "solveImplication {" (ppr imp) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 340be9a..348c70e 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -413,12 +413,12 @@ newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar] newImplication skol_info free_tvs skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { gbl_tvs <- tcGetGlobalTyVars - ; lcl_env <- getLclTypeEnv - ; let all_free_tvs = gbl_tvs `unionVarSet` free_tvs + do { gbl_tvs <- tcGetGlobalTyVars + ; free_tvs <- zonkTcTyVarsAndFV free_tvs + ; let untch = gbl_tvs `unionVarSet` free_tvs ; (result, wanted) <- getConstraints $ - setUntouchables all_free_tvs $ + setUntouchables untch $ thing_inside ; if isEmptyBag wanted && not (hasEqualities given) @@ -431,8 +431,9 @@ newImplication skol_info free_tvs skol_tvs given thing_inside return (emptyTcEvBinds, emptyWanteds, result) else do { ev_binds_var <- newTcEvBinds + ; lcl_env <- getLclTypeEnv ; loc <- getCtLoc skol_info - ; let implic = Implic { ic_env_tvs = all_free_tvs + ; let implic = Implic { ic_untch = untch , ic_env = lcl_env , ic_skols = mkVarSet skol_tvs , ic_scoped = panic "emitImplication" @@ -444,7 +445,6 @@ newImplication skol_info free_tvs skol_tvs given thing_inside ; return (TcEvBinds ev_binds_var, unitBag (WcImplic implic), result) } } \end{code} - %************************************************************************ %* * Boxy unification @@ -1194,7 +1194,7 @@ checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM () -- The extra_tvs can include boxy type variables; -- e.g. TcMatches.tcCheckExistentialPat checkSigTyVarsWrt extra_tvs sig_tvs - = do { extra_tvs' <- zonkTcTyVarsAndFV (varSetElems extra_tvs) + = do { extra_tvs' <- zonkTcTyVarsAndFV extra_tvs ; check_sig_tyvars extra_tvs' sig_tvs } check_sig_tyvars -- 1.7.10.4