X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=cbf9330375ab2273377c29e21901b2d5a2fb248d;hp=ad24eb76d8a82158ac5bdb370067bb34de1b1dca;hb=f67b457bb0271dd1590efcaa912fc441388531d9;hpb=50d0293555691012f96259de7f8682b94db58517 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index ad24eb7..cbf9330 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -8,6 +8,10 @@ module TcSMonad ( isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, isCFrozenErr, + WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList, + workListFromEq, workListFromNonEq, + workListFromEqs, workListFromNonEqs, foldrWorkListM, + CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, deCanonicalise, mkFrozenError, @@ -26,13 +30,12 @@ module TcSMonad ( SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, -- Creation of evidence variables - newEvVar, newCoVar, newWantedCoVar, newGivenCoVar, + newEvVar, newCoVar, newGivenCoVar, newDerivedId, newIPVar, newDictVar, newKindConstraint, -- Setting evidence variables - setWantedCoBind, - setIPBind, setDictBind, setEvBind, + setCoBind, setIPBind, setDictBind, setEvBind, setWantedTyBind, @@ -100,7 +103,9 @@ import HsBinds -- for TcEvBinds stuff import Id import TcRnTypes - +#ifdef DEBUG +import Control.Monad( when ) +#endif import Data.IORef \end{code} @@ -258,8 +263,58 @@ 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 @@ -290,12 +345,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 {}) = False -- DV: changing the semantics -canSolve (Derived {}) (Derived {}) = True -- DV: changing the semantics of derived +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 @@ -366,17 +423,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet) \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 - deriving Eq + = 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 @@ -386,14 +442,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 } @@ -471,7 +527,8 @@ runTcS context untouch tcs #ifdef DEBUG ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) + ; when (count > 0) $ + TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count <+> ppr context) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -508,8 +565,9 @@ 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 @@ -548,10 +606,8 @@ 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 +setCoBind :: CoVar -> Coercion -> TcS () +setCoBind cv co = setEvBind cv (EvCoercion co) setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding @@ -706,7 +762,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 @@ -737,9 +793,6 @@ newGivenCoVar ty1 ty2 co ; 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 ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2