Commit 7babb1b0 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Big changes on tc-untouchables branch

(Before merging to HEAD we need to tidy up and write a proper commit message.)
parent 1bbdbe55
......@@ -27,7 +27,8 @@ module VarEnv (
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv_Directly, restrictVarEnv,
filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv,
-- * The InScopeSet type
InScopeSet,
......@@ -384,6 +385,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
......@@ -430,6 +432,7 @@ isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
partitionVarEnv = partitionUFM
restrictVarEnv env vs = filterVarEnv_Directly keep env
where
......
......@@ -25,11 +25,10 @@ module Inst (
tcSyntaxName,
-- Simple functions over evidence variables
hasEqualities, unitImplication,
hasEqualities,
tyVarsOfWC, tyVarsOfBag,
tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts,
tyVarsOfZonkedWC, tyVarsOfBag,
tyVarsOfCt, tyVarsOfCts,
tidyEvVar, tidyCt, tidyGivenLoc,
......@@ -506,11 +505,6 @@ addClsInstsErr herald ispecs
%************************************************************************
\begin{code}
unitImplication :: Implication -> Bag Implication
unitImplication implic
| isEmptyWC (ic_wanted implic) = emptyBag
| otherwise = unitBag implic
hasEqualities :: [EvVar] -> Bool
-- Has a bunch of canonical constraints (all givens) got any equalities in it?
hasEqualities givens = any (has_eq . evVarPred) givens
......@@ -529,33 +523,23 @@ tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOf
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl)
tyVarsOfCDict :: Ct -> TcTyVarSet
tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCDict _ct = emptyVarSet
tyVarsOfCDicts :: Cts -> TcTyVarSet
tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl)
tyVarsOfCts :: Cts -> TcTyVarSet
tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
tyVarsOfZonkedWC :: WantedConstraints -> TyVarSet
-- Only called on *zonked* things, hence no need to worry about flatten-skolems
tyVarsOfZonkedWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfCts flat `unionVarSet`
tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
tyVarsOfBag tyVarsOfZonkedImplic implic `unionVarSet`
tyVarsOfCts insol
tyVarsOfImplication :: Implication -> TyVarSet
tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
= tyVarsOfWC wanted `delVarSetList` skols
tyVarsOfEvVar :: EvVar -> TyVarSet
tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev
tyVarsOfEvVars :: [EvVar] -> TyVarSet
tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
tyVarsOfZonkedImplic :: Implication -> TyVarSet
-- Only called on *zonked* things, hence no need to worry about flatten-skolems
tyVarsOfZonkedImplic (Implic { ic_skols = skols, ic_given = givens, ic_wanted = wanted })
= (tyVarsOfZonkedWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
`delVarSetList` skols
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
......
......@@ -29,7 +29,6 @@ import Control.Monad ( when )
import MonadUtils
import Control.Applicative ( (<|>) )
import TrieMap
import VarSet
import TcSMonad
import FastString
......@@ -535,19 +534,20 @@ flatten d f fl (TyConApp tc tys)
| otherwise
= ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated
do { (xis, cos) <- flattenMany d f fl tys
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
(cos_args, cos_rest) = splitAt (tyConArity tc) cos
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
fam_ty = mkTyConApp tc xi_args
; (ret_co, rhs_xi, ct) <-
; (ret_co, rhs_xi) <-
case f of
FMSubstOnly ->
return (mkTcReflCo fam_ty, fam_ty, [])
return (mkTcReflCo fam_ty, fam_ty)
FMFullFlatten ->
do { flat_cache <- getFlatCache
; case lookupTM fam_ty flat_cache of
do { mb_ct <- lookupFlatEqn fam_ty
; case mb_ct of
Just ct
| let ctev = cc_ev ct
, ctev `canRewrite` fl
......@@ -564,23 +564,25 @@ flatten d f fl (TyConApp tc tys)
; (flat_rhs_xi,co) <- flatten (cc_depth ct) f ctev rhs_xi
; let final_co = evTermCoercion (ctEvTerm ctev)
`mkTcTransCo` mkTcSymCo co
; return (final_co, flat_rhs_xi,[]) }
; return (final_co, flat_rhs_xi) }
_ | isGiven fl -- Given: make new flatten skolem
-> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlattenSkolemTy fam_ty
; let co = mkTcReflCo fam_ty
; rhs_ty <- newFlattenSkolemTy fam_ty
-- Update the flat cache
; let co = mkTcReflCo fam_ty
new_fl = Given { ctev_gloc = ctev_gloc fl
, ctev_pred = mkTcEqPred fam_ty rhs_xi_var
, ctev_pred = mkTcEqPred fam_ty rhs_ty
, ctev_evtm = EvCoercion co }
ct = CFunEqCan { cc_ev = new_fl
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_xi_var
, cc_depth = d }
-- Update the flat cache
, cc_tyargs = xi_args
, cc_rhs = rhs_ty
, cc_depth = d }
; updFlatCache ct
; return (co, rhs_xi_var, [ct]) }
; updWorkListTcS $ extendWorkListEq ct
; return (co, rhs_ty) }
| otherwise -- Wanted or Derived: make new unification variable
-> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
......@@ -596,12 +598,11 @@ flatten d f fl (TyConApp tc tys)
, cc_depth = d }
-- Update the flat cache: just an optimisation!
; updFlatCache ct
; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var, [ct]) }
; updWorkListTcS $ extendWorkListEq ct
; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
Cached {} -> panic "flatten TyConApp, var must be fresh!" }
}
-- Emit the flat constraints
; updWorkListTcS $ appendWorkListEqs ct
; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos
; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable
-- cf Trac #5655
, mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) $
......@@ -613,11 +614,29 @@ flatten d _f ctxt ty@(ForAllTy {})
-- We allow for-alls when, but only when, no type function
-- applications inside the forall involve the bound type variables.
= do { let (tvs, rho) = splitForAllTys ty
; (rho', co) <- flatten d FMSubstOnly ctxt rho
; (rho', co) <- flatten d FMSubstOnly ctxt rho
-- Substitute only under a forall
-- See Note [Flattening under a forall]
; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
\end{code}
Note [Flattening under a forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Under a forall, we
(a) MUST apply the inert subsitution
(b) MUST NOT flatten type family applications
Hence FMSubstOnly.
For (a) consider c ~ a, a ~ T (forall b. (b, [c])
If we don't apply the c~a substitution to the second constraint
we won't see the occurs-check error.
For (b) consider (a ~ forall b. F a b), we don't want to flatten
to (a ~ forall b.fsk, F a b ~ fsk)
because now the 'b' has escaped its scope. We'd have to flatten to
(a ~ forall b. fsk b, forall b. F a b ~ fsk b)
and we have not begun to think about how to make that work!
\begin{code}
flattenTyVar :: SubGoalDepth
-> FlattenMode
......@@ -782,7 +801,7 @@ canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {})
; return Stop } }
| otherwise
= do { traceTcS "Ommitting decomposition of given polytype equality" $
pprEq s1 s2
pprEq s1 s2 -- See Note [Do not decompose given polytype equalities]
; return Stop }
canEq d fl _ _ = canEqFailure d fl
......@@ -875,6 +894,13 @@ emitKindConstraint ct
orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
\end{code}
Note [Do not decompose given polytype equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this?
No -- what would the evidence look like. So instead we simply discard
this given evidence.
Note [Combining insoluble constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As this point we have an insoluble constraint, like Int~Bool.
......@@ -1017,18 +1043,14 @@ inert set is an idempotent subustitution...
\begin{code}
data TypeClassifier
= FskCls TcTyVar -- ^ Flatten skolem
| VarCls TcTyVar -- ^ Non-flatten-skolem variable
= VarCls TcTyVar -- ^ Type variable
| FunCls TyCon [Type] -- ^ Type function, exactly saturated
| OtherCls TcType -- ^ Neither of the above
classify :: TcType -> TypeClassifier
classify (TyVarTy tv)
| isTcTyVar tv,
FlatSkol {} <- tcTyVarDetails tv = FskCls tv
| otherwise = VarCls tv
classify (TyVarTy tv) = ASSERT2( isTcTyVar tv, ppr tv ) VarCls tv
classify (TyConApp tc tys) | isSynFamilyTyCon tc
, tyConArity tc == length tys
= FunCls tc tys
......@@ -1047,7 +1069,6 @@ reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool
--
-- Postcondition: After re-orienting, first arg is not OTherCls
reOrient _fl (OtherCls {}) (FunCls {}) = True
reOrient _fl (OtherCls {}) (FskCls {}) = True
reOrient _fl (OtherCls {}) (VarCls {}) = True
reOrient _fl (OtherCls {}) (OtherCls {}) = panic "reOrient" -- One must be Var/Fun
......@@ -1058,22 +1079,13 @@ reOrient _fl (FunCls {}) (VarCls _tv) = False
reOrient _fl (FunCls {}) _ = False -- Fun/Other on rhs
reOrient _fl (VarCls {}) (FunCls {}) = True
reOrient _fl (VarCls {}) (FskCls {}) = False
reOrient _fl (VarCls {}) (OtherCls {}) = False
reOrient _fl (VarCls tv1) (VarCls tv2)
| isMetaTyVar tv2 && not (isMetaTyVar tv1) = True
| otherwise = False
-- Just for efficiency, see CTyEqCan invariants
reOrient _fl (FskCls {}) (VarCls tv2) = isMetaTyVar tv2
-- Just for efficiency, see CTyEqCan invariants
reOrient _fl (FskCls {}) (FskCls {}) = False
reOrient _fl (FskCls {}) (FunCls {}) = True
reOrient _fl (FskCls {}) (OtherCls {}) = False
------------------
canEqLeaf :: SubGoalDepth -- Depth
......
......@@ -77,7 +77,7 @@ reportUnsolved runtimeCoercionErrors wanted
; errs_so_far <- ifErrsM (return True) (return False)
; let tidy_env = tidyFreeTyVars env0 free_tvs
free_tvs = tyVarsOfWC wanted
free_tvs = tyVarsOfZonkedWC wanted
err_ctxt = CEC { cec_encl = []
, cec_insol = errs_so_far || insolubleWC wanted
-- Don't report ambiguity errors if
......@@ -143,7 +143,10 @@ reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }
where
env = cec_tidy ctxt
tidy_insols = mapBag (tidyCt env) insols
tidy_flats = mapBag (tidyCt env) (keepWanted flats)
tidy_flats = mapBag (tidyCt env) flats
-- All the Derived ones have been filtered out alrady
-- by the constraint solver. This is ok; we don't want
-- to report unsolved Derived goals as error
-- See Note [Do not report derived but soluble errors]
reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM ()
......@@ -1085,14 +1088,13 @@ find_thing tidy_env ignore_it (ATyVar name tv)
find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
warnDefaulting :: [Ct] -> Type -> TcM ()
warnDefaulting :: Cts -> Type -> TcM ()
warnDefaulting wanteds default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- tcInitTidyEnv
; let wanted_bag = listToBag wanteds
tidy_env = tidyFreeTyVars env0 $
tyVarsOfCts wanted_bag
tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag
; let tidy_env = tidyFreeTyVars env0 $
tyVarsOfCts wanteds
tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
(loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
<+> quotes (ppr default_ty))
......@@ -1131,20 +1133,6 @@ solverDepthErrorTcS depth stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ...
= setCtFlavorLoc (cc_ev top_item) $
do { ev_vars <- mapM (zonkEvVar . cc_id) stack
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
where
top_item = head stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
-}
flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a
flattenForAllErrorTcS fl ty
= setCtFlavorLoc fl $
......
......@@ -1257,16 +1257,17 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
SkolemTv {} -> lookup_in_env
RuntimeUnk {} -> lookup_in_env
FlatSkol ty -> zonkTcTypeToType env ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
zonkTcTypeToType env (tyVarKind tv)
; zonk_unbound_tyvar (setTyVarKind tv kind) }
Indirect ty -> do { zty <- zonkTcTypeToType env ty
-- Small optimisation: shortern-out indirect steps
-- so that the old type may be more easily collected.
; writeMutVar ref (Indirect zty)
; return zty } }
MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref
; case cts of
Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
zonkTcTypeToType env (tyVarKind tv)
; zonk_unbound_tyvar (setTyVarKind tv kind) }
Indirect ty -> do { zty <- zonkTcTypeToType env ty
-- Small optimisation: shortern-out indirect steps
-- so that the old type may be more easily collected.
; writeMutVar ref (Indirect zty)
; return zty } }
| otherwise
= lookup_in_env
where
......
This diff is collapsed.
......@@ -28,7 +28,7 @@ module TcMType (
mkTcTyVarName,
newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
isFilledMetaTyVar, isFlexiMetaTyVar,
newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar,
--------------------------------
-- Creating new evidence variables
......@@ -112,10 +112,18 @@ import Data.List ( (\\), partition, mapAccumL )
%************************************************************************
\begin{code}
mkKindName :: Unique -> Name
mkKindName unique = mkSystemName unique kind_var_occ
kind_var_occ :: OccName -- Just one for all MetaKindVars
-- They may be jiggled by tidying
kind_var_occ = mkOccName tvName "k"
newMetaKindVar :: TcM TcKind
newMetaKindVar = do { uniq <- newUnique
; ref <- newMutVar Flexi
; return (mkTyVarTy (mkMetaKindVar uniq ref)) }
; details <- newMetaDetails TauTv
; let kv = mkTcTyVar (mkKindName uniq) superKind details
; return (mkTyVarTy kv) }
newMetaKindVars :: Int -> TcM [TcKind]
newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
......@@ -266,12 +274,18 @@ tcInstSigTyVar subst tv
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { uniq <- newMetaUnique
; ref <- newMutVar Flexi
= do { uniq <- newUnique
; let name' = setNameUnique name uniq
-- Use the same OccName so that the tidy-er
-- doesn't gratuitously rename 'a' to 'a0' etc
; return (mkTcTyVar name' kind (MetaTv SigTv ref)) }
; details <- newMetaDetails SigTv
; return (mkTcTyVar name' kind details) }
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails info
= do { ref <- newMutVar Flexi
; untch <- getUntouchables
; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
\end{code}
Note [Kind substitution when instantiating]
......@@ -300,14 +314,13 @@ instead of the buggous
newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newMetaTyVar meta_info kind
= do { uniq <- newMetaUnique
; ref <- newMutVar Flexi
= do { uniq <- newUnique
; let name = mkTcTyVarName uniq s
s = case meta_info of
TauTv -> fsLit "t"
TcsTv -> fsLit "u"
SigTv -> fsLit "a"
; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
mkTcTyVarName :: Unique -> FastString -> Name
-- Make sure that fresh TcTyVar names finish with a digit
......@@ -323,7 +336,7 @@ isFilledMetaTyVar :: TyVar -> TcM Bool
-- True of a filled-in (Indirect) meta type variable
isFilledMetaTyVar tv
| not (isTcTyVar tv) = return False
| MetaTv _ ref <- tcTyVarDetails tv
| MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
= do { details <- readMutVar ref
; return (isIndirect details) }
| otherwise = return False
......@@ -332,7 +345,7 @@ isFlexiMetaTyVar :: TyVar -> TcM Bool
-- True of a un-filled-in (Flexi) meta type variable
isFlexiMetaTyVar tv
| not (isTcTyVar tv) = return False
| MetaTv _ ref <- tcTyVarDetails tv
| MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
= do { details <- readMutVar ref
; return (isFlexi details) }
| otherwise = return False
......@@ -351,7 +364,7 @@ writeMetaTyVar tyvar ty
= WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
return ()
| MetaTv _ ref <- tcTyVarDetails tyvar
| MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
= writeMetaTyVarRef tyvar ref ty
| otherwise
......@@ -433,11 +446,11 @@ tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar)
-- Make a new unification variable tyvar whose Name and Kind come from
-- an existing TyVar. We substitute kind variables in the kind.
tcInstTyVarX subst tyvar
= do { uniq <- newMetaUnique
; ref <- newMutVar Flexi
= do { uniq <- newUnique
; details <- newMetaDetails TauTv
; let name = mkSystemName uniq (getOccName tyvar)
kind = substTy subst (tyVarKind tyvar)
new_tv = mkTcTyVar name kind (MetaTv TauTv ref)
new_tv = mkTcTyVar name kind details
; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
\end{code}
......@@ -548,7 +561,7 @@ zonkQuantifiedTyVar tv
-- It might be a skolem type variable,
-- for example from a user type signature
MetaTv _ ref ->
MetaTv { mtv_ref = ref } ->
do when debugIsOn $ do
-- [Sept 04] Check for non-empty.
-- See note [Silly Type Synonym]
......@@ -601,6 +614,7 @@ zonkImplication implic@(Implic { ic_given = given
; loc' <- zonkGivenLoc loc
; wanted' <- zonkWC wanted
; return (implic { ic_given = given'
, ic_fsks = [] -- Zonking removes all FlatSkol tyvars
, ic_wanted = wanted'
, ic_loc = loc' }) }
......@@ -778,10 +792,11 @@ zonkTcTyVar tv
SkolemTv {} -> zonk_kind_and_return
RuntimeUnk {} -> zonk_kind_and_return
FlatSkol ty -> zonkTcType ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> zonk_kind_and_return
Indirect ty -> zonkTcType ty }
MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref
; case cts of
Flexi -> zonk_kind_and_return
Indirect ty -> zonkTcType ty }
where
zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
; return (TyVarTy z_tv) }
......
......@@ -42,7 +42,6 @@ import NameSet
import Bag
import Outputable
import UniqSupply
import Unique
import UniqFM
import DynFlags
import Maybes
......@@ -78,7 +77,6 @@ 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 ;
keep_var <- newIORef emptyNameSet ;
used_rdr_var <- newIORef Set.empty ;
......@@ -151,8 +149,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_meta = meta_var,
tcl_untch = initTyVarUnique
tcl_untch = noUntouchables
} ;
} ;
......@@ -345,16 +342,6 @@ 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 ;
......@@ -1049,20 +1036,28 @@ captureConstraints thing_inside
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 })
; uniq <- newUnique
; let untch' = pushUntouchables uniq (tcl_untch env)
; res <- setLclEnv (env { tcl_untch = untch' })
thing_inside
; high_meta <- readTcRef (tcl_meta env)
; return (res, TouchableRange low_meta high_meta) }
; return (res, untch') }
getUntouchables :: TcM Untouchables
getUntouchables = do { env <- getLclEnv
; return (tcl_untch env) }
setUntouchables :: Untouchables -> TcM a -> TcM a
setUntouchables untch thing_inside
= updLclEnv (\env -> env { tcl_untch = untch }) thing_inside
isUntouchable :: TcTyVar -> TcM Bool
isUntouchable tv
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
-- Kind variables are always touchable
| isSuperKind (tyVarKind tv)
= return False
| otherwise
= do { env <- getLclEnv
; return (varUnique tv < tcl_untch env) }
; return (isTouchableMetaTyVar (tcl_untch env) tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
......
......@@ -48,17 +48,15 @@ module TcRnTypes(
-- Arrows
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Constraints
Untouchables(..), inTouchableRange, isNoUntouchables,
-- Canonical constraints
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, keepWanted,
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC,
singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan,
isCDictCan_Maybe, isCFunEqCan_Maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt,
ctWantedLoc, ctEvidence,
SubGoalDepth, mkNonCanonical, ctPred, ctEvPred, ctEvTerm, ctEvId,
SubGoalDepth, mkNonCanonical, mkNonCanonicalCt,
ctPred, ctEvPred, ctEvTerm, ctEvId,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, addFlats, addImplics, mkFlatWC,
......@@ -113,7 +111,6 @@ import VarSet
import ErrUtils
import UniqFM
import UniqSupply
import Unique
import BasicTypes
import Bag
import DynFlags
......@@ -442,13 +439,7 @@ data TcLclEnv -- Changes as we move inside an expression
-- Why mutable? see notes with tcGetGlobalTyVars
tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints
-- 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
tcl_untch :: Untouchables
}
type TcTypeEnv = NameEnv TcTyThing
......@@ -918,6 +909,9 @@ built (in TcCanonical)
mkNonCanonical :: CtEvidence -> Ct
mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0}
mkNonCanonicalCt :: Ct -> Ct
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_depth = 0}
ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev
......@@ -925,11 +919,12 @@ ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant]
ctPred ct = ctEvPred (cc_ev ct)
keepWanted :: Cts