X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=0992fb971e6d8e6d49be73ca66afce68cb1462fe;hp=a45f9a594d166b3dcb591ebd56467bfd2f80cebe;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=fbb99e831a0c0510e79b2f0c91bbdffd142ea951 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index a45f9a5..0992fb9 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -5,58 +5,57 @@ module TcSMonad ( -- Canonical constraints CanonicalCts, emptyCCan, andCCan, andCCans, singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, - isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, + isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, + isCFrozenErr, + + WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList, + workListFromEq, workListFromNonEq, + workListFromEqs, workListFromNonEqs, foldrWorkListM, CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, - mkWantedConstraints, deCanonicaliseWanted, - makeGivens, makeSolvedByInst, + deCanonicalise, mkFrozenError, - CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, - isGivenCt, isWantedCt, pprFlavorArising, + isWanted, isGivenOrSolved, isDerived, + isGivenOrSolvedCt, isGivenCt_maybe, + isWantedCt, isDerivedCt, pprFlavorArising, isFlexiTcsTv, - DerivedOrig (..), canRewrite, canSolve, - combineCtLoc, mkGivenFlavor, mkWantedFlavor, + combineCtLoc, mkSolvedFlavor, mkGivenFlavor, + mkWantedFlavor, getWantedLoc, - TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality + TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality + traceFireTcS, bumpStepCountTcS, tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, - - -- Creation of evidence variables - newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar, + -- Creation of evidence variables + newEvVar, newCoVar, newGivenCoVar, + newDerivedId, newIPVar, newDictVar, newKindConstraint, -- Setting evidence variables - setWantedCoBind, setDerivedCoBind, - setIPBind, setDictBind, setEvBind, + setCoBind, setIPBind, setDictBind, setEvBind, setWantedTyBind, - newTcEvBindsTcS, - - getInstEnvs, getFamInstEnvs, -- Getting the environments + lookupFlatCacheMap, updateFlatCacheMap, + + getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, - getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, getTcSErrors, - getTcSErrorsBag, FrozenError (..), - addErrorTcS, - ErrorKind(..), + getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, newFlattenSkolemTy, -- Flatten skolems instDFunTypes, -- Instantiation instDFunConstraints, - newFlexiTcSTy, - - isGoodRecEv, + newFlexiTcSTy, instFlexiTcS, compatKind, - TcsUntouchables, isTouchableMetaTyVar, isTouchableMetaTyVar_InRange, @@ -66,15 +65,11 @@ module TcSMonad ( matchClass, matchFam, MatchInstResult (..), checkWellStagedDFun, warnTcS, - pprEq, -- Smaller utils, re-exported from TcM + pprEq -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the -- instance matcher in TcSimplify. I am wondering -- if the whole instance matcher simply belongs -- here - - - mkWantedFunDepEqns -- Instantiation of 'Equations' from FunDeps - ) where #include "HsVersions.h" @@ -87,14 +82,12 @@ import InstEnv import FamInst import FamInstEnv -import NameSet ( addOneToNameSet ) - import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys ) +import Kind import TcType -import Module import DynFlags import Coercion @@ -109,16 +102,20 @@ import Outputable import Bag import MonadUtils import VarSet +import Pair import FastString import HsBinds -- for TcEvBinds stuff import Id -import FunDeps - import TcRnTypes - -import Control.Monad import Data.IORef + +import qualified Data.Map as Map + +#ifdef DEBUG +import StaticFlags( opt_PprStyle_Debug ) +import Control.Monad( when ) +#endif \end{code} @@ -159,8 +156,8 @@ data CanonicalCt | CTyEqCan { -- tv ~ xi (recall xi means function free) -- Invariant: -- * tv not in tvs(xi) (occurs check) - -- * If constraint is given then typeKind xi `compatKind` typeKind tv - -- See Note [Spontaneous solving and kind compatibility] + -- * typeKind xi `compatKind` typeKind tv + -- See Note [Spontaneous solving and kind compatibility] -- * We prefer unification variables on the left *JUST* for efficiency cc_id :: EvVar, cc_flavor :: CtFlavor, @@ -170,8 +167,7 @@ data CanonicalCt | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun - -- * If constraint is given then - -- typeKind (F xis) `compatKind` typeKind xi + -- * typeKind (F xis) `compatKind` typeKind xi cc_id :: EvVar, cc_flavor :: CtFlavor, cc_fun :: TyCon, -- A type function @@ -181,37 +177,27 @@ data CanonicalCt } -compatKind :: Kind -> Kind -> Bool + | CFrozenErr { -- A "frozen error" does not interact with anything + -- See Note [Frozen Errors] + cc_id :: EvVar, + cc_flavor :: CtFlavor + } + +mkFrozenError :: CtFlavor -> EvVar -> CanonicalCt +mkFrozenError fl ev = CFrozenErr { cc_id = ev, cc_flavor = fl } + +compatKind :: Kind -> Kind -> Bool compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 -makeGivens :: CanonicalCts -> CanonicalCts -makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol }) - -- The UnkSkol doesn't matter because these givens are - -- not contradictory (else we'd have rejected them already) - -makeSolvedByInst :: CanonicalCt -> CanonicalCt --- Record that a constraint is now solved --- Wanted -> Derived --- Given, Derived -> no-op -makeSolvedByInst ct - | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc DerInst } - | otherwise = ct - -mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints -mkWantedConstraints flats implics - = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics - -deCanonicaliseWanted :: CanonicalCt -> WantedEvVar -deCanonicaliseWanted ct - = WARN( not (isWanted $ cc_flavor ct), ppr ct ) - let Wanted loc = cc_flavor ct - in WantedEvVar (cc_id ct) loc +deCanonicalise :: CanonicalCt -> FlavoredEvVar +deCanonicalise ct = mkEvVarX (cc_id ct) (cc_flavor ct) tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty +tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty +tyVarsOfCanonical (CFrozenErr { cc_id = ev }) = tyVarsOfEvVar ev tyVarsOfCDict :: CanonicalCt -> TcTyVarSet tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys @@ -229,9 +215,11 @@ instance Outputable CanonicalCt where ppr (CIPCan ip fl ip_nm ty) = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty) ppr (CTyEqCan co fl tv ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty) ppr (CFunEqCan co fl tc tys ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty) + ppr (CFrozenErr co fl) + = ppr fl <+> pprEvVarWithType co \end{code} Note [Canonical implicit parameter constraints] @@ -281,8 +269,61 @@ isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc isCFunEqCan_Maybe _ = Nothing +isCFrozenErr :: CanonicalCt -> Bool +isCFrozenErr (CFrozenErr {}) = True +isCFrozenErr _ = False + + +-- A mixture of Given, Wanted, and Derived constraints. +-- We split between equalities and the rest to process equalities first. +data WorkList = WorkList { weqs :: CanonicalCts + -- NB: weqs includes equalities /and/ family equalities + , wrest :: CanonicalCts } + +unionWorkList :: WorkList -> WorkList -> WorkList +unionWorkList wl1 wl2 + = WorkList { weqs = weqs wl1 `andCCan` weqs wl2 + , wrest = wrest wl1 `andCCan` wrest wl2 } + +unionWorkLists :: [WorkList] -> WorkList +unionWorkLists = foldr unionWorkList emptyWorkList + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl) + +emptyWorkList :: WorkList +emptyWorkList + = WorkList { weqs = emptyBag, wrest = emptyBag } + +workListFromEq :: CanonicalCt -> WorkList +workListFromEq = workListFromEqs . singleCCan + +workListFromNonEq :: CanonicalCt -> WorkList +workListFromNonEq = workListFromNonEqs . singleCCan + +workListFromNonEqs :: CanonicalCts -> WorkList +workListFromNonEqs cts + = WorkList { weqs = emptyCCan, wrest = cts } + +workListFromEqs :: CanonicalCts -> WorkList +workListFromEqs cts + = WorkList { weqs = cts, wrest = emptyCCan } + +foldrWorkListM :: (Monad m) => (CanonicalCt -> r -> m r) + -> r -> WorkList -> m r +-- Prioritizes equalities +foldrWorkListM on_ct r (WorkList {weqs = eqs, wrest = rest }) + = do { r1 <- foldrBagM on_ct r eqs + ; foldrBagM on_ct r1 rest } + +instance Outputable WorkList where + ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl) + , text "WorkList (Other) = " <+> ppr (wrest wl) ] + \end{code} + + %************************************************************************ %* * CtFlavor @@ -291,49 +332,6 @@ isCFunEqCan_Maybe _ = Nothing %************************************************************************ \begin{code} -data CtFlavor - = Given GivenLoc -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc DerivedOrig - -- 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 --- Deriveds are either superclasses of other wanteds or deriveds, or partially --- solved wanteds from instances. - -instance Outputable CtFlavor where - ppr (Given _) = ptext (sLit "[Given]") - ppr (Wanted _) = ptext (sLit "[Wanted]") - ppr (Derived {}) = ptext (sLit "[Derived]") - -isWanted :: CtFlavor -> Bool -isWanted (Wanted {}) = True -isWanted _ = False - -isGiven :: CtFlavor -> Bool -isGiven (Given {}) = True -isGiven _ = False - -isDerived :: CtFlavor -> Bool -isDerived (Derived {}) = True -isDerived _ = False - -isDerivedSC :: CtFlavor -> Bool -isDerivedSC (Derived _ DerSC) = True -isDerivedSC _ = False - -isDerivedByInst :: CtFlavor -> Bool -isDerivedByInst (Derived _ DerInst) = True -isDerivedByInst _ = False - -pprFlavorArising :: CtFlavor -> SDoc -pprFlavorArising (Derived wl _) = pprArisingAt wl -pprFlavorArising (Wanted wl) = pprArisingAt wl -pprFlavorArising (Given gl) = pprArisingAt gl - getWantedLoc :: CanonicalCt -> WantedLoc getWantedLoc ct = ASSERT (isWanted (cc_flavor ct)) @@ -341,11 +339,17 @@ getWantedLoc ct Wanted wl -> wl _ -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty - -isWantedCt :: CanonicalCt -> Bool +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 @@ -355,12 +359,14 @@ canSolve :: CtFlavor -> CtFlavor -> Bool -- active(tv ~ xi) = tv -- active(D xis) = D xis -- active(IP nm ty) = nm +-- +-- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ----------------------------------------- canSolve (Given {}) _ = True -canSolve (Derived {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True +canSolve (Wanted {}) (Derived {}) = True canSolve (Wanted {}) (Wanted {}) = True -canSolve _ _ = False +canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given +canSolve _ _ = False -- (There is no *evidence* for a derived.) canRewrite :: CtFlavor -> CtFlavor -> Bool -- canRewrite ctid1 ctid2 @@ -369,24 +375,29 @@ 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" +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) -mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk) -mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk) +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 (Wanted loc) = Wanted loc +mkWantedFlavor (Derived loc) = Wanted loc +mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) \end{code} - %************************************************************************ %* * %* The TcS solver monad * @@ -417,64 +428,53 @@ data TcSEnv tcs_context :: SimplContext, - tcs_errors :: IORef (Bag FrozenError), - -- Frozen errors that we defer reporting as much as possible, in order to - -- make them as informative as possible. See Note [Frozen Errors] + tcs_untch :: TcsUntouchables, - tcs_untch :: TcsUntouchables + tcs_ic_depth :: Int, -- Implication nesting depth + tcs_count :: IORef Int, -- Global step count + + tcs_flat_map :: IORef FlatCache } -type TcsUntouchables = (Untouchables,TcTyVarSet) --- Like the TcM Untouchables, --- but records extra TcsTv variables generated during simplification --- See Note [Extra TcsTv untouchables] in TcSimplify +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 } -data FrozenError - = FrozenError ErrorKind CtFlavor TcType TcType +newtype FunEqHead = FunEqHead (TyCon,[Xi]) -data ErrorKind - = MisMatchError | OccCheckError | KindError +instance Eq FunEqHead where + FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2 -instance Outputable FrozenError where - ppr (FrozenError _frknd fl ty1 ty2) = ppr fl <+> pprEq ty1 ty2 <+> text "(frozen)" +instance Ord FunEqHead where + FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) + = case compare tc1 tc2 of + EQ -> cmpTypes xis1 xis2 + other -> other +type TcsUntouchables = (Untouchables,TcTyVarSet) +-- Like the TcM Untouchables, +-- but records extra TcsTv variables generated during simplification +-- See Note [Extra TcsTv untouchables] in TcSimplify \end{code} -Note [Frozen Errors] -~~~~~~~~~~~~~~~~~~~~ -Some of the errors that we get during canonicalization are best reported when all constraints -have been simplified as much as possible. For instance, assume that during simplification -the following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta - -When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail we will simply -see a message: - 'Can't construct the infinite type beta ~ uf1 beta' -and the user has no idea what the uf1 variable is. - -Instead our plan is that we will NOT fail immediately, but: - (1) Record the "frozen" error in the tcs_errors field - (2) Isolate the offending constraint from the rest of the inerts - (3) Keep on simplifying/canonicalizing - -At the end, we will hopefully have substituted uf1 := F alpha, and we will be able to -report a more informative error: - 'Can't construct the infinite type beta ~ F alpha beta' \begin{code} - data SimplContext - = SimplInfer -- Inferring type of a let-bound thing - | SimplRuleLhs -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck -- Checking a type signature or RULE rhs + = SimplInfer SDoc -- Inferring type of a let-bound thing + | SimplRuleLhs RuleName -- Inferring type of a RULE lhs + | SimplInteractive -- Inferring type at GHCi prompt + | SimplCheck SDoc -- Checking a type signature or RULE rhs instance Outputable SimplContext where - ppr SimplInfer = ptext (sLit "SimplInfer") - ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs") + ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d + ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d + ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) ppr SimplInteractive = ptext (sLit "SimplInteractive") - ppr SimplCheck = ptext (sLit "SimplCheck") isInteractive :: SimplContext -> Bool isInteractive SimplInteractive = True @@ -484,14 +484,14 @@ simplEqsOnly :: SimplContext -> Bool -- Simplify equalities only, not dictionaries -- This is used for the LHS of rules; ee -- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly SimplRuleLhs = True -simplEqsOnly _ = False +simplEqsOnly (SimplRuleLhs {}) = True +simplEqsOnly _ = False performDefaulting :: SimplContext -> Bool -performDefaulting SimplInfer = False -performDefaulting SimplRuleLhs = False -performDefaulting SimplInteractive = True -performDefaulting SimplCheck = True +performDefaulting (SimplInfer {}) = False +performDefaulting (SimplRuleLhs {}) = False +performDefaulting SimplInteractive = True +performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -529,22 +529,38 @@ panicTcS doc = pprPanic "TcCanonical" doc traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc -traceTcS0 :: String -> SDoc -> TcS () -traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc +bumpStepCountTcS :: TcS () +bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +traceFireTcS :: Int -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS depth doc + = TcS $ \env -> + TcM.ifDOptM Opt_D_dump_cs_trace $ + do { n <- TcM.readTcRef (tcs_count env) + ; let msg = int n + <> text (replicate (tcs_ic_depth env) '>') + <> brackets (int depth) <+> doc + ; TcM.dumpTcRn msg } runTcS :: SimplContext -> Untouchables -- Untouchables -> TcS a -- What to run - -> TcM (a, Bag FrozenError, Bag EvBind) + -> TcM (a, Bag EvBind) runTcS context untouch tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds - ; err_ref <- TcM.newTcRef emptyBag + ; 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_errors = err_ref + , tcs_count = step_count + , tcs_ic_depth = 0 + , tcs_flat_map = flat_cache_var } -- Run the computation @@ -553,26 +569,49 @@ runTcS context untouch tcs ; ty_binds <- TcM.readTcRef ty_binds_var ; mapM_ do_unification (varEnvElts ty_binds) +#ifdef DEBUG + ; count <- TcM.readTcRef step_count + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") + <+> int count <+> ppr context) +#endif -- And return - ; frozen_errors <- TcM.readTcRef err_ref ; ev_binds <- TcM.readTcRef evb_ref - ; return (res, frozen_errors, evBindMapBinds ev_binds) } + ; return (res, evBindMapBinds ev_binds) } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a -nestImplicTcS ref untch (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, - tcs_context = ctxt, - tcs_errors = err_ref } -> - let - nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_ty_binds = ty_binds - , tcs_untch = untch - , tcs_context = ctxtUnderImplic ctxt - , tcs_errors = err_ref } - in - thing_inside nest_env +nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) + = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds + , tcs_untch = (_outer_range, outer_tcs) + , tcs_count = count + , tcs_ic_depth = idepth + , 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! + + ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var + ; flat_cache_var <- TcM.newTcRef orig_flat_cache + -- One could be more conservative as well: + -- ; flat_cache_var <- TcM.newTcRef 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 + , tcs_ty_binds = ty_binds + , tcs_untch = inner_untch + , tcs_count = count + , tcs_ic_depth = idepth+1 + , tcs_context = ctxtUnderImplic ctxt + , tcs_flat_map = flat_cache_var } + ; thing_inside nest_env } recoverTcS :: TcS a -> TcS a -> TcS a recoverTcS (TcS recovery_code) (TcS thing_inside) @@ -581,20 +620,21 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic SimplRuleLhs = SimplCheck -ctxtUnderImplic ctxt = ctxt +ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") + <+> doubleQuotes (ftext n)) +ctxtUnderImplic ctxt = ctxt tryTcS :: TcS a -> TcS a --- Like runTcS, but from within the TcS monad +-- Like runTcS, but from within the TcS monad -- Ignore all the evidence generated, and do not affect caller's evidence! -tryTcS tcs +tryTcS tcs = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds - ; err_ref <- TcM.newTcRef emptyBag + ; flat_cache_var <- TcM.newTcRef emptyFlatCache ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var - , tcs_errors = err_ref } - ; unTcS tcs env1 }) + , tcs_ty_binds = ty_binds_var + , tcs_flat_map = flat_cache_var } + ; unTcS tcs env1 }) -- Update TcEvBinds -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -614,30 +654,56 @@ getUntouchables = TcS (return . tcs_untch) getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) -getTcSErrors :: TcS (IORef (Bag FrozenError)) -getTcSErrors = TcS (return . tcs_errors) - -getTcSErrorsBag :: TcS (Bag FrozenError) -getTcSErrorsBag = do { err_ref <- getTcSErrors - ; wrapTcS $ TcM.readTcRef err_ref } - -getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) +getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) +getFlatCacheMapVar :: TcS (IORef FlatCache) +getFlatCacheMapVar + = TcS (return . tcs_flat_map) + +lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor + -> TcS (Maybe (TcType,Coercion,CtFlavor)) +-- For givens, we lookup in given flat cache +lookupFlatCacheMap tc xis (Given {}) + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) } +-- For wanteds, we first lookup in givenFlatCache. +-- If we get nothing back then we lookup in wantedFlatCache. +lookupFlatCacheMap tc xis (Wanted {}) + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of + Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map) + other -> return other } +lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing + +updateFlatCacheMap :: TyCon -> [Xi] + -> TcType -> CtFlavor -> Coercion -> TcS () +updateFlatCacheMap _tc _xis _tv (Derived {}) _co + = return () -- Not caching deriveds +updateFlatCacheMap tc xis ty fl co + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; let new_cache_map + | isGivenOrSolved fl + = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + givenFlatCache cache_map } + | isWanted fl + = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + wantedFlatCache cache_map } + | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty + ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map } + getTcEvBindsBag :: TcS EvBindMap getTcEvBindsBag = do { EvBindsVar ev_ref _ <- getTcEvBinds ; wrapTcS $ TcM.readTcRef ev_ref } -setWantedCoBind :: CoVar -> Coercion -> TcS () -setWantedCoBind cv co - = setEvBind cv (EvCoercion co) - -- Was: wrapTcS $ TcM.writeWantedCoVar cv co -setDerivedCoBind :: CoVar -> Coercion -> TcS () -setDerivedCoBind cv co - = setEvBind cv (EvCoercion co) +setCoBind :: CoVar -> Coercion -> TcS () +setCoBind cv co = setEvBind cv (EvCoercion co) setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding @@ -663,12 +729,9 @@ setDictBind = setEvBind setEvBind :: EvVar -> EvTerm -> TcS () -- Internal setEvBind ev rhs - = do { tc_evbinds <- getTcEvBinds + = do { tc_evbinds <- getTcEvBinds ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) } -newTcEvBindsTcS :: TcS EvBindsVar -newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds) - warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS () warnTcS loc warn_if doc | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc @@ -680,25 +743,6 @@ getDefaultInfo ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt)) ; return (ctxt, tys, flags) } - - --- Recording errors in the TcS monad --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -addErrorTcS :: ErrorKind -> CtFlavor -> TcType -> TcType -> TcS () -addErrorTcS frknd fl ty1 ty2 - = do { err_ref <- getTcSErrors - ; wrapTcS $ do - { TcM.updTcRef err_ref $ \ errs -> - consBag (FrozenError frknd fl ty1 ty2) errs - - -- If there's an error in the *given* constraints, - -- stop right now, to avoid a cascade of errors - -- in the wanteds - ; when (isGiven fl) TcM.failM - - ; return () } } - -- Just get some environments needed for instance looking up and matching -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -727,7 +771,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -768,7 +812,7 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty newFlattenSkolemTyVar :: TcType -> TcS TcTyVar newFlattenSkolemTyVar ty = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique - ; let name = mkSysTvName uniq (fsLit "f") + ; let name = TcM.mkTcTyVarName uniq (fsLit "f") ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } ; traceTcS "New Flatten Skolem Born" $ (ppr tv <+> text "[:= " <+> ppr ty <+> text "]") @@ -800,7 +844,7 @@ newFlexiTcSTy knd = wrapTcS $ do { uniq <- TcM.newUnique ; ref <- TcM.newMutVar Flexi - ; let name = mkSysTvName uniq (fsLit "uf") + ; let name = TcM.mkTcTyVarName uniq (fsLit "uf") ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) } isFlexiTcsTv :: TyVar -> Bool @@ -814,7 +858,7 @@ newKindConstraint :: TcTyVar -> Kind -> TcS CoVar newKindConstraint tv knd = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd ; let ty_k = mkTyVarTy tv_k - ; co_var <- newWantedCoVar (mkTyVarTy tv) ty_k + ; co_var <- newCoVar (mkTyVarTy tv) ty_k ; return co_var } instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar @@ -829,27 +873,23 @@ instFlexiTcSHelper tvname tvkind -- Superclasses and recursive dictionaries -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar -newGivOrDerEvVar pty evtrm - = do { ev <- wrapTcS $ TcM.newEvVar pty - ; setEvBind ev evtrm - ; return ev } +newEvVar :: TcPredType -> TcS EvVar +newEvVar pty = wrapTcS $ TcM.newEvVar pty + +newDerivedId :: TcPredType -> TcS EvVar +newDerivedId pty = wrapTcS $ TcM.newEvVar pty -newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar +newGivenCoVar :: TcType -> TcType -> Coercion -> TcS EvVar -- Note we create immutable variables for given or derived, since we -- must bind them to TcEvBinds (because their evidence may involve -- superclasses). However we should be able to override existing -- 'derived' evidence, even in TcEvBinds -newGivOrDerCoVar ty1 ty2 co +newGivenCoVar ty1 ty2 co = do { cv <- newCoVar ty1 ty2 ; setEvBind cv (EvCoercion co) ; return cv } -newWantedCoVar :: TcType -> TcType -> TcS EvVar -newWantedCoVar ty1 ty2 = wrapTcS $ TcM.newWantedCoVar ty1 ty2 - - -newCoVar :: TcType -> TcType -> TcS EvVar +newCoVar :: TcType -> TcType -> TcS EvVar newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 newIPVar :: IPName Name -> TcType -> TcS EvVar @@ -861,74 +901,6 @@ newDictVar cl tys = wrapTcS $ TcM.newDict cl tys \begin{code} -isGoodRecEv :: EvVar -> EvVar -> TcS Bool --- In a call (isGoodRecEv ev wv), we are considering solving wv --- using some term that involves ev, such as: --- by setting wv = ev --- or wv = EvCast x |> ev --- etc. --- But that would be Very Bad if the evidence for 'ev' mentions 'wv', --- in an "unguarded" way. So isGoodRecEv looks at the evidence ev --- recursively through the evidence binds, to see if uses of 'wv' are guarded. --- --- Guarded means: more instance calls than superclass selections. We --- compute this by chasing the evidence, adding +1 for every instance --- call (constructor) and -1 for every superclass selection (destructor). --- --- See Note [Superclasses and recursive dictionaries] in TcInteract -isGoodRecEv ev_var wv - = do { tc_evbinds <- getTcEvBindsBag - ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var - ; return $ case mb of - Nothing -> True - Just min_guardedness -> min_guardedness > 0 - } - - where chase_ev_var :: EvBindMap -- Evidence binds - -> EvVar -- Target variable whose gravity we want to return - -> Int -- Current gravity - -> [EvVar] -- Visited nodes - -> EvVar -- Current node - -> TcS (Maybe Int) - chase_ev_var assocs trg curr_grav visited orig - | trg == orig = return $ Just curr_grav - | orig `elem` visited = return $ Nothing - | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig - = chase_ev assocs trg curr_grav (orig:visited) ev_trm - - | otherwise = return Nothing - - chase_ev assocs trg curr_grav visited (EvId v) - = chase_ev_var assocs trg curr_grav visited v - chase_ev assocs trg curr_grav visited (EvSuperClass d_id _) - = chase_ev_var assocs trg (curr_grav-1) visited d_id - chase_ev assocs trg curr_grav visited (EvCast v co) - = do { m1 <- chase_ev_var assocs trg curr_grav visited v - ; m2 <- chase_co assocs trg curr_grav visited co - ; return (comb_chase_res Nothing [m1,m2]) } - - chase_ev assocs trg curr_grav visited (EvCoercion co) - = chase_co assocs trg curr_grav visited co - chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) - = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars - ; return (comb_chase_res Nothing chase_results) } - - chase_co assocs trg curr_grav visited co - = -- Look for all the coercion variables in the coercion - -- chase them, and combine the results. This is OK since the - -- coercion will not contain any superclass terms -- anything - -- that involves dictionaries will be bound in assocs. - let co_vars = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) [] - (tyVarsOfType co) - in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars - ; return (comb_chase_res Nothing chase_results) } - - comb_chase_res f [] = f - comb_chase_res f (Nothing:rest) = comb_chase_res f rest - comb_chase_res Nothing (Just n:rest) = comb_chase_res (Just n) rest - comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest - - -- Matching and looking up classes and family instances -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -943,7 +915,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs - ; case lookupInstEnv instEnvs clas tys of { + ; case lookupInstEnv instEnvs clas tys of { ([], unifs) -- Nothing matches -> do { traceTcS "matchClass not matching" (vcat [ text "dict" <+> ppr pred, @@ -955,10 +927,9 @@ matchClass clas tys ; traceTcS "matchClass success" (vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ]) + <+> ppr (idType dfun_id) ]) -- Record that this dfun is needed - ; record_dfun_usage dfun_id - ; return $ MatchInstSingle (dfun_id, inst_tys) + ; return $ MatchInstSingle (dfun_id, inst_tys) } ; (matches, unifs) -- More than one matches -> do { traceTcS "matchClass multiple matches, deferring choice" @@ -969,26 +940,8 @@ matchClass clas tys } } } - where record_dfun_usage :: Id -> TcS () - record_dfun_usage dfun_id - = do { hsc_env <- getTopEnv - ; let dfun_name = idName dfun_id - dfun_mod = ASSERT( isExternalName dfun_name ) - nameModule dfun_name - ; if isInternalName dfun_name || -- Internal name => defined in this module - modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) - then return () -- internal, or in another package - else do updInstUses dfun_id - } - - updInstUses :: Id -> TcS () - updInstUses dfun_id - = do { tcg_env <- getGblEnv - ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) - (`addOneToNameSet` idName dfun_id) - } - -matchFam :: TyCon + +matchFam :: TyCon -> [Type] -> TcS (MatchInstResult (TyCon, [Type])) matchFam tycon args @@ -999,47 +952,4 @@ matchFam tycon args -- DV: We never return MatchInstMany, since tcLookupFamInst never returns -- multiple matches. Check. } - - --- Functional dependencies, instantiation of equations -------------------------------------------------------- - -mkWantedFunDepEqns :: WantedLoc - -> [(Equation, (PredType, SDoc), (PredType, SDoc))] - -> TcS [WantedEvVar] -mkWantedFunDepEqns _ [] = return [] -mkWantedFunDepEqns loc eqns - = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns)) - ; wevvars <- mapM to_work_item eqns - ; return $ concat wevvars } - where - to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar] - to_work_item ((qtvs, pairs), d1, d2) - = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') - loc' = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - ; mapM (do_one subst loc') pairs } - - do_one subst loc' (ty1, ty2) - = do { let sty1 = substTy subst ty1 - sty2 = substTy subst ty2 - ; ev <- newWantedCoVar sty1 sty2 - ; return (WantedEvVar ev loc') } - -pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc -pprEquationDoc (eqn, (p1, _), (p2, _)) - = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)] - -mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv - -> TcM (TidyEnv, SDoc) -mkEqnMsg (pred1,from1) (pred2,from2) tidy_env - = do { pred1' <- TcM.zonkTcPredType pred1 - ; pred2' <- TcM.zonkTcPredType pred2 - ; let { pred1'' = tidyPred tidy_env pred1' - ; pred2'' = tidyPred tidy_env pred2' } - ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), - nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), - nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])] - ; return (tidy_env, msg) } \end{code}