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
12 files changed:
recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
text "with", ppr expected])
(congruenceNewtypes actual expected >>=
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
-- TOMDO: what about the coercion?
-- we should consider family instances
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
(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
tvs1_contents <- zonkTcTyVars ty_tvs'
let subst = (uncurry zipTopTvSubst . unzip)
[(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
-- leave them to the tcSimplifyTop, and quite a bit faster too
| otherwise -- Nested case
-- 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) }
-}
; lie_binds <- bindLocalMethods lie ids
; return (binds, lie_binds, thing) }
-}
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
+ <- captureConstraints $
tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newMetaTyVar meta_info kind
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
; ref <- newMutVar Flexi
; let name = mkSysTvName uniq fs
fs = case meta_info of
-- Make a new meta tyvar whose Name and Kind
-- come from an existing TyVar
instMetaTyVar meta_info tyvar
-- 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
; ref <- newMutVar Flexi
; let name = setNameUnique (tyVarName tyvar) uniq
kind = tyVarKind tyvar
-- Create the new, frozen, skolem type variable
-- We zonk to a skolem, not to a regular TcVar
-- See Note [Zonking to Skolem]
-- 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)
; 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
-- Bind the meta tyvar to the new tyvar
; case details of
\begin{code}
zonkImplication :: Implication -> TcM Implication
\begin{code}
zonkImplication :: Implication -> TcM Implication
-zonkImplication implic@(Implic { ic_untch = env_tvs, ic_given = given
+zonkImplication implic@(Implic { ic_given = given
- = do { env_tvs' <- zonkTcTyVarsAndFV env_tvs
- ; given' <- mapM zonkEvVar given
+ = do { given' <- mapM zonkEvVar given
; wanted' <- mapBagM zonkWanted wanted
; 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)
zonkEvVar :: EvVar -> TcM EvVar
zonkEvVar var = do { ty' <- zonkTcType (varType var)
| not (isOverloadedTy (idType id))
= do { res <- thing_inside; return (res, emptyTcEvBinds) }
| otherwise
| 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) }
-}
; binds <- bindLocalMethods lie [id]
; return (res, binds) }
-}
tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
= do { (pat', (res, pat_ct))
<- tc_lpat pat pat_ty (makeLazy penv) $
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
-- 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') $
-- Check there are no unlifted types under the lazy pattern
; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
the pattern C!
So we have to make the constraints from thing_inside "hop around"
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
The same thing ensures that equality constraints in a lazy match
are not made available in the RHS of the match. For example
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls boot_iface decls
= do { -- Do all the declarations
-- 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 {
; traceTc "Tc8" empty ;
; setEnvs tc_envs $
do {
hs_ruleds = rule_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
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
-- Check for illegal declarations
-- OK, we're ready to typecheck the stmts
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
-- 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
mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
-- 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
(tyVarsOfType res_ty) lie) ;
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
initTc hsc_env hsc_src keep_rn_syntax mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
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 ;
tvs_var <- newIORef emptyVarSet ;
dfuns_var <- newIORef emptyNameSet ;
keep_var <- newIORef emptyNameSet ;
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
- tcl_untch = emptyVarSet
+ tcl_meta = meta_var,
+ tcl_untch = initTyVarUnique
%************************************************************************
\begin{code}
%************************************************************************
\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 ;
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv ;
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
tryTcLIE thing_inside
-- 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) }
; case mb_res of
Nothing -> return (msgs, Nothing)
Just val -> do { emitConstraints lie; return (msgs, Just val) }
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`extendWanteds` 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) }
= 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 :: 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) }
getLclTypeEnv :: TcM (NameEnv TcTyThing)
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Constraints
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Constraints
+ Untouchables(..), inTouchableRange,
WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc,
wantedEvVarToVar, wantedEvVarPred, splitWanteds,
WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc,
wantedEvVarToVar, wantedEvVarPred, splitWanteds,
import Var
import VarEnv
import Module
import Var
import VarEnv
import Module
import SrcLoc
import VarSet
import ErrUtils
import SrcLoc
import VarSet
import ErrUtils
import BasicTypes
import Bag
import Outputable
import BasicTypes
import Bag
import Outputable
-- Why mutable? see notes with tcGetGlobalTyVars
tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints
-- 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
}
type TcTypeEnv = NameEnv TcTyThing
v%************************************************************************
\begin{code}
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
type WantedConstraints = Bag WantedConstraint
; (lhs', lhs_lie, rhs', rhs_lie, rule_ty)
<- tcExtendTyVarEnv tv_bndrs $
tcExtendIdEnv id_bndrs $
; (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)
; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) }
; (lhs_dicts, lhs_ev_binds, rhs_ev_binds)
newTcEvBindsTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
newTcEvBindsTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
- getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
+ getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
-- Global type bindings
tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
-- Global type bindings
- tcs_context :: SimplContext
+ tcs_context :: SimplContext,
+
+ tcs_untch :: Untouchables
traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
runTcS :: SimplContext
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
-> TcS a -- What to run
-> TcM (a, Bag EvBind)
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
; 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 }
- ; res <- TcM.setUntouchables untouch (unTcS tcs env)
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
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 $ \ 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 }
- TcM.setUntouchables untouch (unTcS tcs nest_env)
ctxtUnderImplic :: SimplContext -> SimplContext
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
ctxtUnderImplic SimplRuleLhs = SimplCheck
ctxtUnderImplic ctxt = ctxt
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!
-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
= 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 }
= 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) })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
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)
getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
getGblEnv :: TcS TcGblEnv
getGblEnv = wrapTcS $ TcM.getGblEnv
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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
-- is touchable variable!
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
-- We use this function when inferring the type of a function
-- The wanted constraints are already zonked
simplifyAsMuchAsPossible ctxt wanteds
-- 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*
-- We allow ourselves to unify environment
-- variables; hence *no untouchables*
= do { wanteds <- mapBagM zonkWanted wanteds
; loc <- getCtLoc NoScSkol
; (unsolved, ev_binds)
= 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
do { can_self <- canGivens loc [self]
; let inert = foldlBag updInertSet emptyInert can_self
-- No need for solveInteract; we know it's inert
; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds
; loc <- getCtLoc (RuleSkol name)
; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $
; 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"
, ic_env = emptyNameEnv
, ic_skols = mkVarSet tv_bndrs
, ic_scoped = panic "emitImplication"
; traceTc "simplifyCheck {" (vcat
[ ptext (sLit "wanted =") <+> ppr 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 }" $
solveWanteds emptyInert wanteds
; traceTc "simplifyCheck }" $
| isEmptyBag wanteds
= return emptyBag
| otherwise
| 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
; 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])
; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts
, text "Type defaults =" <+> ppr deflt_cts])
; return (unionManyBags deflt_cts `andCCan` unionManyBags tv_cts) }
------------------
; 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
-- 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
defaultTyVar untch the_tv
| isMetaTyVar the_tv
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
, not (k `eqKind` default_k)
= do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
:: ( SimplContext
, [Type]
, (Bool,Bool) ) -- (Overloaded strings, extended default rules)
:: ( 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))
-> CanonicalCts -- Unsolved
-> [[(CanonicalCt,TcTyVar)]]
findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
is_defaultable_group ds@((_,tv):_)
= isTyConableTyVar tv -- Note [Avoiding spurious errors]
&& not (tv `elemVarSet` bad_tvs)
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"
&& defaultable_classes [cc_class cc | (cc,_) <- ds]
is_defaultable_group [] = panic "defaultable_group"
------------------------------
disambigGroup :: [Type] -- The default types
------------------------------
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
-> 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
-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,
= do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty)
; ev <- newGivOrDerCoVar (mkTyVarTy the_tv) default_ty default_ty -- Refl
-- We know this equality is canonical,
, cc_tyvar = the_tv
, cc_rhs = default_ty }
, cc_tyvar = the_tv
, cc_rhs = default_ty }
- ; success <- tryTcS (extendVarSet untch the_tv) $
do { given_inert <- solveOne inert given_eq
; final_inert <- solveInteract given_inert (listToBag wanteds)
; let (_, unsolved) = extractUnsolved final_inert
do { given_inert <- solveOne inert given_eq
; final_inert <- solveInteract given_inert (listToBag wanteds)
; let (_, unsolved) = extractUnsolved final_inert
; return (unitBag given_eq) }
False -> -- Failure: try with the next type
do { traceTcS "disambigGoup succeeded" (ppr default_ty)
; 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
where
((the_ct,the_tv):_) = group
wanteds = map fst group
; let brack_stage = Brack cur_stage pending_splices lie_var
; (meta_ty, lie) <- setStage brack_stage $
; let brack_stage = Brack cur_stage pending_splices lie_var
; (meta_ty, lie) <- setStage brack_stage $
tc_bracket cur_stage brack
; simplifyBracket lie
tc_bracket cur_stage brack
; simplifyBracket lie
-- if the type checker fails!
setStage Splice $
do { -- Typecheck the expression
-- 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
-- Solve the constraints
; const_binds <- simplifyTop lie
newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar]
-> [EvVar] -> TcM result
-> TcM (TcEvBinds, WantedConstraints, result)
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 )
= 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
; if isEmptyBag wanted && not (hasEqualities given)
-- Optimisation : if there are no wanteds, and the givens
go _ ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
go _ ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
-{-- | isSigmaTy ty1 || isSigmaTy ty2 --}
= unifySigmaTy origin ty1 ty2
-- Anything else fails
= unifySigmaTy origin ty1 ty2
-- Anything else fails
in_scope = mkInScopeSet (mkVarSet skol_tvs)
phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
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
-- 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