Superclass decomposition belongs in (4), see note [Superclasses]
\begin{code}
-
type AtomicInert = CanonicalCt -- constraint pulled from InertSet
type WorkItem = CanonicalCt -- constraint pulled from WorkList
-- A mixture of Given, Wanted, and Derived constraints.
-- We split between equalities and the rest to process equalities first.
-data WorkList = WL { wl_eqs :: CanonicalCts -- Equalities (CTyEqCan, CFunEqCan)
- , wl_other :: CanonicalCts -- Other
- }
-type SWorkList = WorkList -- A worklist of solved
+type WorkList = CanonicalCts
+type SWorkList = WorkList -- A worklist of solved
unionWorkLists :: WorkList -> WorkList -> WorkList
-unionWorkLists wl1 wl2
- = WL { wl_eqs = andCCan (wl_eqs wl1) (wl_eqs wl2)
- , wl_other = andCCan (wl_other wl1) (wl_other wl2) }
-
-foldWorkListEqCtsM :: Monad m => (a -> WorkItem -> m a) -> a -> WorkList -> m a
--- Fold over the equalities of a worklist
-foldWorkListEqCtsM f r wl = Bag.foldlBagM f r (wl_eqs wl)
-
-foldWorkListOtherCtsM :: Monad m => (a -> WorkItem -> m a) -> a -> WorkList -> m a
--- Fold over non-equality constraints of a worklist
-foldWorkListOtherCtsM f r wl = Bag.foldlBagM f r (wl_other wl)
+unionWorkLists = andCCan
isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList wl = isEmptyCCan (wl_eqs wl) && isEmptyCCan (wl_other wl)
+isEmptyWorkList = isEmptyCCan
emptyWorkList :: WorkList
-emptyWorkList = WL { wl_eqs = emptyCCan, wl_other = emptyCCan }
-
-workListFromCCans :: CanonicalCts -> WorkList
--- Generic, no precondition
-workListFromCCans cts = WL eqs others
- where (eqs, others) = Bag.partitionBag isTyEqCCan cts
+emptyWorkList = emptyCCan
workListFromCCan :: CanonicalCt -> WorkList
-workListFromCCan ct | isTyEqCCan ct = WL (singleCCan ct) emptyCCan
- | otherwise = WL emptyCCan (singleCCan ct)
--- TODO:
--- At the call sites of workListFromCCan(s), sometimes we know whether the new work
--- involves equalities or not. It's probably a good idea to add specialized calls for
--- those, to avoid asking whether 'isTyEqCCan' all the time.
-
+workListFromCCan = singleCCan
+------------------------
data StopOrContinue
= Stop -- Work item is consumed
| ContinueWith WorkItem -- Not consumed
, ptext (sLit "new work =") <+> ppr work <> comma
, ptext (sLit "stop =") <+> ppr stop])
-instance Outputable WorkList where
- ppr (WL eqcts othercts) = vcat [ppr eqcts, ppr othercts]
-
type SimplifierStage = WorkItem -> InertSet -> TcS StageResult
-- Combine a sequence of simplifier 'stages' to create a pipeline
solveInteract :: InertSet -> CanonicalCts -> TcS InertSet
solveInteract inert ws
= do { dyn_flags <- getDynFlags
- ; let worklist = workListFromCCans ws
- ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert worklist
+ ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert ws
}
solveOne :: InertSet -> WorkItem -> TcS InertSet
solveOne inerts workItem
| otherwise
= do { traceTcS "solveInteractWithDepth" $
- vcat [ text "Current depth =" <+> ppr n
- , text "Max depth =" <+> ppr max_depth
- ]
- ; is_from_eqs <- foldWorkListEqCtsM (solveOneWithDepth ctxt) inert ws
- ; foldWorkListOtherCtsM (solveOneWithDepth ctxt) is_from_eqs ws
- }
+ vcat [ text "Current depth =" <+> ppr n
+ , text "Max depth =" <+> ppr max_depth ]
+
+ -- Solve equalities first
+ ; let (eqs, non_eqs) = Bag.partitionBag isTyEqCCan ws
+ ; is_from_eqs <- Bag.foldlBagM (solveOneWithDepth ctxt) inert eqs
+ ; Bag.foldlBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs }
------------------
-- Fully interact the given work item with an inert set, and return a
Derived {} -> setDerivedCoBind cv co
_ -> pprPanic "Can't spontaneously solve *given*" empty
-- See Note [Avoid double unifications]
- ; return $ Just (workListFromCCans cts) }
+ ; return $ Just cts }
occurCheck :: VarEnv (TcTyVar, TcType) -> InertSet
-> TcTyVar -> TcType -> Maybe (TcType,CoercionI)
eqn_pred_locs = improveFromAnother work_item_pred_loc inert_pred_loc
; wevvars <- mkWantedFunDepEqns loc eqn_pred_locs
- ; fd_cts <- canWanteds wevvars
- ; let fd_work = workListFromCCans fd_cts
+ ; fd_work <- canWanteds wevvars
-- See Note [Generating extra equalities]
; traceTcS "Checking if improvements existed." (ppr fdimprs)
- ; if isEmptyCCan fd_cts || haveBeenImproved fdimprs pty1 pty2 then
+ ; if isEmptyWorkList fd_work || haveBeenImproved fdimprs pty1 pty2 then
-- Must keep going
mkIRContinue workItem KeepInert fd_work
else do { traceTcS "Recording improvement and throwing item back in worklist." (ppr (pty1,pty2))
do { co_var <- newWantedCoVar ty1 ty2
; let flav = Wanted (combineCtLoc ifl wfl)
; cans <- mkCanonical flav co_var
- ; mkIRContinue workItem KeepInert (workListFromCCans cans) }
+ ; mkIRContinue workItem KeepInert cans }
-- Inert: equality, work item: function equality
, cc_tyargs = args2, cc_rhs = xi2 })
| fl1 `canSolve` fl2 && lhss_match
= do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
- ; mkIRStop KeepInert (workListFromCCans cans) }
+ ; mkIRStop KeepInert cans }
| fl2 `canSolve` fl1 && lhss_match
= do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
- ; mkIRContinue workItem DropInert (workListFromCCans cans) }
+ ; mkIRContinue workItem DropInert cans }
where
lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2)
-- Check for matching LHS
| fl1 `canSolve` fl2 && tv1 == tv2
= do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
- ; mkIRStop KeepInert (workListFromCCans cans) }
+ ; mkIRStop KeepInert cans }
| fl2 `canSolve` fl1 && tv1 == tv2
= do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
- ; mkIRContinue workItem DropInert (workListFromCCans cans) }
+ ; mkIRContinue workItem DropInert cans }
-- Check for rewriting RHS
| fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfType xi2
= do { rewritten_eq <- rewriteEqRHS (cv1,tv1,xi1) (cv2,fl2,tv2,xi2)
- ; mkIRStop KeepInert (workListFromCCans rewritten_eq) }
+ ; mkIRStop KeepInert rewritten_eq }
| fl2 `canRewrite` fl1 && tv2 `elemVarSet` tyVarsOfType xi1
= do { rewritten_eq <- rewriteEqRHS (cv2,tv2,xi2) (cv1,fl1,tv1,xi1)
- ; mkIRContinue workItem DropInert (workListFromCCans rewritten_eq) }
+ ; mkIRContinue workItem DropInert rewritten_eq }
-- Finally, if workitem is a Flatten Equivalence Class constraint and the
-- inert is a wanted constraint, even when the workitem cannot rewrite the
, cc_rhs = xi2 }) }
-rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS CanonicalCts
+rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS WorkList
-- Use the first equality to rewrite the second, flavors already checked.
-- E.g. c1 : tv1 ~ xi1 c2 : tv2 ~ xi2
-- rewrites c2 to give
co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
-rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS CanonicalCts
+rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList
-- Used to ineract two equalities of the following form:
-- First Equality: co1: (XXX ~ xi1)
-- Second Equality: cv2: (XXX ~ xi2)
doTopReact :: WorkItem -> TcS TopInteractResult
-- The work item does not react with the inert set,
-- so try interaction with top-level instances
+
+-- Given dictionary; just add superclasses
+-- See Note [Given constraint that matches an instance declaration]
+doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Given loc
+ , cc_class = cls, cc_tyargs = xis })
+ = do { sc_work <- newGivenSCWork dv loc cls xis
+ ; return $ SomeTopInt sc_work (ContinueWith workItem) }
+
+-- Derived dictionary
+-- Do not add any further derived superclasses; their
+-- full transitive closure has already been added.
+-- But do look for functional dependencies
+doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Derived loc _
+ , cc_class = cls, cc_tyargs = xis })
+ = do { fd_work <- findClassFunDeps dv cls xis loc
+ ; if isEmptyWorkList fd_work then
+ return NoTopInt
+ else return $ SomeTopInt { tir_new_work = fd_work
+ , tir_new_inert = ContinueWith workItem } }
+
doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc
, cc_class = cls, cc_tyargs = xis })
= do { -- See Note [MATCHING-SYNONYMS]
; lkp_inst_res <- matchClassInst cls xis loc
; case lkp_inst_res of
- NoInstance -> do { traceTcS "doTopReact/ no class instance for" (ppr dv)
- ; funDepReact }
+ NoInstance ->
+ do { traceTcS "doTopReact/ no class instance for" (ppr dv)
+ ; fd_work <- findClassFunDeps dv cls xis loc
+ ; if isEmptyWorkList fd_work then
+ do { sc_work <- newDerivedSCWork dv loc cls xis
+ -- See Note [Adding Derived Superclasses]
+ -- NB: workItem is inert, but it isn't solved
+ -- keep it as inert, although it's not solved
+ -- because we have now reacted all its
+ -- top-level fundep-induced equalities!
+ ; return $ SomeTopInt
+ { tir_new_work = fd_work `unionWorkLists` sc_work
+ , tir_new_inert = ContinueWith workItem } }
+
+ else -- More fundep work produced, don't do any superclass stuff,
+ -- just thow him back in the worklist, which will prioritize
+ -- the solution of fd equalities
+ return $ SomeTopInt
+ { tir_new_work = fd_work `unionWorkLists`
+ workListFromCCan workItem
+ , tir_new_inert = Stop } }
+
GenInst wtvs ev_term -> -- Solved
-- No need to do fundeps stuff here; the instance
-- matches already so we won't get any more info
-- from functional dependencies
do { traceTcS "doTopReact/ found class instance for" (ppr dv)
; setDictBind dv ev_term
- ; workList <- canWanteds wtvs
+ ; inst_work <- canWanteds wtvs
; if null wtvs
-- Solved in one step and no new wanted work produced.
-- i.e we directly matched a top-level instance
else do { let solved = makeSolvedByInst workItem
; sc_work <- newDerivedSCWork dv loc cls xis
-- See Note [Adding Derived Superclasses]
- ; let inst_work = workListFromCCans workList
; return $ SomeTopInt
{ tir_new_work = inst_work `unionWorkLists` sc_work
, tir_new_inert = ContinueWith solved } }
- }
- }
- where
- -- Try for a fundep reaction beween the wanted item
- -- and a top-level instance declaration
- funDepReact
- = do { instEnvs <- getInstEnvs
- ; let eqn_pred_locs = improveFromInstEnv (classInstances instEnvs)
- (ClassP cls xis, ppr dv)
- ; wevvars <- mkWantedFunDepEqns loc eqn_pred_locs
- -- NB: fundeps generate some wanted equalities, but
- -- we don't use their evidence for anything
- ; fd_cts <- canWanteds wevvars
- ; let fd_work = workListFromCCans fd_cts
-
- ; if isEmptyCCan fd_cts then
- do { sc_work <- newDerivedSCWork dv loc cls xis
- -- See Note [Adding Derived Superclasses]
- ; return $ SomeTopInt { tir_new_work = fd_work `unionWorkLists` sc_work
- , tir_new_inert = ContinueWith workItem }
- }
- else -- More fundep work produced, don't do any superlcass stuff, just
- -- thow him back in the worklist prioritizing the solution of fd equalities
- return $
- SomeTopInt { tir_new_work = fd_work `unionWorkLists` workListFromCCan workItem
- , tir_new_inert = Stop }
-
- -- NB: workItem is inert, but it isn't solved
- -- keep it as inert, although it's not solved because we
- -- have now reacted all its top-level fundep-induced equalities!
-
- -- See Note [FunDep Reactions]
- }
-
--- Derived, do not add any further derived superclasses; their full transitive
--- closure has already been added.
-doTopReact (CDictCan { cc_flavor = fl })
- | isDerived fl
- = return NoTopInt
-
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Given loc
- , cc_class = cls, cc_tyargs = xis })
- = do { sc_work <- newGivenSCWork dv loc cls xis
- ; return $ SomeTopInt sc_work (ContinueWith workItem) }
- -- See Note [Given constraint that matches an instance declaration]
+ } }
-- Type functions
doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe
; can_cts <- mkCanonical fl cv'
- ; let workList = workListFromCCans can_cts
- ; return $ SomeTopInt workList Stop }
+ ; return $ SomeTopInt can_cts Stop }
_
-> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
}
-- Any other work item does not react with any top-level equations
doTopReact _workItem = return NoTopInt
+
+----------------------
+findClassFunDeps :: EvVar -> Class -> [Xi] -> WantedLoc -> TcS WorkList
+-- Look for a fundep reaction beween the wanted item
+-- and a top-level instance declaration
+findClassFunDeps dv cls xis loc
+ = do { instEnvs <- getInstEnvs
+ ; let eqn_pred_locs = improveFromInstEnv (classInstances instEnvs)
+ (ClassP cls xis, ppr dv)
+ ; wevvars <- mkWantedFunDepEqns loc eqn_pred_locs
+ -- NB: fundeps generate some wanted equalities, but
+ -- we don't use their evidence for anything
+ ; canWanteds wevvars }
\end{code}
Note [Adding Derived Superclasses]
| NoScSkol <- ctLocOrigin loc -- Very important!
= return emptyWorkList
| otherwise
- = newImmSCWorkFromFlavored ev (Given loc) cls xis >>= return . workListFromCCans
+ = newImmSCWorkFromFlavored ev (Given loc) cls xis >>= return
newDerivedSCWork :: EvVar -> WantedLoc -> Class -> [Xi] -> TcS WorkList
newDerivedSCWork ev loc cls xis
= do { ims <- newImmSCWorkFromFlavored ev flavor cls xis
- ; final_cts <- rec_sc_work ims
- ; return $ workListFromCCans final_cts }
- where rec_sc_work :: CanonicalCts -> TcS CanonicalCts
- rec_sc_work cts
- = do { bg <- mapBagM (\c -> do { ims <- imm_sc_work c
- ; recs_ims <- rec_sc_work ims
- ; return $ consBag c recs_ims }) cts
- ; return $ concatBag bg }
- imm_sc_work (CDictCan { cc_id = dv, cc_flavor = fl, cc_class = cls, cc_tyargs = xis })
- = newImmSCWorkFromFlavored dv fl cls xis
- imm_sc_work _ct = return emptyCCan
-
- flavor = Derived loc DerSC
-
-newImmSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts
+ ; rec_sc_work ims }
+ where
+ rec_sc_work :: CanonicalCts -> TcS CanonicalCts
+ rec_sc_work cts
+ = do { bg <- mapBagM (\c -> do { ims <- imm_sc_work c
+ ; recs_ims <- rec_sc_work ims
+ ; return $ consBag c recs_ims }) cts
+ ; return $ concatBag bg }
+ imm_sc_work (CDictCan { cc_id = dv, cc_flavor = fl, cc_class = cls, cc_tyargs = xis })
+ = newImmSCWorkFromFlavored dv fl cls xis
+ imm_sc_work _ct = return emptyCCan
+
+ flavor = Derived loc DerSC
+
+newImmSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList
-- Returns immediate superclasses
newImmSCWorkFromFlavored ev flavor cls xis
= do { let (tyvars, sc_theta, _, _) = classBigSig cls
projects / ghc-hetmet.git / commitdiff