Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9697b84b by Markus Läll at 2026-05-21T11:34:53-04:00 Use "grimily" instead of "grimly" Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221 - - - - - e2ab7959 by fendor at 2026-05-21T11:34:54-04:00 Speed up 'closure' computation in `ghc-pkg` Cache the set of already seen `UnitId`s and use `Set` operations to speed up 'closure' computation. Further simplify the implementation of 'closure' to account for the actual usage. As a consequence, we rename 'closure' to 'brokenPackages' to reflect its purpose better after the simplification. - - - - - a56de36e by sheaf at 2026-05-21T11:35:01-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. - - - - - 15 changed files: - + changelog.d/ghc-pkg-faster-closure - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/Supply.hs - + testsuite/tests/ghc-api/T27273.hs - testsuite/tests/ghc-api/all.T - utils/ghc-pkg/Main.hs Changes: ===================================== changelog.d/ghc-pkg-faster-closure ===================================== @@ -0,0 +1,10 @@ +section: ghc-pkg +synopsis: Improve performance of `ghc-pkg list` command +issues: #27275 +mrs: !16062 + +description: { +`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation. +We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time +for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`. +} ===================================== compiler/GHC/CmmToLlvm/Base.hs ===================================== @@ -318,7 +318,7 @@ instance DSM.MonadGetUnique LlvmM where tag <- getEnv envTag liftUDSMT $! do uq <- DSM.getUniqueM - return (newTagUniqueGrimly uq tag) + return (newTagUniqueGrimily uq tag) -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -175,11 +175,11 @@ instance MonadPlus CoreM instance MonadUnique CoreM where getUniqueSupplyM = do tag <- read cr_uniq_tag - liftIO $! mkSplitUniqSupplyGrimly tag + liftIO $! mkSplitUniqSupplyGrimily tag getUniqueM = do tag <- read cr_uniq_tag - liftIO $! uniqFromTagGrimly tag + liftIO $! uniqFromTagGrimily tag runCoreM :: HscEnv -> RuleBase ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -144,7 +144,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv | otherwise = unpackHObj res_hty header_bits = maybe mempty idTag maybe_target - idTag i = let (tag, u) = unpkUniqueGrimly (getUnique i) + idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i) in CHeader (char tag <> word64 u) normal_args = map (\(nm,_ty,_,_) -> nm) arg_info ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -707,7 +707,7 @@ putName BinSymbolTable{ bin_symtab_next = symtab_next } bh name | isKnownKeyName name - , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits = -- assert (u < 2^(22 :: Int)) put_ bh (0x80000000 .|. (fromIntegral (ord c) `shiftL` 22) ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -66,9 +66,9 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } instance MonadUnique StgM where getUniqueSupplyM = StgM $ do { tag <- ask - ; liftIO $! mkSplitUniqSupplyGrimly tag} + ; liftIO $! mkSplitUniqSupplyGrimily tag} getUniqueM = StgM $ do { tag <- ask - ; liftIO $! uniqFromTagGrimly tag} + ; liftIO $! uniqFromTagGrimily tag} runStgM :: UniqueTag -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m (uniqueTag mask) ===================================== compiler/GHC/StgToJS/Ids.hs ===================================== @@ -130,7 +130,7 @@ makeIdentForId i num id_type current_module = name ident -- unique suffix for non-exported Ids , if exported then mempty - else let (c,u) = unpkUniqueGrimly (getUnique i) + else let (c,u) = unpkUniqueGrimily (getUnique i) in mconcat [BSC.pack ['_',c,'_'], word64BS u] ] @@ -235,4 +235,3 @@ declVarsForId i = case typeSize (idType i) of 0 -> return mempty 1 -> decl <$> identForId i s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] - ===================================== 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 {- ************************************************************************ @@ -1008,13 +997,13 @@ newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; let tag = env_ut env - ; liftIO $! uniqFromTagGrimly tag } + ; liftIO $! uniqFromTagGrimily tag } newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; let tag = env_ut env - ; liftIO $! mkSplitUniqSupplyGrimly tag } + ; liftIO $! mkSplitUniqSupplyGrimily tag } cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -122,7 +122,7 @@ data NameCache = NameCache type OrigNameCache = ModuleEnv (OccEnv Name) takeUniqFromNameCache :: NameCache -> IO Unique -takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimly c +takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -38,12 +38,12 @@ module GHC.Types.Unique ( mkUniqueIntGrimily, getKey, mkUnique, unpkUnique, - unpkUniqueGrimly, + unpkUniqueGrimily, mkUniqueInt, eqUnique, ltUnique, incrUnique, stepUnique, - newTagUnique, newTagUniqueGrimly, + newTagUnique, newTagUniqueGrimily, nonDetCmpUnique, isValidKnownKeyUnique, @@ -99,7 +99,7 @@ Note [Performance implications of UniqueTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The UniqueTag ADT is meant to be ephemeral and eliminated by the simplifier, so for long term storage (i.e. in monadic environments or data structures) we -want to store the raw 'Char's. Working with the raw tags is done via the *Grimly +want to store the raw 'Char's. Working with the raw tags is done via the *Grimily class of functions For instance, if we are generating a unique for a concrete tag, we should use @@ -116,7 +116,7 @@ newUnique ; liftIO $! uniqFromTag tag } Prefer `env_ut :: Char` and - ; liftIO $! uniqFromTagGrimly tag } + ; liftIO $! uniqFromTagGrimily tag } -} @@ -295,7 +295,7 @@ The stuff about unique *supplies* is handled further down this module. -} unpkUnique :: Unique -> (UniqueTag, Word64) -- The reverse -unpkUniqueGrimly :: Unique -> (Char, Word64) -- The reverse +unpkUniqueGrimily :: Unique -> (Char, Word64) -- The reverse mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply getKey :: Unique -> Word64 -- for Var @@ -303,7 +303,7 @@ getKey :: Unique -> Word64 -- for Var incrUnique :: Unique -> Unique stepUnique :: Unique -> Word64 -> Unique newTagUnique :: Unique -> UniqueTag -> Unique -newTagUniqueGrimly :: Unique -> Char -> Unique +newTagUniqueGrimily :: Unique -> Char -> Unique mkUniqueGrimily = MkUnique @@ -323,9 +323,9 @@ maxLocalUnique :: Unique maxLocalUnique = mkLocalUnique uniqueMask -- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = newTagUniqueGrimly u (uniqueTag c) +newTagUnique u c = newTagUniqueGrimily u (uniqueTag c) -newTagUniqueGrimly u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimly u +newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u -- | Bitmask that has zeros for the tag bits and ones for the rest. uniqueMask :: Word64 @@ -368,7 +368,7 @@ mkUniqueIntGrimily = MkUnique . intToWord64 {-# INLINE mkUniqueIntGrimily #-} -unpkUniqueGrimly (MkUnique u) +unpkUniqueGrimily (MkUnique u) = let -- The potentially truncating use of fromIntegral here is safe -- because the argument is just the tag bits after shifting. @@ -376,10 +376,10 @@ unpkUniqueGrimly (MkUnique u) i = u .&. uniqueMask in (tag, i) -{-# INLINE unpkUniqueGrimly #-} +{-# INLINE unpkUniqueGrimily #-} -unpkUnique u = case unpkUniqueGrimly u of +unpkUnique u = case unpkUniqueGrimily u of (c, i) -> ( charToUniqueTag c, i) {-# INLINE unpkUnique #-} @@ -389,7 +389,7 @@ unpkUnique u = case unpkUniqueGrimly u of -- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details. isValidKnownKeyUnique :: Unique -> Bool isValidKnownKeyUnique u = - case unpkUniqueGrimly u of + case unpkUniqueGrimily u of (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) {- @@ -512,7 +512,7 @@ showUnique :: Unique -> String showUnique uniq = tagStr ++ w64ToBase62 u where - (tag, u) = unpkUniqueGrimly uniq + (tag, u) = unpkUniqueGrimily uniq -- Avoid emitting non-printable characters in pretty uniques. -- See #25989. tagStr ===================================== compiler/GHC/Types/Unique/Supply.hs ===================================== @@ -16,10 +16,10 @@ module GHC.Types.Unique.Supply ( -- ** Operations on supplies uniqFromSupply, uniqsFromSupply, -- basic ops takeUniqFromSupply, - uniqFromTag, uniqFromTagGrimly, + uniqFromTag, uniqFromTagGrimily, UniqueTag(..), - mkSplitUniqSupply, mkSplitUniqSupplyGrimly, + mkSplitUniqSupply, mkSplitUniqSupplyGrimily, splitUniqSupply, listSplitUniqSupply, -- * Unique supply monad and its abstraction @@ -203,10 +203,10 @@ data UniqSupply -- when split => these two supplies mkSplitUniqSupply :: UniqueTag -> IO UniqSupply -mkSplitUniqSupply ut = mkSplitUniqSupplyGrimly (uniqueTag ut) +mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut) {-# INLINE mkSplitUniqSupply #-} -mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply +mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air. -- The "tag" (Char) supplied is mostly cosmetic, making it easier -- to figure out where a Unique was born. See Note [Uniques and tags]. @@ -219,7 +219,7 @@ mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply -- See Note [How the unique supply works] -- See Note [Optimising the unique supply] -mkSplitUniqSupplyGrimly ut +mkSplitUniqSupplyGrimily ut = unsafeDupableInterleaveIO (IO mk_supply) where @@ -286,15 +286,15 @@ initUniqSupply counter inc = do poke ghc_unique_inc inc uniqFromTag :: UniqueTag -> IO Unique -uniqFromTag !ut = uniqFromTagGrimly (uniqueTag ut) +uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut) {-# INLINE uniqFromTag #-} -uniqFromTagGrimly :: Char -> IO Unique -uniqFromTagGrimly !tag +uniqFromTagGrimily :: Char -> IO Unique +uniqFromTagGrimily !tag = do { uqNum <- genSym ; return $! mkUniqueGrimilyWithTag tag uqNum } -{-# NOINLINE uniqFromTagGrimly #-} -- We'll unbox everything, but we don't want to inline it +{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which ===================================== 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']) ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do all_ps = map mungedId pkgs1 let not_broken_pkgs = filterOut broken_pkgs pkgs - (_, trans_broken_pkgs) = closure [] not_broken_pkgs + trans_broken_pkgs = brokenPackages not_broken_pkgs all_broken_pkgs :: [InstalledPackageInfo] all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs @@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> ([InstalledPackageInfo], [InstalledPackageInfo]) -closure pkgs db_stack = go pkgs db_stack - where - go avail not_avail = - case partition (depsAvailable avail) not_avail of - ([], not_avail') -> (avail, not_avail') - (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' +-- | Compute the set of transitive broken packages. +-- +-- A package is assumed to be broken if any of its dependencies is not +-- found in the 'db_stack' after a transitive reduction. +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages db_stack = go Set.empty db_stack + where + go avail_ids not_avail = + case partition (depsAvailable avail_ids) not_avail of + ([], not_avail') -> not_avail' + (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail' - depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo - -> Bool - depsAvailable pkgs_ok pkg = null dangling - where dangling = filter (`notElem` pids) (depends pkg) - pids = map installedUnitId pkgs_ok + add new_avail avail_ids = + foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail) - -- we want mutually recursive groups of package to show up - -- as broken. (#1750) + depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool + depsAvailable pids pkg = all (`Set.member` pids) (depends pkg) -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = snd (closure [] pkgs) + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f61143adb4809968be3eb0a5732f22... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f61143adb4809968be3eb0a5732f22... You're receiving this email because of your account on gitlab.haskell.org.