[Git][ghc/ghc][wip/T24359] WIP on a different approach [skip ci]
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jan 16 08:26:21 UTC 2025
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
61d8ab31 by Simon Peyton Jones at 2025-01-16T08:25:49+00:00
WIP on a different approach [skip ci]
- - - - -
1 changed file:
- compiler/GHC/Tc/Solver/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -824,6 +824,8 @@ added. This is initialised from the innermost implication constraint.
data TcSEnv
= TcSEnv {
+ tcs_mode :: TcSMode,
+
tcs_ev_binds :: EvBindsVar,
tcs_unified :: IORef Int,
@@ -841,15 +843,25 @@ data TcSEnv
tcs_inerts :: IORef InertSet, -- Current inert set
- -- Whether to throw an exception if we come across an insoluble constraint.
- -- Used to fail-fast when checking for hole-fits. See Note [Speeding up
- -- valid hole-fits].
- tcs_abort_on_insoluble :: Bool,
-
-- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet
tcs_worklist :: IORef WorkList -- Current worklist
}
+data TcSMode
+ = TcSVanilla
+
+ | TcSHoleFits -- See Note [Speeding up valid hole-fits].
+ -- In this moe we throw an exception if we come across an
+ -- insoluble constraint, to fail-fast when checking for hole-fits.
+
+ | TcSSpecPrag -- Don't use instance declarations or upack forall constraints
+ -- when simplifying a SPECIALISE pragma
+
+instance Outputable TcSMode where
+ ppr TcSVanilla = text "TcSVanilla"
+ ppr TcSHoleFits = text "TcSHoleFits"
+ ppr TcSSpecPrag = text "TcSSpecPrag"
+
---------------
newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
deriving (Functor)
@@ -917,10 +929,8 @@ warnTcS msg = wrapTcS (TcM.addDiagnostic msg)
addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc
-tryEarlyAbortTcS :: TcS ()
--- Abort (fail in the monad) if the abort_on_insoluble flag is on
-tryEarlyAbortTcS
- = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM)
+getModeTcS :: TcS TcSMode
+getModeTcS = mkTcS (\env -> return (tcs_mode env))
-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.
ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()
@@ -990,7 +1000,7 @@ runTcS tcs
runTcSEarlyAbort :: TcS a -> TcM a
runTcSEarlyAbort tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; runTcSWithEvBinds' True True ev_binds_var tcs }
+ ; runTcSWithEvBinds' True TcSHoleFits ev_binds_var tcs }
-- | This can deal only with equality constraints.
runTcSEqualities :: TcS a -> TcM a
@@ -1012,29 +1022,29 @@ runTcSInerts inerts tcs = do
runTcSWithEvBinds :: EvBindsVar
-> TcS a
-> TcM a
-runTcSWithEvBinds = runTcSWithEvBinds' True False
+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
- -> Bool
+ -> TcSMode
-> EvBindsVar
-> TcS a
-> TcM a
-runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs
+runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
; wl_var <- TcM.newTcRef emptyWorkList
; unif_lvl_var <- TcM.newTcRef Nothing
- ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
- , tcs_unified = unified_var
- , tcs_unif_lvl = unif_lvl_var
- , tcs_count = step_count
- , tcs_inerts = inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
- , tcs_worklist = wl_var }
+ ; let env = TcSEnv { tcs_mode = mode
+ , tcs_ev_binds = ev_binds_var
+ , tcs_unified = unified_var
+ , tcs_unif_lvl = unif_lvl_var
+ , tcs_count = step_count
+ , tcs_inerts = inert_var
+ , tcs_worklist = wl_var }
-- Run the computation
; res <- unTcS tcs env
@@ -1091,12 +1101,7 @@ nestImplicTcS :: EvBindsVar
-> TcLevel -> TcS a
-> TcS a
nestImplicTcS ref inner_tclvl (TcS thing_inside)
- = TcS $ \ TcSEnv { tcs_unified = unified_var
- , tcs_inerts = old_inert_var
- , tcs_count = count
- , tcs_unif_lvl = unif_lvl
- , tcs_abort_on_insoluble = abort_on_insoluble
- } ->
+ = 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)
@@ -1105,13 +1110,9 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
-- All other InertSet fields are inherited
; new_inert_var <- TcM.newTcRef nest_inert
; new_wl_var <- TcM.newTcRef emptyWorkList
- ; let nest_env = TcSEnv { tcs_count = count -- Inherited
- , tcs_unif_lvl = unif_lvl -- Inherited
- , tcs_ev_binds = ref
- , tcs_unified = unified_var
- , tcs_inerts = new_inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
- , tcs_worklist = new_wl_var }
+ ; let nest_env = env { tcs_ev_binds = ref
+ , tcs_inerts = new_inert_var
+ , tcs_worklist = new_wl_var }
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61d8ab31312dfbefde1ccce3032749d5fb29872c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61d8ab31312dfbefde1ccce3032749d5fb29872c
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/20250116/efeb0543/attachment-0001.html>
More information about the ghc-commits
mailing list