diff options
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcMType.lhs | 16 | ||||
| -rw-r--r-- | compiler/typecheck/TcPat.lhs | 9 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 40 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.lhs | 33 | ||||
| -rw-r--r-- | compiler/typecheck/TcRules.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 42 | ||||
| -rw-r--r-- | compiler/typecheck/TcSimplify.lhs | 29 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.lhs | 4 | ||||
| -rw-r--r-- | 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 ef25ad5644..6075cbaecc 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 c918c9dd89..a191b8225f 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 b31a4cc41e..950d7339f8 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 1e391de4dd..f8c98b5de3 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 1e8fc1758a..60f0fe93dd 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 456bd7e45b..ba694b6ed5 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 17f8d63012..8f02da6142 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 71c539993d..81c018a118 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 a71548c912..b105f8de72 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 5cbffdd872..acc5b3cd9a 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 aa5e9a175b..b96307d215 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 2b9838bcc7..e058a6fd1e 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 |