From debb7b80e707c343a3a7d8993ffab19b83e5c52b Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 8 Oct 2010 13:37:51 +0000 Subject: [PATCH] Beautiful new approach to the skolem-escape check and untouchable Instead of keeping a *set* of untouchable variables in each implication contraints, we keep a *range* of uniques for the *touchable* variables of an implication. This are precisely the ones we would call the "existentials" if we were French. It turns out that the code is more efficient, and vastly easier to get right, than the set-based approach. Fixes Trac #4355 among others --- compiler/ghci/RtClosureInspect.hs | 4 ++-- compiler/typecheck/TcBinds.lhs | 4 ++-- compiler/typecheck/TcMType.lhs | 16 +++++++------- compiler/typecheck/TcPat.lhs | 9 ++++---- compiler/typecheck/TcRnDriver.lhs | 10 ++++----- compiler/typecheck/TcRnMonad.lhs | 40 +++++++++++++++++++++++------------ compiler/typecheck/TcRnTypes.lhs | 33 +++++++++++++++++++++++++---- compiler/typecheck/TcRules.lhs | 4 ++-- compiler/typecheck/TcSMonad.lhs | 42 ++++++++++++++++++++----------------- compiler/typecheck/TcSimplify.lhs | 29 +++++++++++++------------ compiler/typecheck/TcSplice.lhs | 4 ++-- compiler/typecheck/TcUnify.lhs | 24 ++++++++++----------- 12 files changed, 130 insertions(+), 89 deletions(-) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index ef25ad5..6075cba 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -591,7 +591,7 @@ addConstraint actual expected = do recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, text "with", ppr expected]) (congruenceNewtypes actual expected >>= - (getConstraints . uncurry unifyType) >> return ()) + (captureConstraints . uncurry unifyType) >> return ()) -- TOMDO: what about the coercion? -- we should consider family instances @@ -862,7 +862,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do (ty_tvs, _, _) <- tcInstType return ty (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty) - _ <- getConstraints(unifyType rtti_ty' ty') + _ <- captureConstraints (unifyType rtti_ty' ty') tvs1_contents <- zonkTcTyVars ty_tvs' let subst = (uncurry zipTopTvSubst . unzip) [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index c918c9d..a191b82 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -271,7 +271,7 @@ bindLocalInsts top_lvl thing_inside -- leave them to the tcSimplifyTop, and quite a bit faster too | otherwise -- Nested case - = do { ((binds, ids, thing), lie) <- getConstraints thing_inside + = do { ((binds, ids, thing), lie) <- captureConstraints thing_inside ; lie_binds <- bindLocalMethods lie ids ; return (binds, lie_binds, thing) } -} @@ -417,7 +417,7 @@ tcPolyInfer -> TcM (LHsBinds TcId, [TcId]) tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list = do { ((binds', mono_infos), wanted) - <- getConstraints $ + <- captureConstraints $ tcMonoBinds sig_fn LetLclBndr rec_tc bind_list ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index b31a4cc..950d733 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -300,7 +300,7 @@ tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv) newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air newMetaTyVar meta_info kind - = do { uniq <- newUnique + = do { uniq <- newMetaUnique ; ref <- newMutVar Flexi ; let name = mkSysTvName uniq fs fs = case meta_info of @@ -312,7 +312,7 @@ instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar -- Make a new meta tyvar whose Name and Kind -- come from an existing TyVar instMetaTyVar meta_info tyvar - = do { uniq <- newUnique + = do { uniq <- newMetaUnique ; ref <- newMutVar Flexi ; let name = setNameUnique (tyVarName tyvar) uniq kind = tyVarKind tyvar @@ -583,8 +583,10 @@ zonkQuantifiedTyVar tv -- Create the new, frozen, skolem type variable -- We zonk to a skolem, not to a regular TcVar -- See Note [Zonking to Skolem] + ; uniq <- newUnique -- Remove it from TcMetaTyVar unique land ; let final_kind = defaultKind (tyVarKind tv) - final_tv = mkSkolTyVar (tyVarName tv) final_kind UnkSkol + final_name = setNameUnique (tyVarName tv) uniq + final_tv = mkSkolTyVar final_name final_kind UnkSkol -- Bind the meta tyvar to the new tyvar ; case details of @@ -601,13 +603,11 @@ zonkQuantifiedTyVar tv \begin{code} zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_untch = env_tvs, ic_given = given +zonkImplication implic@(Implic { ic_given = given , ic_wanted = wanted }) - = do { env_tvs' <- zonkTcTyVarsAndFV env_tvs - ; given' <- mapM zonkEvVar given + = do { given' <- mapM zonkEvVar given ; wanted' <- mapBagM zonkWanted wanted - ; return (implic { ic_untch = env_tvs', ic_given = given' - , ic_wanted = wanted' }) } + ; return (implic { ic_given = given', ic_wanted = wanted' }) } zonkEvVar :: EvVar -> TcM EvVar zonkEvVar var = do { ty' <- zonkTcType (varType var) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 1e391de..f8c98b5 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -294,7 +294,7 @@ bindInstsOfPatId id thing_inside | not (isOverloadedTy (idType id)) = do { res <- thing_inside; return (res, emptyTcEvBinds) } | otherwise - = do { (res, lie) <- getConstraints thing_inside + = do { (res, lie) <- captureConstraints thing_inside ; binds <- bindLocalMethods lie [id] ; return (res, binds) } -} @@ -410,11 +410,12 @@ tc_pat penv (BangPat pat) pat_ty thing_inside tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside = do { (pat', (res, pat_ct)) <- tc_lpat pat pat_ty (makeLazy penv) $ - getConstraints thing_inside + captureConstraints thing_inside -- Ignore refined penv', revert to penv ; emitConstraints pat_ct - -- getConstraints/extendConstraintss: see Note [Hopping the LIE in lazy patterns] + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] -- Check there are no unlifted types under the lazy pattern ; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $ @@ -593,7 +594,7 @@ We can't discharge the Num constraint from dictionaries bound by the pattern C! So we have to make the constraints from thing_inside "hop around" -the pattern. Hence the getConstraints and emitConstraints. +the pattern. Hence the captureConstraints and emitConstraints. The same thing ensures that equality constraints in a lazy match are not made available in the RHS of the match. For example diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 1e8fc17..60f0fe9 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -364,7 +364,7 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations - (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ; + (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; ; setEnvs tc_envs $ do { @@ -482,7 +482,7 @@ tcRnHsBootDecls decls hs_ruleds = rule_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group - ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do { + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { -- Check for illegal declarations @@ -1274,7 +1274,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ -> + ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1307,8 +1307,8 @@ tcRnExpr hsc_env ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - ((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -} + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints (simplifyInfer False {- No MR for now -} (tyVarsOfType res_ty) lie) ; _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 456bd7e..ba694b6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -69,6 +69,7 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; + meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; dfuns_var <- newIORef emptyNameSet ; keep_var <- newIORef emptyNameSet ; @@ -133,7 +134,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, - tcl_untch = emptyVarSet + tcl_meta = meta_var, + tcl_untch = initTyVarUnique } ; } ; @@ -315,6 +317,16 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) %************************************************************************ \begin{code} +newMetaUnique :: TcM Unique +-- The uniques for TcMetaTyVars are allocated specially +-- in guaranteed linear order, starting at zero for each module +newMetaUnique + = do { env <- getLclEnv + ; let meta_var = tcl_meta env + ; uniq <- readMutVar meta_var + ; writeMutVar meta_var (incrUnique uniq) + ; return uniq } + newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; @@ -678,7 +690,7 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a) -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ; + = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ; ; case mb_res of Nothing -> return (msgs, Nothing) Just val -> do { emitConstraints lie; return (msgs, Just val) } @@ -951,25 +963,27 @@ emitConstraint ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`extendWanteds` ct) } -getConstraints :: TcM a -> TcM (a, WantedConstraints) --- (getConstraints m) runs m, and returns the type constraints it generates -getConstraints thing_inside +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +captureConstraints thing_inside = do { lie_var <- newTcRef emptyWanteds ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -setUntouchables :: TcTyVarSet -> TcM a -> TcM a -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) } - -- NB: no need to zonk this TcTyVarSet: they are, after all, untouchable! +captureUntouchables :: TcM a -> TcM (a, Untouchables) +captureUntouchables thing_inside + = do { env <- getLclEnv + ; low_meta <- readTcRef (tcl_meta env) + ; res <- setLclEnv (env { tcl_untch = low_meta }) + thing_inside + ; high_meta <- readTcRef (tcl_meta env) + ; return (res, TouchableRange low_meta high_meta) } isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) } +isUntouchable tv = do { env <- getLclEnv + ; return (varUnique tv < tcl_untch env) } getLclTypeEnv :: TcM (NameEnv TcTyThing) getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 17f8d63..8f02da6 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -28,7 +28,7 @@ module TcRnTypes( ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Constraints - Untouchables, + Untouchables(..), inTouchableRange, WantedConstraints, emptyWanteds, andWanteds, extendWanteds, WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc, wantedEvVarToVar, wantedEvVarPred, splitWanteds, @@ -68,11 +68,12 @@ import NameSet import Var import VarEnv import Module -import UniqFM import SrcLoc import VarSet import ErrUtils +import UniqFM import UniqSupply +import Unique import BasicTypes import Bag import Outputable @@ -383,7 +384,13 @@ data TcLclEnv -- Changes as we move inside an expression -- Why mutable? see notes with tcGetGlobalTyVars tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_untch :: Untouchables -- Untouchables + + -- TcMetaTyVars have + tcl_meta :: TcRef Unique, -- The next free unique for TcMetaTyVars + -- Guaranteed to be allocated linearly + tcl_untch :: Unique -- Any TcMetaTyVar with + -- unique >= tcl_untch is touchable + -- unique < tcl_untch is untouchable } type TcTypeEnv = NameEnv TcTyThing @@ -678,7 +685,25 @@ instance Outputable WhereFrom where v%************************************************************************ \begin{code} -type Untouchables = TcTyVarSet -- All MetaTyVars +data Untouchables = NoUntouchables + | TouchableRange + Unique -- Low end + Unique -- High end + -- A TcMetaTyvar is *touchable* iff its unique u satisfies + -- u >= low + -- u < high + +instance Outputable Untouchables where + ppr NoUntouchables = ptext (sLit "No untouchables") + ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> + ppr low <+> char '-' <+> ppr high + +inTouchableRange :: Untouchables -> TcTyVar -> Bool +inTouchableRange NoUntouchables _ = True +inTouchableRange (TouchableRange low high) tv + = uniq >= low && uniq < high + where + uniq = varUnique tv type WantedConstraints = Bag WantedConstraint diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 71c5399..81c018a 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -57,8 +57,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; (lhs', lhs_lie, rhs', rhs_lie, rule_ty) <- tcExtendTyVarEnv tv_bndrs $ tcExtendIdEnv id_bndrs $ - do { ((lhs', rule_ty), lhs_lie) <- getConstraints (tcInferRho lhs) - ; (rhs', rhs_lie) <- getConstraints (tcMonoExpr rhs rule_ty) + do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_lie) <- captureConstraints (tcMonoExpr rhs rule_ty) ; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) } ; (lhs_dicts, lhs_ev_binds, rhs_ev_binds) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index a71548c..b105f8d 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -30,7 +30,7 @@ module TcSMonad ( newTcEvBindsTcS, getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS, + getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, @@ -340,7 +340,9 @@ data TcSEnv tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings - tcs_context :: SimplContext + tcs_context :: SimplContext, + + tcs_untch :: Untouchables } data SimplContext @@ -412,7 +414,7 @@ traceTcS0 :: String -> SDoc -> TcS () traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc runTcS :: SimplContext - -> TcTyVarSet -- Untouchables + -> Untouchables -- Untouchables -> TcS a -- What to run -> TcM (a, Bag EvBind) runTcS context untouch tcs @@ -420,10 +422,11 @@ runTcS context untouch tcs ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var - , tcs_context = context } + , tcs_context = context + , tcs_untch = untouch } -- Run the computation - ; res <- TcM.setUntouchables untouch (unTcS tcs env) + ; res <- unTcS tcs env -- Perform the type unifications required ; ty_binds <- TcM.readTcRef ty_binds_var @@ -436,30 +439,31 @@ runTcS context untouch tcs do_unification (tv,ty) = TcM.writeMetaTyVar tv ty -nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a -nestImplicTcS ref untouch tcs +nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a +nestImplicTcS ref untch (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } -> let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds - , tcs_context = ctxtUnderImplic ctxt } + , tcs_untch = untch + , tcs_context = ctxtUnderImplic ctxt } in - TcM.setUntouchables untouch (unTcS tcs nest_env) + thing_inside nest_env ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify ctxtUnderImplic SimplRuleLhs = SimplCheck ctxtUnderImplic ctxt = ctxt -tryTcS :: TcTyVarSet -> TcS a -> TcS a +tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Ignore all the evidence generated, and do not affect caller's evidence! -tryTcS untch tcs +tryTcS tcs = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds ; let env1 = env { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var } - ; TcM.setUntouchables untch (unTcS tcs env1) }) + ; unTcS tcs env1 }) -- Update TcEvBinds -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -473,6 +477,9 @@ getTcSContext = TcS (return . tcs_context) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) +getUntouchables :: TcS Untouchables +getUntouchables = TcS (return . tcs_untch) + getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) @@ -543,9 +550,6 @@ getTopEnv = wrapTcS $ TcM.getTopEnv getGblEnv :: TcS TcGblEnv getGblEnv = wrapTcS $ TcM.getGblEnv -getUntouchablesTcS :: TcS TcTyVarSet -getUntouchablesTcS = wrapTcS $ TcM.getUntouchables - -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -563,10 +567,10 @@ pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool -- is touchable variable! -isTouchableMetaTyVar v - | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v; - ; return (not untch) } - | otherwise = return False +isTouchableMetaTyVar tv + | isMetaTyVar tv = do { untch <- getUntouchables + ; return (inTouchableRange untch tv) } + | otherwise = return False -- Flatten skolems diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 5cbffdd..acc5b3c 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -247,7 +247,7 @@ simplifyAsMuchAsPossible :: SimplContext -> WantedConstraints -- We use this function when inferring the type of a function -- The wanted constraints are already zonked simplifyAsMuchAsPossible ctxt wanteds - = do { let untch = emptyVarSet + = do { let untch = NoUntouchables -- We allow ourselves to unify environment -- variables; hence *no untouchables* @@ -451,7 +451,7 @@ simplifySuperClass self wanteds = do { wanteds <- mapBagM zonkWanted wanteds ; loc <- getCtLoc NoScSkol ; (unsolved, ev_binds) - <- runTcS SimplCheck emptyVarSet $ + <- runTcS SimplCheck NoUntouchables $ do { can_self <- canGivens loc [self] ; let inert = foldlBag updInertSet emptyInert can_self -- No need for solveInteract; we know it's inert @@ -560,7 +560,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_untch = emptyVarSet -- No untouchables + Implic { ic_untch = NoUntouchables , ic_env = emptyNameEnv , ic_skols = mkVarSet tv_bndrs , ic_scoped = panic "emitImplication" @@ -604,7 +604,7 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, ev_binds) <- runTcS ctxt emptyVarSet $ + ; (unsolved, ev_binds) <- runTcS ctxt NoUntouchables $ solveWanteds emptyInert wanteds ; traceTc "simplifyCheck }" $ @@ -801,13 +801,13 @@ applyDefaultingRules inert wanteds | isEmptyBag wanteds = return emptyBag | otherwise - = do { untch <- getUntouchablesTcS + = do { untch <- getUntouchables ; tv_cts <- mapM (defaultTyVar untch) $ varSetElems (tyVarsOfCanonicals wanteds) ; info@(_, default_tys, _) <- getDefaultInfo ; let groups = findDefaultableGroups info untch wanteds - ; deflt_cts <- mapM (disambigGroup default_tys untch inert) groups + ; deflt_cts <- mapM (disambigGroup default_tys inert) groups ; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts , text "Type defaults =" <+> ppr deflt_cts]) @@ -815,7 +815,7 @@ applyDefaultingRules inert wanteds ; return (unionManyBags deflt_cts `andCCan` unionManyBags tv_cts) } ------------------ -defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts +defaultTyVar :: Untouchables -> TcTyVar -> TcS CanonicalCts -- defaultTyVar is used on any un-instantiated meta type variables to -- default the kind of ? and ?? etc to *. This is important to ensure -- that instance declarations match. For example consider @@ -832,7 +832,7 @@ defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts defaultTyVar untch the_tv | isMetaTyVar the_tv - , not (the_tv `elemVarSet` untch) + , inTouchableRange untch the_tv , not (k `eqKind` default_k) = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk @@ -855,7 +855,7 @@ findDefaultableGroups :: ( SimplContext , [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> TcTyVarSet -- Untouchable + -> Untouchables -- Untouchable -> CanonicalCts -- Unsolved -> [[(CanonicalCt,TcTyVar)]] findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) @@ -882,7 +882,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) is_defaultable_group ds@((_,tv):_) = isTyConableTyVar tv -- Note [Avoiding spurious errors] && not (tv `elemVarSet` bad_tvs) - && not (tv `elemVarSet` untch) -- Non untouchable + && inTouchableRange untch tv && defaultable_classes [cc_class cc | (cc,_) <- ds] is_defaultable_group [] = panic "defaultable_group" @@ -904,15 +904,14 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) ------------------------------ disambigGroup :: [Type] -- The default types - -> TcTyVarSet -- Untouchables -> InertSet -- Given inert -> [(CanonicalCt, TcTyVar)] -- All classes of the form (C a) -- sharing same type variable -> TcS CanonicalCts -disambigGroup [] _inert _untch _grp +disambigGroup [] _inert _grp = return emptyBag -disambigGroup (default_ty:default_tys) untch inert group +disambigGroup (default_ty:default_tys) inert group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; ev <- newGivOrDerCoVar (mkTyVarTy the_tv) default_ty default_ty -- Refl -- We know this equality is canonical, @@ -922,7 +921,7 @@ disambigGroup (default_ty:default_tys) untch inert group , cc_tyvar = the_tv , cc_rhs = default_ty } - ; success <- tryTcS (extendVarSet untch the_tv) $ + ; success <- tryTcS $ do { given_inert <- solveOne inert given_eq ; final_inert <- solveInteract given_inert (listToBag wanteds) ; let (_, unsolved) = extractUnsolved final_inert @@ -936,7 +935,7 @@ disambigGroup (default_ty:default_tys) untch inert group ; return (unitBag given_eq) } False -> -- Failure: try with the next type do { traceTcS "disambigGoup succeeded" (ppr default_ty) - ; disambigGroup default_tys untch inert group } } + ; disambigGroup default_tys inert group } } where ((the_ct,the_tv):_) = group wanteds = map fst group diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index aa5e9a1..b96307d 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -344,7 +344,7 @@ tcBracket brack res_ty ; let brack_stage = Brack cur_stage pending_splices lie_var ; (meta_ty, lie) <- setStage brack_stage $ - getConstraints $ + captureConstraints $ tc_bracket cur_stage brack ; simplifyBracket lie @@ -487,7 +487,7 @@ tcTopSpliceExpr tc_action -- if the type checker fails! setStage Splice $ do { -- Typecheck the expression - (expr', lie) <- getConstraints tc_action + (expr', lie) <- captureConstraints tc_action -- Solve the constraints ; const_binds <- simplifyTop lie diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 2b9838b..e058a6f 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -412,16 +412,16 @@ checkConstraints skol_info free_tvs skol_tvs given thing_inside newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar] -> [EvVar] -> TcM result -> TcM (TcEvBinds, WantedConstraints, result) -newImplication skol_info free_tvs skol_tvs given thing_inside +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 - ; free_tvs <- zonkTcTyVarsAndFV free_tvs - ; let untch = 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 untch $ - thing_inside + ; ((result, untch), wanted) <- captureConstraints $ + captureUntouchables $ + thing_inside ; if isEmptyBag wanted && not (hasEqualities given) -- Optimisation : if there are no wanteds, and the givens @@ -619,7 +619,6 @@ uType_np origin orig_ty1 orig_ty2 go _ ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 -{-- | isSigmaTy ty1 || isSigmaTy ty2 --} = unifySigmaTy origin ty1 ty2 -- Anything else fails @@ -636,12 +635,11 @@ unifySigmaTy origin ty1 ty2 in_scope = mkInScopeSet (mkVarSet skol_tvs) phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 - untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - - ; (coi, lie) <- getConstraints $ - setUntouchables untch $ - uType origin phi1 phi2 +-- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 + ; ((coi, _untch), lie) <- captureConstraints $ + captureUntouchables $ + uType origin phi1 phi2 -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a) ; let bad_lie = filterBag is_bad lie is_bad w = any (`elemVarSet` tyVarsOfWanted w) skol_tvs -- 1.7.10.4