[Git][ghc/ghc][wip/T21909] Change `qci_pend_sc` from `Bool` to `ExpansionFuel`
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Feb 7 23:50:22 UTC 2023
Apoorv Ingle pushed to branch wip/T21909 at Glasgow Haskell Compiler / GHC
Commits:
2d07c9b9 by Apoorv Ingle at 2023-02-07T17:50:04-06:00
Change `qci_pend_sc` from `Bool` to `ExpansionFuel`
- - - - -
3 changed files:
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -494,18 +494,18 @@ makeSuperClasses :: [Ct] -> TcS [Ct]
-- class C [a] => D a
-- makeSuperClasses (C x) will return (D x, C [x])
--
--- NB: the incoming constraints have had their cc_pend_sc flag already
--- flipped to False, by isPendingScDict, so we are /obliged/ to at
--- least produce the immediate superclasses
+-- NB: the incoming constraints will be expanded only if the fuel is striclty > 0
+-- expansion will consume a unit of fuel
makeSuperClasses cts = concatMapM go cts
where
go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys, cc_pend_sc = fuel })
= assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
mkStrictSuperClasses (consumeFuel fuel) ev [] [] cls tys
- go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+ go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
= assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
-- class pred heads
- mkStrictSuperClasses defaultFuelQC ev tvs theta cls tys
+ assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
go ct = pprPanic "makeSuperClasses" (ppr ct)
@@ -653,14 +653,14 @@ mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
-- and expand its superclasses
mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
- ; return [this_ct] } -- cc_pend_sc of this_ct = True
+ ; return [this_ct] } -- cc_pend_sc of this_ct = fuel
| otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
, ppr (isCTupleClass cls)
, ppr rec_clss
])
; sc_cts <- mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
; return (this_ct : sc_cts) }
- -- cc_pend_sc of this_ct = False
+ -- cc_pend_sc of this_ct = doNotExpand
where
cls_nm = className cls
loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
@@ -678,7 +678,7 @@ mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| otherwise
= CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
, qci_ev = ev
- , qci_pend_sc = loop_found })
+ , qci_pend_sc = this_cc_pend })
{- Note [Equality superclasses in quantified constraints]
@@ -835,17 +835,19 @@ canForAllNC ev tvs theta pred
, Just (cls, tys) <- cls_pred_tys_maybe
= do { sc_cts <- mkStrictSuperClasses defaultFuelGivens ev tvs theta cls tys
; emitWork sc_cts
- ; canForAll ev False }
+ ; canForAll ev doNotExpand }
| otherwise
- = canForAll ev (isJust cls_pred_tys_maybe)
+ = canForAll ev fuel
where
+ fuel | isJust cls_pred_tys_maybe = defaultFuelQC
+ | otherwise = doNotExpand
cls_pred_tys_maybe = getClassPredTys_maybe pred
-canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+canForAll :: CtEvidence -> ExpansionFuel -> TcS (StopOrContinue Ct)
-- We have a constraint (forall as. blah => C tys)
-canForAll ev pend_sc
+canForAll ev fuel
= do { -- First rewrite it to apply the current substitution
let pred = ctEvPred ev
; (redn, rewriters) <- rewrite ev pred
@@ -855,14 +857,14 @@ canForAll ev pend_sc
-- (It takes a lot less code to rewrite before decomposing.)
; case classifyPredType (ctEvPred new_ev) of
ForAllPred tvs theta pred
- -> solveForAll new_ev tvs theta pred pend_sc
+ -> solveForAll new_ev tvs theta pred fuel
_ -> pprPanic "canForAll" (ppr new_ev)
} }
-solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool
+solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel
-> TcS (StopOrContinue Ct)
solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
- tvs theta pred _pend_sc
+ tvs theta pred _fuel
= -- See Note [Solving a Wanted forall-constraint]
setLclEnv (ctLocEnv loc) $
-- This setLclEnv is important: the emitImplicationTcS uses that
@@ -908,12 +910,12 @@ solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_lo
_ -> pSizeType pred
-- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc
+solveForAll ev@(CtGiven {}) tvs _theta pred fuel
= do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
where
qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = pred, qci_pend_sc = pend_sc }
+ , qci_pred = pred, qci_pend_sc = fuel }
{- Note [Solving a Wanted forall-constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -548,7 +548,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
-- exhaust the fuel for this constraint before adding it as
- -- we don't want to expand these constraints again
+ -- we don't want to expand these constraints again
= addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
@@ -556,7 +556,10 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
get_pending_inst cts qci@(QCI { qci_ev = ev })
| Just qci' <- pendingScInst_maybe qci
, belongs_to_this_level ev
- = (CQuantCan qci' : cts, qci')
+ = (CQuantCan qci : cts, qci')
+ -- qci' have their fuel exhausted
+ -- we don't want to expand these constraints again
+ -- qci is expanded
| otherwise
= (cts, qci)
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -287,8 +287,9 @@ data QCInst -- A much simplified version of ClsInst
-- Always Given
, qci_tvs :: [TcTyVar] -- The tvs
, qci_pred :: TcPredType -- The ty
- , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan
- -- Invariant: True => qci_pred is a ClassPred
+ , qci_pend_sc :: ExpansionFuel -- Same as cc_pend_sc flag in CDictCan
+ -- Invariants: qci_pend_sc > 0 => qci_pred is a ClassPred
+ -- the superclasses are unexplored
}
instance Outputable QCInst where
@@ -690,8 +691,8 @@ instance Outputable Ct where
| psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CDictCan"
CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason
- CQuantCan (QCI { qci_pend_sc = pend_sc })
- | pend_sc -> text "CQuantCan(psc)"
+ CQuantCan (QCI { qci_pend_sc = psc })
+ | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CQuantCan"
-----------------------------------
@@ -922,9 +923,9 @@ pendingScDict_maybe _ = Nothing
pendingScInst_maybe :: QCInst -> Maybe QCInst
-- Same as isPendingScDict, but for QCInsts
-pendingScInst_maybe qci@(QCI { qci_pend_sc = True })
- = Just (qci { qci_pend_sc = False })
-pendingScInst_maybe _ = Nothing
+pendingScInst_maybe qci@(QCI { qci_pend_sc = n })
+ | n > 0 = Just (qci { qci_pend_sc = doNotExpand })
+ | otherwise = Nothing
superClassesMightHelp :: WantedConstraints -> Bool
-- ^ True if taking superclasses of givens, or of wanteds (to perhaps
@@ -943,6 +944,7 @@ superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })
is_ip _ = False
getPendingWantedScs :: Cts -> ([Ct], Cts)
+-- [Ct] has original fuel while Cts has fuel exhausted
getPendingWantedScs simples
= mapAccumBagL get [] simples
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d07c9b94c542671e0a19c86d0d3a65e64cbeaf4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d07c9b94c542671e0a19c86d0d3a65e64cbeaf4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230207/88a7ad7e/attachment-0001.html>
More information about the ghc-commits
mailing list