[Git][ghc/ghc][wip/T24359] Moving towards the new plan [skip ci]
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jan 23 11:48:01 UTC 2025
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
32e0aa05 by Simon Peyton Jones at 2025-01-23T11:47:35+00:00
Moving towards the new plan [skip ci]
... as discussed between Simon and Sam
- - - - -
6 changed files:
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -952,22 +952,28 @@ tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
<- tcRuleBndrs skol_info rule_bndrs $
tcInferRho spec_e
- -- Simplify the constraints
- ; ev_binds_var <- newTcEvBinds
- ; wanted <- setTcLevel rhs_tclvl $
- runTcSWithEvBinds ev_binds_var $
- solveWanteds wanted
+ -- Simplify the constraints enough to perform unificaitons
+ ; wanted_clone <- cloneWC wanted
+ ; _ <- setTcLevel rhs_tclvl $
+ runTcS $
+ solveWanteds wanted_clone
+ ; wanted <- liftZonkM $ zonkWC wanted
-- Quantify over the the constraints
- ; qevs <- mapM newEvVar $
- ctsPreds $
- approximateWC False wanted
+ ; (quant_cts, residual_wanted) <- getRuleQuantCts wanted
+ ; let qevs = map ctEvId (bagToList quant_cts)
+ -- Wrap the call in bindings for any other constraints
+ ; ev_binds_var1 <- newTcEvBinds
; let tv_bndrs = filter isTyVar rule_bndrs'
- ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var
+ ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var1
emptyVarSet tv_bndrs qevs
- wanted
+ residual_wanted
+ ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var1)) spec_e'
+ -- The free vars of `lhs_call` are `qevs`, plus the explicit `rule_bndrs`
+ -- and any free tyvars of the above
+ ;
; traceTc "tcSpecPrag:SpecSigE" $
vcat [ text "nm:" <+> ppr nm
, text "rule_bndrs':" <+> ppr rule_bndrs'
@@ -975,7 +981,6 @@ tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
, text "spec_e:" <+> ppr spec_e'
, text "inl:" <+> ppr inl ]
- ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) spec_e'
; return [SpecPragE { spe_fn_nm = nm
, spe_fn_id = poly_id
, spe_bndrs = qevs ++ rule_bndrs' -- Dependency order
@@ -1483,7 +1488,8 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
-- Note [The SimplifyRule Plan] step 3
- ; (quant_evs, residual_lhs_wanted) <-getRuleQuantCts lhs_wanted
+ ; (quant_cts, residual_lhs_wanted) <-getRuleQuantCts lhs_wanted
+ ; let qant_evs = map ctEvId (bagToTolist quant_cts)
; traceTc "simplifyRule" $
vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
@@ -1496,7 +1502,7 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
; return (quant_evs, residual_lhs_wanted, dont_default) }
-getRuleQuantCts :: WantedConstraints -> TcM ([EvVar], WantedConstraints)
+getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints)
-- Extract all the constraints that we can quantify over,
-- also returning the depleted WantedConstraints
--
@@ -1513,11 +1519,8 @@ getRuleQuantCts :: WantedConstraints -> TcM ([EvVar], WantedConstraints)
-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
getRuleQuantCts wc
- = do { quant_evs <- mapM mk_one (bagToList quant_cts)
- ; return (quant_evs, residual_wc) }
+ = float_wc emptyVarSet wc
where
- (quant_cts, residual_wc) = float_wc emptyVarSet wc
-
float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
= ( simple_yes `andCts` implic_yes
=====================================
compiler/GHC/Tc/Solver/Default.hs
=====================================
@@ -973,7 +973,7 @@ tryDefaultGroup wanteds (Proposal assignments)
errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()
errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs
- = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems
+ = failWithTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems
where
proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments
tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -885,7 +885,8 @@ try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls
| otherwise -- Wanted, but not cached
= do { dflags <- getDynFlags
- ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+ ; mode <- getModeTcS
+ ; lkup_res <- matchClassInst dflags mode inerts cls xis dict_loc
; case lkup_res of
OneInst { cir_what = what }
-> do { insertSafeOverlapFailureTcS what work_item
@@ -940,10 +941,14 @@ checkInstanceOK loc what pred
| otherwise
= loc
-matchClassInst :: DynFlags -> InertSet
+matchClassInst :: DynFlags -> TcSMode
+ -> InertSet
-> Class -> [Type]
-> CtLoc -> TcS ClsInstResult
-matchClassInst dflags inerts clas tys loc
+matchClassInst dflags mode inerts clas tys loc
+ | TcSSpecPrag <- mode -- See Note [Handling new-form SPECIALISE pragmas]
+ = return NoInstance -- in GHc.Tc.Gen.Sig
+
-- First check whether there is an in-scope Given that could
-- match this constraint. In that case, do not use any instance
-- whether top level, or local quantified constraints.
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -2018,8 +2018,9 @@ finishCanWithIrred :: CtIrredReason -> CtEvidence
-> TcS (StopOrContinue (Either IrredCt a))
finishCanWithIrred reason ev
= do { -- Abort fast if we have any insoluble Wanted constraints,
- -- and the TcS abort-if-insoluble flag is on.
- when (isInsolubleReason reason) tryEarlyAbortTcS
+ -- and the TcSMode is TcsHoleFits
+ mode <- getModeTcS
+ ; when (mode == TcSHoleFits && isInsolubleReason reason) failTcS
; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } }
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -14,9 +14,10 @@
module GHC.Tc.Solver.Monad (
-- The TcS monad
- TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
- failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
- runTcSEqualities,
+ TcS, TcSMode(..),
+ runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
+ runTcSEqualities, runTcSSpecPrag,
+ failTcS, failWithTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
nestTcS, nestImplicTcS, setEvBindsTcS,
emitImplicationTcS, emitTvImplicationTcS,
emitFunDepWanteds,
@@ -37,7 +38,7 @@ module GHC.Tc.Solver.Monad (
stopWithStage, nopStage,
-- Tracing etc
- panicTcS, traceTcS, tryEarlyAbortTcS,
+ panicTcS, traceTcS, getModeTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
resetUnificationFlag, setUnificationFlag,
@@ -856,6 +857,7 @@ data TcSMode
| TcSSpecPrag -- Don't use instance declarations or upack forall constraints
-- when simplifying a SPECIALISE pragma
+ deriving( Eq )
instance Outputable TcSMode where
ppr TcSVanilla = text "TcSVanilla"
@@ -922,9 +924,11 @@ wrapWarnTcS :: TcM a -> TcS a
wrapWarnTcS = wrapTcS
panicTcS :: SDoc -> TcS a
-failTcS :: TcRnMessage -> TcS a
+failTcS :: TcS a
+failWithTcS :: TcRnMessage -> TcS a
warnTcS, addErrTcS :: TcRnMessage -> TcS ()
-failTcS = wrapTcS . TcM.failWith
+failTcS = wrapTcS TcM.failM
+failWithTcS = wrapTcS . TcM.failWith
warnTcS msg = wrapTcS (TcM.addDiagnostic msg)
addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc
@@ -986,11 +990,13 @@ csTraceTcM mk_doc
msg }) }
{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities]
-runTcS :: TcS a -- What to run
- -> TcM (a, EvBindMap)
+runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a
+runTcSWithEvBinds = runTcSWorker True TcSVanilla
+
+runTcS :: TcS a -> TcM (a, EvBindMap)
runTcS tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; res <- runTcSWithEvBinds ev_binds_var tcs
+ ; res <- runTcSWorker True TcSVanilla aev_binds_var tcs
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; return (res, ev_binds) }
@@ -1000,39 +1006,43 @@ runTcS tcs
runTcSEarlyAbort :: TcS a -> TcM a
runTcSEarlyAbort tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; runTcSWithEvBinds' True TcSHoleFits ev_binds_var tcs }
+ ; runTcSWorker' True TcSHoleFits ev_binds_var tcs }
-- | This can deal only with equality constraints.
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities thing_inside
- = do { ev_binds_var <- TcM.newNoTcEvBinds
- ; runTcSWithEvBinds ev_binds_var thing_inside }
+ = do { ev_binds_var <- TcM.newNoTcEvBinds -- No bindings
+ ; runTcSWorker True TcSVanilla ev_binds_var thing_inside }
+
+-- | This version of runTcS uses mode TcSSpecPrag
+runTcSSpecPrag :: TcS a -> TcM (a, Bag EvBind)
+runTcSSpecPrag thing_inside
+ = do { ev_binds_var <- TcM.newTcEvBinds
+ ; res <- runTcSWorker True TcSSpecPrag ev_binds_var tcs
+ ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
+ ; return (res, evBindMapBinds ev_binds) }
-- | A variant of 'runTcS' that takes and returns an 'InertSet' for
-- later resumption of the 'TcS' session.
runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts inerts tcs = do
- ev_binds_var <- TcM.newTcEvBinds
- runTcSWithEvBinds' False False ev_binds_var $ do
- setInertSet inerts
- a <- tcs
- new_inerts <- getInertSet
- return (a, new_inerts)
-
-runTcSWithEvBinds :: EvBindsVar
- -> TcS a
- -> TcM a
-runTcSWithEvBinds = runTcSWithEvBinds' True TcSVanilla
-
-runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
- -- Don't if you want to reuse the InertSet.
- -- See also Note [Type equality cycles]
- -- in GHC.Tc.Solver.Equality
- -> TcSMode
- -> EvBindsVar
- -> TcS a
- -> TcM a
-runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs
+ = do { ev_binds_var <- TcM.newTcEvBinds
+ ; runTcWorker False TcSVanilla ev_binds_var $
+ do { setInertSet inerts
+ ; a <- tcs
+ ; new_inerts <- getInertSet
+ ; return (a, new_inerts) } }
+
+-- runTcSWorker is not exported
+runTcSWorker :: Bool -- ^ Restore type variable cycles afterwards?
+ -- Don't if you want to reuse the InertSet.
+ -- See also Note [Type equality cycles]
+ -- in GHC.Tc.Solver.Equality
+ -> TcSMode
+ -> EvBindsVar
+ -> TcS a
+ -> TcM a
+runTcSWorker restore_cycles mode ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
@@ -1101,7 +1111,7 @@ nestImplicTcS :: EvBindsVar
-> TcLevel -> TcS a
-> TcS a
nestImplicTcS ref inner_tclvl (TcS thing_inside)
- = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var } ->
+ = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) ->
do { inerts <- TcM.readTcRef old_inert_var
; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack
(inert_cycle_breakers inerts)
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -923,7 +923,7 @@ solveSimpleWanteds simples
-- See Note [The solveSimpleWanteds loop]
go n limit wc
| n `intGtLimit` limit
- = failTcS $ TcRnSimplifierTooManyIterations simples limit wc
+ = failWithTcS $ TcRnSimplifierTooManyIterations simples limit wc
| isEmptyBag (wc_simple wc)
= return (n,wc)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32e0aa0571ac34032426a94b8f2f1be10002bdd9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32e0aa0571ac34032426a94b8f2f1be10002bdd9
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/20250123/21bd0e4c/attachment-0001.html>
More information about the ghc-commits
mailing list