Commit 0430775a authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor, plus fix Trac #4418

We weren't doing fundeps for derived superclasses
parent 7f14b79f
......@@ -287,50 +287,27 @@ Note [Basic plan]
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
......@@ -358,9 +335,6 @@ instance Outputable StageResult where
, 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
......@@ -429,8 +403,7 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni
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
......@@ -450,12 +423,13 @@ solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws
| 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
......@@ -720,7 +694,7 @@ solveWithIdentity inerts cv gw tv xi
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)
......@@ -959,11 +933,10 @@ doInteractWithInert fdimprs
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))
......@@ -1038,7 +1011,7 @@ doInteractWithInert _fdimprs
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
......@@ -1077,10 +1050,10 @@ doInteractWithInert _fdimprs
, 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)
......@@ -1090,19 +1063,19 @@ doInteractWithInert _fdimprs
-- 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
......@@ -1169,7 +1142,7 @@ rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2)
, 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
......@@ -1204,7 +1177,7 @@ rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2)
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)
......@@ -1664,20 +1637,60 @@ allowedTopReaction _ _ = True
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
......@@ -1690,55 +1703,10 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc
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
......@@ -1766,8 +1734,7 @@ 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!"
}
......@@ -1775,6 +1742,19 @@ doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
-- 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]
......@@ -2043,26 +2023,26 @@ newGivenSCWork ev loc cls xis
| 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment