Commit 9591547f authored by dimitris's avatar dimitris
Browse files

Introducing:

   1) Postponing the application of instances when there
      is a possibility of a given matching. With the addition
      of prioritizing equalities this fixes #5002 and #4981.

   2) Implemented caching of flattening in constraint
      simplification. This improves efficiency (fixes #5030)

   3) Simplified pushing of unsolved wanteds
      (now pushing only equalities) inside implications.
parent 2d520511
......@@ -551,7 +551,7 @@ tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
......@@ -595,8 +595,8 @@ substFlavoredEvVar subst (EvVarX v fl)
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
substFlavor _ fl = fl
substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
......
......@@ -92,6 +92,7 @@ expansions contain any type function applications would speed things
up a bit; right now we waste a lot of energy traversing the same types
multiple times.
\begin{code}
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
......@@ -139,7 +140,7 @@ flatten fl (TyConApp tc tys)
-- Otherwise, it's a type function application, and we have to
-- flatten it away as well, and generate a new given equality constraint
-- between the application and a newly generated flattening skolem variable.
| otherwise
| otherwise
= ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated
do { (xis, cos, ccs) <- flattenMany fl tys
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
......@@ -148,33 +149,40 @@ flatten fl (TyConApp tc tys)
-- in which case the remaining arguments should
-- be dealt with by AppTys
fam_ty = mkTyConApp tc xi_args
fam_co = fam_ty -- identity
; (ret_co, rhs_var, ct) <-
if isGiven fl then
do { rhs_var <- newFlattenSkolemTy fam_ty
; cv <- newGivenCoVar fam_ty rhs_var fam_co
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = fl -- Given
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; return $ (mkCoVarCoercion cv, rhs_var, ct) }
else -- Derived or Wanted: make a new *unification* flatten variable
do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
; cv <- newCoVar fam_ty rhs_var
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = mkWantedFlavor fl
-- Always Wanted, not Derived
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; return $ (mkCoVarCoercion cv, rhs_var, ct) }
fam_co = fam_ty -- identity
; (ret_co, rhs_var, ct) <-
do { is_cached <- lookupFlatCacheMap tc xi_args fl
; case is_cached of
Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
Nothing
| isGivenOrSolved fl ->
do { rhs_var <- newFlattenSkolemTy fam_ty
; cv <- newGivenCoVar fam_ty rhs_var fam_co
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = fl -- Given
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; let ret_co = mkCoVarCoercion cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) }
| otherwise ->
-- Derived or Wanted: make a new *unification* flatten variable
do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
; cv <- newCoVar fam_ty rhs_var
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = mkWantedFlavor fl
-- Always Wanted, not Derived
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; let ret_co = mkCoVarCoercion cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) } }
; return ( foldl AppTy rhs_var xi_rest
, foldl AppTy (mkSymCoercion ret_co
`mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
, ccs `extendCCans` ct) }
`mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
, ccs `andCCan` ct) }
flatten ctxt (PredTy pred)
......@@ -222,7 +230,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList
canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
; return (unionWorkLists ccs) }
mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
......@@ -238,6 +246,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
canon_one fev wl = do { wl' <- mkCanonicalFEV fev
; return (unionWorkList wl' wl) }
mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
mkCanonical fl ev = case evVarPred ev of
ClassP clas tys -> canClassToWorkList fl ev clas tys
......@@ -250,13 +259,13 @@ canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
; let no_flattening_happened = isEmptyCCan ccs
dict_co = mkTyConCoercion (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v
else if isGiven fl then return v
; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved fl then return v
-- The cos are all identities if fl=Given,
-- hence nothing to do
else do { v' <- newDictVar cn xis -- D xis
; when (isWanted fl) $ setDictBind v (EvCast v' dict_co)
; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
-- NB: No more setting evidence for derived now
; return v' }
......@@ -320,7 +329,7 @@ For Deriveds:
Here's an example that demonstrates why we chose to NOT add
superclasses during simplification: [Comes from ticket #4497]
class Num (RealOf t) => Normed t
type family RealOf x
......@@ -346,14 +355,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis
= return emptyWorkList -- Deriveds don't yield more superclasses because we will
-- add them transitively in the case of wanteds.
| isGiven orig_flavor
= do { let sc_theta = immSuperClasses cls xis
flavor = orig_flavor
; sc_vars <- mapM newEvVar sc_theta
; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
; mkCanonicals flavor sc_vars }
| isEmptyVarSet (tyVarsOfTypes xis)
| Just gk <- isGiven_maybe orig_flavor
= case gk of
GivenOrig -> do { let sc_theta = immSuperClasses cls xis
flavor = orig_flavor
; sc_vars <- mapM newEvVar sc_theta
; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
; mkCanonicals flavor sc_vars }
GivenSolved -> return emptyWorkList
-- Seems very dangerous to add the superclasses for dictionaries that may be
-- partially solved because we may end up with evidence loops.
| isEmptyVarSet (tyVarsOfTypes xis)
= return emptyWorkList -- Wanteds with no variables yield no deriveds.
-- See Note [Improvement from Ground Wanteds]
......@@ -428,7 +441,7 @@ canEq fl cv s1 s2
(mkCoVarCoercion v2) (mkCoVarCoercion v3)
; setCoBind cv res_co
; return (v1,v2,v3) }
else if isGiven fl then -- Given
else if isGivenOrSolved fl then -- Given
let co_orig = mkCoVarCoercion cv
coa = mkCsel1Coercion co_orig
cob = mkCsel2Coercion co_orig
......@@ -458,7 +471,7 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv)
; return (argv,resv) }
else if isGiven fl then
else if isGivenOrSolved fl then
let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv)
in do { argv <- newGivenCoVar s1 s2 arg
; resv <- newGivenCoVar t1 t2 res
......@@ -510,7 +523,7 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
; return argsv }
else if isGiven fl then
else if isGivenOrSolved fl then
let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
in zipWith3M newGivenCoVar tys1 tys2 cos
......@@ -532,7 +545,7 @@ canEq fl cv ty1 ty2
mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2)
; return (cv1,cv2) }
else if isGiven fl then
else if isGivenOrSolved fl then
let co1 = mkLeftCoercion $ mkCoVarCoercion cv
co2 = mkRightCoercion $ mkCoVarCoercion cv
in do { cv1 <- newGivenCoVar s1 s2 co1
......@@ -751,7 +764,7 @@ canEqLeaf _untch fl cv cls1 cls2
then do { cv' <- newCoVar s2 s1
; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv')
; return cv' }
else if isGiven fl then
else if isGivenOrSolved fl then
newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv))
else -- Derived
newDerivedId (EqPred s2 s1)
......@@ -784,8 +797,8 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
no_flattening_happened = isEmptyCCan ccs
; cv_new <- if no_flattening_happened then return cv
else if isGiven fl then return cv
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
-- cv' : F xis ~ xi2
......@@ -830,8 +843,8 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2
Nothing -> canEqFailure fl cv ;
Just xi2' ->
do { let no_flattening_happened = isEmptyCCan ccs2
; cv_new <- if no_flattening_happened then return cv
else if isGiven fl then return cv
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2
; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co)
......@@ -1057,7 +1070,7 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
; mapM (do_one subst) eqs }
where
fl' = case fl of
Given _ -> panic "mkFunDepEqns"
Given {} -> panic "mkFunDepEqns"
Wanted loc -> Wanted (push_ctx loc)
Derived loc -> Derived (push_ctx loc)
......
......@@ -16,6 +16,7 @@ import TcSMonad
import TcType
import TypeRep
import Type( isTyVarTy )
import Unify ( tcMatchTys )
import Inst
import InstEnv
......@@ -106,7 +107,7 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
-- because they are unconditionally wrong
-- Moreover, if any of the insolubles are givens, stop right there
-- ignoring nested errors, because the code is inaccessible
= do { let (given, other) = partitionBag (isGiven . evVarX) insols
= do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
insol_implics = filterBag ic_insol implics
; if isEmptyBag given
then do { mapBagM_ (reportInsoluble ctxt) other
......@@ -154,7 +155,8 @@ reportInsoluble ctxt (EvVarX ev flav)
| otherwise
= pprPanic "reportInsoluble" (pprEvVarWithType ev)
where
inaccessible_msg | Given loc <- flav
inaccessible_msg | Given loc GivenOrig <- flav
-- If a GivenSolved then we should not report inaccessible code
= hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
| otherwise = empty
......@@ -420,18 +422,18 @@ couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig)
= vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
2 (pprArising orig)
, vcat pp_givens ]
where
pp_givens
= case givens of
, vcat (pp_givens givens)]
pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
pp_givens givens
= case givens of
[] -> []
(g:gs) -> ppr_given (ptext (sLit "from the context")) g
: map (ppr_given (ptext (sLit "or from"))) gs
ppr_given herald (gs,loc)
= hang (herald <+> pprEvVarTheta gs)
2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
, ptext (sLit "at") <+> ppr (ctLocSpan loc)])
where ppr_given herald (gs,loc)
= hang (herald <+> pprEvVarTheta gs)
2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
, ptext (sLit "at") <+> ppr (ctLocSpan loc)])
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
......@@ -577,6 +579,18 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
<+> pprPred pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
, if not (null overlapping_givens) then
sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
else empty
, if null overlapping_givens && isSingleton matches && null unifiers then
-- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
-- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
-- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
else empty
, if not (isSingleton matches)
then -- Two or more matches
empty
......@@ -584,11 +598,39 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
ptext (sLit "when compiling the other instance declarations")])]
if null (overlapping_givens) then
vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
ptext (sLit "when compiling the other instance declarations")]
else empty])]
where
ispecs = [ispec | (ispec, _) <- matches]
givens = getUserGivens ctxt
overlapping_givens = unifiable_givens givens
unifiable_givens [] = []
unifiable_givens (gg:ggs)
| Just ggdoc <- matchable gg
= ggdoc : unifiable_givens ggs
| otherwise
= unifiable_givens ggs
matchable (evvars,gloc)
= case ev_vars_matching of
[] -> Nothing
_ -> Just $ hang (pprTheta ev_vars_matching)
2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
, ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
ev_var_matches (ClassP clas' tys')
| clas' == clas
, Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
= True
ev_var_matches (ClassP clas' tys') =
any ev_var_matches (immSuperClasses clas' tys')
ev_var_matches _ = False
reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
----------------------
......@@ -834,9 +876,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
\end{code}
%************************************************************************
......
......@@ -621,6 +621,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
-- We instantiate the dfun_id with superSkolems.
-- See Note [Subtle interaction of recursion and overlap]
-- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
......@@ -699,7 +702,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
listToBag meth_binds)
}
where
skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
......
This diff is collapsed.
......@@ -627,8 +627,8 @@ zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
zonkFlavor :: CtFlavor -> TcM CtFlavor
zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
zonkFlavor fl = return fl
zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
zonkFlavor fl = return fl
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
......
......@@ -40,11 +40,13 @@ module TcRnTypes(
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, pushErrCtxt,
WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
SkolemInfo(..),
CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
CtFlavor(..), pprFlavorArising, isWanted,
isGivenOrSolved, isGiven_maybe,
isDerived,
FlavoredEvVar,
-- Pretty printing
......@@ -923,35 +925,37 @@ pprWantedEvVar (EvVarX v _) = pprEvVarWithType v
\begin{code}
data CtFlavor
= Given GivenLoc -- We have evidence for this constraint in TcEvBinds
| Derived WantedLoc
-- We have evidence for this constraint in TcEvBinds;
-- *however* this evidence can contain wanteds, so
-- it's valid only provisionally to the solution of
-- these wanteds
| Wanted WantedLoc -- We have no evidence bindings for this constraint.
-- data DerivedOrig = DerSC | DerInst | DerSelf
-- Deriveds are either superclasses of other wanteds or deriveds, or partially
-- solved wanteds from instances, or 'self' dictionaries containing yet wanted
-- superclasses.
= Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
| Derived WantedLoc -- Derived's are just hints for unifications
| Wanted WantedLoc -- We have no evidence bindings for this constraint.
data GivenKind
= GivenOrig -- Originates in some given, such as signature or pattern match
| GivenSolved -- Is given as result of being solved, maybe provisionally on
-- some other wanted constraints.
instance Outputable CtFlavor where
ppr (Given {}) = ptext (sLit "[G]")
ppr (Wanted {}) = ptext (sLit "[W]")
ppr (Derived {}) = ptext (sLit "[D]")
ppr (Given _ GivenOrig) = ptext (sLit "[G]")
ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
ppr (Wanted {}) = ptext (sLit "[W]")
ppr (Derived {}) = ptext (sLit "[D]")
pprFlavorArising :: CtFlavor -> SDoc
pprFlavorArising (Derived wl ) = pprArisingAt wl
pprFlavorArising (Derived wl) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
pprFlavorArising (Given gl) = pprArisingAt gl
pprFlavorArising (Given gl _) = pprArisingAt gl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
isGiven :: CtFlavor -> Bool
isGiven (Given {}) = True
isGiven _ = False
isGivenOrSolved :: CtFlavor -> Bool
isGivenOrSolved (Given {}) = True
isGivenOrSolved _ = False
isGiven_maybe :: CtFlavor -> Maybe GivenKind
isGiven_maybe (Given _ gk) = Just gk
isGiven_maybe _ = Nothing
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
......
......@@ -15,13 +15,15 @@ module TcSMonad (
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts,
deCanonicalise, mkFrozenError,
isWanted, isGiven, isDerived,
isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
isWanted, isGivenOrSolved, isDerived,
isGivenOrSolvedCt, isGivenCt_maybe,
isWantedCt, isDerivedCt, pprFlavorArising,
isFlexiTcsTv,
canRewrite, canSolve,
combineCtLoc, mkGivenFlavor, mkWantedFlavor,
combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
mkWantedFlavor,
getWantedLoc,
TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality
......@@ -39,6 +41,8 @@ module TcSMonad (
setWantedTyBind,
lookupFlatCacheMap, updateFlatCacheMap,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
......@@ -104,6 +108,8 @@ import Id
import TcRnTypes
import Data.IORef
import qualified Data.Map as Map
#ifdef DEBUG
import StaticFlags( opt_PprStyle_Debug )
import Control.Monad( when )
......@@ -333,11 +339,16 @@ getWantedLoc ct
isWantedCt :: CanonicalCt -> Bool
isWantedCt ct = isWanted (cc_flavor ct)
isGivenCt :: CanonicalCt -> Bool
isGivenCt ct = isGiven (cc_flavor ct)
isDerivedCt :: CanonicalCt -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
isGivenOrSolvedCt :: CanonicalCt -> Bool
isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
......@@ -362,22 +373,27 @@ canRewrite = canSolve
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
combineCtLoc (Wanted loc) _ = loc
combineCtLoc _ (Wanted loc) = loc
combineCtLoc (Derived loc ) _ = loc
combineCtLoc _ (Derived loc ) = loc
combineCtLoc (Wanted loc) _ = loc
combineCtLoc _ (Wanted loc) = loc
combineCtLoc (Derived loc ) _ = loc
combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
mkSolvedFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
mkSolvedFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
\end{code}
%************************************************************************
......@@ -412,10 +428,33 @@ data TcSEnv
tcs_untch :: TcsUntouchables,
tcs_ic_depth :: Int, -- Implication nesting depth
tcs_count :: IORef Int -- Global step count
tcs_ic_depth :: Int, -- Implication nesting depth
tcs_count :: IORef Int, -- Global step count
tcs_flat_map :: IORef FlatCache
}
data FlatCache
= FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
-- Invariant: all CtFlavors here satisfy isGiven
, wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
-- Invariant: all CtFlavors here satisfy isWanted
emptyFlatCache :: FlatCache
emptyFlatCache
= FlatCache { givenFlatCache = Map.empty, wantedFlatCache = Map.empty }
newtype FunEqHead = FunEqHead (TyCon,[Xi])
instance Eq FunEqHead where
FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && tcEqTypes xis1 xis2
instance Ord FunEqHead where
FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2)
= case compare tc1 tc2 of
EQ -> tcCmpTypes xis1 xis2
other -> other
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables,
-- but records extra TcsTv variables generated during simplification
......@@ -512,12 +551,14 @@ runTcS context untouch tcs
= do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; step_count <- TcM.newTcRef 0
; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
, tcs_context = context
, tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet
, tcs_count = step_count
, tcs_ic_depth = 0
, tcs_flat_map = flat_cache_var
}
-- Run the computation
......@@ -544,21 +585,29 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
, tcs_untch = (_outer_range, outer_tcs)
, tcs_count = count
, tcs_ic_depth = idepth
, tcs_context = ctxt } ->
let
inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
, tcs_context = ctxt
, tcs_flat_map = orig_flat_cache_var
} ->
do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
-- The inner_range should be narrower than the outer one
-- (thus increasing the set of untouchables) but
-- the inner Tcs-untouchables must be unioned with the
-- outer ones!
nest_env = TcSEnv { tcs_ev_binds = ref
, tcs_ty_binds = ty_binds
, tcs_untch = inner_untch
, tcs_count = count
, tcs_ic_depth = idepth+1
, tcs_context = ctxtUnderImplic ctxt }
in
thing_inside nest_env
; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
; flat_cache_var <- TcM.newTcRef orig_flat_cache -- emptyFlatCache
-- Consider copying the results the tcs_flat_map of the
-- incomping constraint, but we must make sure that we
-- have pushed everything in, which seems somewhat fragile
; let nest_env = TcSEnv { tcs_ev_binds = ref