Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7ecc6184 by sheaf at 2026-05-21T15:27:10-04:00 TcMPluginHandling: be more lenient when no plugins This change ensures that, if a function such as 'typecheckModule' was invoked with 'NoTcMPlugins', GHC doesn't spuriously complain about TcM plugins having already been stopped, as there were none to start with. - - - - - 4 changed files: - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - + testsuite/tests/ghc-api/T27273.hs - testsuite/tests/ghc-api/all.T Changes: ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -1250,14 +1250,17 @@ emptyTcMPluginsShutdown = TcMPluginsShutdown data TcMPluginsState -- | The 'TcM' plugins have not been started. = TcMPluginsUninitialised - -- | The 'TcM' plugins have been initialised and not yet stopped. + -- | The 'TcM' plugins have been initialised and not yet stopped, + -- or there were no 'TcM' plugins to start with. -- -- We may be in the middle of typechecker, or have finished typechecking -- and be in the middle of desugaring. | TcMPluginsRunning !RunningTcMPlugins - -- | The 'TcM' plugins have been stopped. + -- | There were 'TcM' plugins that were running, but they have been stopped. | TcMPluginsStopped +-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and +-- @shutdown@ actions. data RunningTcMPlugins = RunningTcMPlugins { rtcmp_run :: TcMPluginsRun @@ -1281,11 +1284,20 @@ tcMPluginsShutdownActions = rtcmp_shutdown -- | Retrieve the 'TcM' plugins from a 'TcMPluginsState'. -- --- Assumes the plugins have been already started and not yet stopped. +-- Assumes the plugins (if any) have been already started and not yet stopped. runningTcMPlugins :: HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins runningTcMPlugins = \case - TcMPluginsUninitialised -> panic "runningTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "runningTcMPlugins: TcM plugins already stopped" + TcMPluginsUninitialised -> + pprPanic "TcM plugins have not been started" $ + vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'" + , text "to ensure that TcM plugins (if any) are initialised before typechecking." + ] + TcMPluginsStopped -> + pprPanic "TcM plugins already stopped" $ + vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking," + , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling'," + , text "as that stops TcM plugins after typechecking." + ] TcMPluginsRunning plugins -> plugins ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -790,9 +790,10 @@ withoutTcMPlugins thing_inside = do tcg_env <- getGblEnv writeTcRef (tcg_plugins tcg_env) $ TcMPluginsRunning emptyRunningTcMPlugins - teardown = do - tcg_env <- getGblEnv - writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped + teardown = + -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only + -- be used when there were 'TcM' plugins to start with (#27273). + return () -- | Initialise 'TcM' plugins. initTcMPlugins :: HscEnv -> TcM () @@ -946,32 +947,20 @@ shutdownTcMPlugins = \case runPluginShutdowns (tcs ++ defs) solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver] -solverTcMPlugins = \case - TcMPluginsUninitialised -> panic "solverTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "solverTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_solvers (tcMPluginsRunActions plugins) +solverTcMPlugins = + tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter] -rewriterTcMPlugins = \case - TcMPluginsUninitialised -> panic "rewriterTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "rewriterTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_rewriters (tcMPluginsRunActions plugins) +rewriterTcMPlugins = + tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting] -defaultingTcMPlugins = \case - TcMPluginsUninitialised -> panic "defaultingTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "defaultingTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_defaulters (tcMPluginsRunActions plugins) +defaultingTcMPlugins = + tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin] -holeFitTcMPlugins = \case - TcMPluginsUninitialised -> panic "holeFitTcMPlugins: TcM plugins not started" - TcMPluginsStopped -> panic "holeFitTcMPlugins: TcM plugins already stopped" - TcMPluginsRunning plugins -> - tcmp_hole_fits (tcMPluginsRunActions plugins) +holeFitTcMPlugins = + tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins {- ************************************************************************ ===================================== testsuite/tests/ghc-api/T27273.hs ===================================== @@ -0,0 +1,56 @@ +module Main where + +-- base +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import System.Environment (getArgs) + +-- time +import Data.Time (getCurrentTime) + +-- ghc +import qualified GHC as GHC +import qualified GHC.Core as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Unit.Module.ModGuts as GHC +import qualified GHC.Unit.Types as GHC + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + let inputSource = unlines + [ "module NumLitDesugaring where" + , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int + , "f = 1" + ] + + void $ compileToCore "NumLitDesugaring" inputSource + +compileToCore :: String -> String -> IO [GHC.CoreBind] +compileToCore modName inputSource = do + [libdir] <- getArgs + GHC.runGhc (Just libdir) $ do + (_ms, tcMod) <- typecheckSourceCode modName inputSource + dsMod <- GHC.desugarModule tcMod + return $ GHC.mg_binds $ GHC.dm_core_module dsMod + +typecheckSourceCode + :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule) +typecheckSourceCode modName inputSource = do + now <- liftIO getCurrentTime + df1 <- GHC.getSessionDynFlags + GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend } + let target = GHC.Target + { GHC.targetId = GHC.TargetFile (modName ++ ".hs") Nothing + , GHC.targetUnitId = GHC.homeUnitId_ df1 + , GHC.targetAllowObjCode = False + , GHC.targetContents = Just (GHC.stringToStringBuffer inputSource, now) + } + GHC.setTargets [target] + void $ GHC.depanal [] False + + ms <- GHC.getModSummary + (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName)) + tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins + return (ms, tm) ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -82,3 +82,6 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) test('T25121_status', normal, compile_and_run, ['-package ghc']) test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) +test('T27273', [extra_run_opts(f'"{config.libdir}"')], + compile_and_run, + ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ecc618466382588b9934c514f178e0b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ecc618466382588b9934c514f178e0b... You're receiving this email because of your account on gitlab.haskell.org.