May 2026 - ghc-commits

[Git][ghc/ghc][wip/semaphore-v2] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Zubin (＠wz1000) 25 May '26

25 May '26

Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC Commits: d21ad32b by Zubin Duggal at 2026-05-25T16:06:52+05:30 Update to semaphore-compat 2.0.0 using v2 of the protocol On Linux and other POSIX platforms, GHC's -jsem jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix domain sockets in place of POSIX named semaphores. This avoids the libc-ABI issues that affected the old implementation. Windows is unaffected and continues to use the v1 protocol (Win32 named semaphores); its reported protocol version remains v1. When GHC receives a -jsem name whose protocol version it does not support, it emits a -Wsemaphore-version-mismatch warning and falls back to -j<N> rather than crashing. ghc --info exposes the supported version in a new "Semaphore version" entry so cabal-install can detect a mismatch before invoking GHC. Users on a cabal-install that predates the v2 update will continue to build successfully on Linux/POSIX, but will lose the cross-process -jsem coordination and fall back to -j<N> per GHC invocation. Users must upgrade to a cabal-install that supports protocol v2 to recover full parallelism. Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot heldTokens and release them before killing the loop, while the loop's in-flight acquire/release children could still be mutating it. Cleanup now runs inside the loop's own exit handler, after draining the active child via a new activeChild TVar, so the snapshot has no concurrent mutator. See also: - GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673 - cabal-install patch: https://github.com/haskell/cabal/pull/11628 - semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8 Bump semaphore-compat submodule to 2.0.0 Fixes #25087 and #27253 - - - - - 16 changed files: - + changelog.d/jobserver-leak-fix - + changelog.d/semaphore-v2 - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Flavour.hs - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout Changes: ===================================== changelog.d/jobserver-leak-fix ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27253 +mrs: !15729 +synopsis: + Fix a token leak in the ``-jsem`` jobserver shutdown path +description: + A build interrupted by Ctrl-C while a ``-jsem`` token transfer was in + flight could leak that token. ===================================== changelog.d/semaphore-v2 ===================================== @@ -0,0 +1,30 @@ +section: compiler +issues: #25087 +mrs: !15729 +synopsis: + Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2) +description: + On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client + now speaks v2 of the semaphore-compat protocol, which uses Unix + domain sockets in place of POSIX named semaphores. This avoids the + libc-ABI issues that affected the old implementation. Windows is + unaffected and continues to use the v1 protocol (Win32 named + semaphores); its reported protocol version remains v1. + + When GHC receives a ``-jsem`` name whose protocol version it does not + support, it now emits a ``-Wsemaphore-version-mismatch`` warning and + falls back to ``-j1`` rather than crashing. ``ghc --info`` exposes the + supported version in a new ``"Semaphore version"`` entry so + cabal-install can detect a mismatch before invoking GHC. + + Users on a ``cabal-install`` that predates the v2 update will continue + to build successfully, but on Linux/POSIX will lose the cross-process + ``-jsem`` coordination and fall back to ``-j1`` per GHC invocation. + To recover full parallelism, upgrade to a ``cabal-install`` that + supports protocol v2. + + See also: + + - the `GHC proposal amendment <https://github.com/ghc-proposals/ghc-proposals/pull/673>`_ + - the `cabal-install patch <https://github.com/haskell/cabal/pull/11628>`_ + - the `semaphore-compat library MR <https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8>`_ ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -24,6 +24,8 @@ import GHC.Types.Hint import GHC.Types.SrcLoc import Data.Version +import System.Semaphore + ( SemaphoreError(..), getSemaphoreProtocolVersion ) import Language.Haskell.Syntax.Decls (RuleDecl(..)) import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) @@ -90,6 +92,20 @@ instance Diagnostic GhcMessage where instance HasDefaultDiagnosticOpts DriverMessageOpts where defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) +pprSemaphoreError :: SemaphoreError -> SDoc +pprSemaphoreError = \case + SemaphoreAlreadyExists nm -> + text "a semaphore named" <+> quotes (text nm) <+> text "already exists" + SemaphoreDoesNotExist nm -> + text "no semaphore named" <+> quotes (text nm) + SemaphoreIncompatibleVersion got want -> + text "protocol version mismatch (got v" + <> int (getSemaphoreProtocolVersion got) + <> text ", supported v" + <> int (getSemaphoreProtocolVersion want) <> text ")" + SemaphoreOtherError ioe -> + text (show ioe) + instance Diagnostic DriverMessage where type DiagnosticOpts DriverMessage = DriverMessageOpts diagnosticMessage opts = \case @@ -282,6 +298,10 @@ instance Diagnostic DriverMessage where -> mkSimpleDecorated $ vcat [ text "The following modules are missing a linkable which is needed for creating a library:" , nest 2 $ hcat (map ppr mods) ] + DriverSemaphoreOpenFailure _ err + -> mkSimpleDecorated $ + text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <> + text "; ignoring -jsem and compiling sequentially." diagnosticReason = \case DriverUnknownMessage m @@ -355,6 +375,8 @@ instance Diagnostic DriverMessage where -> WarningWithoutFlag DriverMissingLinkableForModule {} -> ErrorWithoutFlag + DriverSemaphoreOpenFailure {} + -> WarningWithFlag Opt_WarnSemaphoreOpenFailure diagnosticHints = \case DriverUnknownMessage m @@ -430,5 +452,19 @@ instance Diagnostic DriverMessage where -> noHints DriverMissingLinkableForModule {} -> noHints + DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported) + | received < supported + -> let required = getSemaphoreProtocolVersion supported + target = case buildingCabal of + YesBuildingCabalPackage -> UpgradeCabalInstall + NoBuildingCabalPackage -> UpgradeJobserver + in [SuggestUpgradeForSemaphoreVersionMismatch target required] + | received > supported + -> [SuggestUpgradeForSemaphoreVersionMismatch + UpgradeGHC (getSemaphoreProtocolVersion received)] + | otherwise + -> noHints + DriverSemaphoreOpenFailure {} + -> noHints diagnosticCode = constructorCode @GHC ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -37,6 +37,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Generics ( Generic ) +import System.Semaphore ( SemaphoreError ) import GHC.Tc.Errors.Types import GHC.Iface.Errors.Types @@ -419,6 +420,17 @@ data DriverMessage where DriverMissingLinkableForModule :: ![Module] -> DriverMessage + {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to + open the semaphore specified by @-jsem@, e.g. the socket does not + exist, the protocol version is incompatible, or a system error + occurred. GHC ignores @-jsem@ and compiles sequentially. + + The 'BuildingCabalPackage' flag controls whether the diagnostic + hint suggests upgrading @cabal-install@ (it only does so when GHC + is invoked by Cabal). + -} + DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage + deriving instance Generic DriverMessage data DriverMessageOpts = ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1115,6 +1115,7 @@ data WarningFlag = | Opt_WarnUnusableUnpackPragmas -- ^ @since 9.14 | Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14 | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 + | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1237,6 +1238,7 @@ warnFlagNames wflag = case wflag of Opt_WarnUnusableUnpackPragmas -> "unusable-unpack-pragmas" :| [] Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| [] Opt_WarnUnrecognisedModifiers -> "unrecognised-modifiers" :| [] + Opt_WarnSemaphoreOpenFailure -> "semaphore-open-failure" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options @@ -1383,7 +1385,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnDeprecatedPragmas, Opt_WarnRuleLhsEqualities, Opt_WarnUnusableUnpackPragmas, - Opt_WarnUnrecognisedModifiers + Opt_WarnUnrecognisedModifiers, + Opt_WarnSemaphoreOpenFailure ] -- | Things you get with @-W@. ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -28,16 +28,39 @@ import GHC.Driver.Errors.Types import GHC.Driver.Messager import GHC.Driver.MakeSem +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import System.Semaphore + ( SemaphoreIdentifier ) +#else +import System.Semaphore + ( SemaphoreError, SemaphoreIdentifier ) +#endif + +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) +import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig ) +import GHC.Driver.Errors ( printOrThrowDiagnostics ) +import GHC.Types.Error ( singleMessage ) +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Utils.Error ( mkPlainMsgEnvelope ) +#endif import GHC.Utils.Logger import GHC.Utils.TmpFs +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask ) +#else import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) +#endif import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Monad import qualified Control.Monad.Catch as MC +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import GHC.Conc ( getNumProcessors ) +#else import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +#endif import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.LogQueue import Control.Concurrent.STM @@ -49,7 +72,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit mkWorkerLimit dflags = case parMakeCount dflags of Nothing -> pure $ num_procs 1 - Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) + Just (ParMakeSemaphore h) -> pure (JSemLimit h) Just ParMakeNumProcessors -> num_procs <$> getNumProcessors Just (ParMakeThisMany n) -> pure $ num_procs n where @@ -65,8 +88,8 @@ isWorkerLimitSequential (JSemLimit {}) = False data WorkerLimit = NumProcessorsLimit Int | JSemLimit - SemaphoreName - -- ^ Semaphore name to use + SemaphoreIdentifier + -- ^ Semaphore identifier from @-jsem@ deriving Eq -- | Environment used when compiling a module @@ -106,6 +129,7 @@ runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = } in runAllPipelines (NumProcessorsLimit 1) env all_pipelines +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a runNjobsAbstractSem n_jobs action = do compile_sem <- newQSem n_jobs @@ -122,17 +146,26 @@ runNjobsAbstractSem n_jobs action = do resetNumCapabilities = set_num_caps n_capabilities MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a -#if defined(wasm32_HOST_ARCH) -runWorkerLimit _ action = do +#endif + +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +runWorkerLimit _logger _dflags _ action = do lock <- newMVar () action $ AbstractSem (takeMVar lock) (putMVar lock ()) #else -runWorkerLimit worker_limit action = case worker_limit of +runWorkerLimit logger dflags worker_limit action = case worker_limit of NumProcessorsLimit n_jobs -> runNjobsAbstractSem n_jobs action - JSemLimit sem -> - runJSemAbstractSem sem action + JSemLimit sem_ident -> do + result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action + case result of + Right a -> return a + Left err -> do + let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err + msg = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag + printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg) + runNjobsAbstractSem 1 action #endif -- | Build and run a pipeline @@ -159,7 +192,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } - runWorkerLimit worker_limit $ \abstract_sem -> do + runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do let env = MakeEnv { hsc_env = thread_safe_hsc_env , withLogger = withParLog log_queue_queue_var , compile_sem = abstract_sem @@ -245,4 +278,4 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () -waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar \ No newline at end of file +waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Driver/MakeSem.hs ===================================== @@ -1,23 +1,33 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | Implementation of a jobserver using system semaphores. -- -- module GHC.Driver.MakeSem - ( -- * JSem: parallelism semaphore backed + ( +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) + -- * JSem: parallelism semaphore backed -- by a system semaphore (Posix/Windows) - runJSemAbstractSem - - -- * System semaphores - , Semaphore, SemaphoreName(..) + runJSemAbstractSem, +#endif -- * Abstract semaphores - , AbstractSem(..) + AbstractSem(..) , withAbstractSem ) where +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) + +import System.Semaphore + ( AbstractSem(..) + , withAbstractSem + ) + +#else + import GHC.Prelude import GHC.Conc import GHC.Data.OrdList @@ -27,6 +37,15 @@ import GHC.Utils.Panic import GHC.Utils.Json import System.Semaphore + ( AbstractSem(..) + , ClientSemaphore + , SemaphoreIdentifier + , SemaphoreToken + , openSemaphore + , releaseSemaphoreToken + , waitOnSemaphore + , withAbstractSem + ) import Control.Monad import qualified Control.Monad.Catch as MC @@ -46,11 +65,14 @@ import Debug.Trace -- available from the semaphore. data Jobserver = Jobserver - { jSemaphore :: !Semaphore + { jSemaphore :: !ClientSemaphore -- ^ The semaphore which controls available resources , jobs :: !(TVar JobResources) -- ^ The currently pending jobs, and the resources -- obtained from the semaphore + , activeChild :: !(TVar (Maybe (ThreadId, TMVar (Maybe MC.SomeException)))) + -- ^ Handle on the current acquire thread (if any). The loop's exit + -- handler reads this to drain a still-running child on shutdown. } data JobserverOptions @@ -81,6 +103,9 @@ data JobResources , jobsWaiting :: !(OrdList (TMVar ())) -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into -- the TMVar will allow the job to continue. + , heldTokens :: [SemaphoreToken] + -- ^ Actual semaphore tokens (for release/cleanup). + -- Length should equal tokensOwned - 1 (the implicit token has no SemaphoreToken). } instance Outputable JobResources where @@ -93,9 +118,9 @@ instance Outputable JobResources where ] ) -- | Add one new token. -addToken :: JobResources -> JobResources -addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free }) - = jobs { tokensOwned = owned + 1, tokensFree = free + 1 } +addToken :: SemaphoreToken -> JobResources -> JobResources +addToken tok jobs@( Jobs { tokensOwned = owned, tokensFree = free, heldTokens = toks }) + = jobs { tokensOwned = owned + 1, tokensFree = free + 1, heldTokens = tok : toks } -- | Free one token. addFreeToken :: JobResources -> JobResources @@ -111,12 +136,14 @@ removeFreeToken jobs@( Jobs { tokensFree = free }) (text "removeFreeToken:" <+> ppr free) $ jobs { tokensFree = free - 1 } --- | Return one owned token. -removeOwnedToken :: JobResources -> JobResources -removeOwnedToken jobs@( Jobs { tokensOwned = owned }) +-- | Return one owned token, extracting the 'SemaphoreToken' for release. +removeOwnedToken :: JobResources -> (SemaphoreToken, JobResources) +removeOwnedToken jobs@( Jobs { tokensOwned = owned, heldTokens = toks }) = assertPpr (owned > 1) (text "removeOwnedToken:" <+> ppr owned) - $ jobs { tokensOwned = owned - 1 } + $ case toks of + (t:rest) -> (t, jobs { tokensOwned = owned - 1, heldTokens = rest }) + [] -> panic "removeOwnedToken: no held tokens" -- | Add one new job to the end of the list of pending jobs. addJob :: TMVar () -> JobResources -> JobResources @@ -143,7 +170,7 @@ data JobserverAction = Idle -- | A thread is waiting for a token on the semaphore. | Acquiring - { activeWaitId :: WaitId + { activeThreadId :: ThreadId , threadFinished :: TMVar (Maybe MC.SomeException) } -- | Retrieve the 'TMVar' that signals if the current thread has finished, @@ -189,17 +216,30 @@ releaseJob jobs_tvar = do return ((), addFreeToken jobs) --- | Release all tokens owned from the semaphore (to clean up --- the jobserver at the end). -cleanupJobserver :: Jobserver -> IO () -cleanupJobserver (Jobserver { jSemaphore = sem - , jobs = jobs_tvar }) - = do - Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar - let toks_to_release = owned - 1 - -- Subtract off the implicit token: whoever spawned the ghc process - -- in the first place is responsible for that token. - releaseSemaphore sem toks_to_release +-- | Kill the current acquire thread, if any, and wait for it to exit. +-- +-- Called from the jobserver loop's exit handler, which runs masked. +-- Relies on the invariant from 'acquireThread' that a forked child +-- always fills its 'threadFinished' TMVar before it dies; this is what +-- lets the 'takeTMVar' below terminate after the 'killThread'. +drainActiveChild :: Jobserver -> IO () +drainActiveChild (Jobserver { activeChild = active_tvar }) = do + mb <- readTVarIO active_tvar + for_ mb $ \(tid, tmv) -> do + killThread tid + void $ atomically (takeTMVar tmv) + atomically $ writeTVar active_tvar Nothing + +-- | Release every token currently in 'heldTokens'. +-- +-- Called from the jobserver loop's exit handler, which runs masked, +-- after 'drainActiveChild': no other thread is mutating 'JobResources' +-- at this point. +releaseAllHeld :: Jobserver -> IO () +releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do + Jobs { heldTokens = toks } <- readTVarIO jobs_tvar + forM_ toks $ \t -> + void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t) -- | Dispatch the available tokens acquired from the semaphore -- to the pending jobs in the job server. @@ -252,7 +292,7 @@ tracedAtomically origin act = do return a renderJobResources :: String -> JobResources -> String -renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $ +renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $ JSObject [ ("name", JSString origin) , ("owned", JSInt own) , ("free", JSInt free) @@ -262,61 +302,68 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON -- | Spawn a new thread that waits on the semaphore in order to acquire -- an additional token. +-- +-- The child is forked masked so the only async-exception delivery point +-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then +-- always runs to completion, so 'threadFinished' is always filled. +-- +-- The (tid, threadFinished) pair is also published to 'activeChild' so +-- shutdown can drain the child even after the in-loop 'JobserverState' +-- is gone. acquireThread :: Jobserver -> IO JobserverAction -acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do threadFinished_tmvar <- newEmptyTMVarIO - let - wait_result_action :: Either MC.SomeException Bool -> IO () - wait_result_action wait_res = + tid <- MC.mask_ $ do + tid <- forkIO $ do + wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem tracedAtomically_ "acquire_thread" do (r, jb) <- case wait_res of Left (e :: MC.SomeException) -> do return $ (Just e, Nothing) - Right success -> do - if success - then do - modifyJobResources jobs_tvar \ jobs -> - return (Nothing, addToken jobs) - else - return (Nothing, Nothing) + Right tok -> do + modifyJobResources jobs_tvar \ jobs -> + return (Nothing, addToken tok jobs) putTMVar threadFinished_tmvar r return jb - wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action - labelThread (waitingThreadId wait_id) "acquire_thread" - return $ Acquiring { activeWaitId = wait_id + atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar)) + return tid + labelThread tid "acquire_thread" + return $ Acquiring { activeThreadId = tid , threadFinished = threadFinished_tmvar } -- | Spawn a thread to release ownership of one resource from the semaphore, -- provided we have spare resources and no pending jobs. releaseThread :: Jobserver -> IO JobserverAction -releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do +releaseThread (Jobserver { jobs = jobs_tvar }) = do threadFinished_tmvar <- newEmptyTMVarIO MC.mask_ do -- Pre-release the resource so that another thread doesn't take control of it -- just as we release the lock on the semaphore. - still_ok_to_release + mb_tok <- tracedAtomically "pre_release" $ modifyJobResources jobs_tvar \ jobs -> if guardRelease jobs - -- TODO: should this also debounce? - then return (True , removeOwnedToken $ removeFreeToken jobs) - else return (False, jobs) - if not still_ok_to_release - then return Idle - else do - tid <- forkIO $ do - x <- MC.try $ releaseSemaphore sem 1 - tracedAtomically_ "post-release" $ do - (r, jobs) <- case x of - Left (e :: MC.SomeException) -> do - modifyJobResources jobs_tvar \ jobs -> - return (Just e, addToken jobs) - Right _ -> do - return (Nothing, Nothing) - putTMVar threadFinished_tmvar r - return jobs - labelThread tid "release_thread" - return Idle + then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs + in return (Just tok, jobs') + else return (Nothing, jobs) + case mb_tok of + Nothing -> + -- Not OK to release: there are other pending jobs that could make use of the token. + return Idle + Just tok -> do + tid <- forkIO $ do + x <- MC.try @_ @MC.SomeException $ releaseSemaphoreToken tok + tracedAtomically_ "post-release" $ do + (r, jobs) <- case x of + Left (e :: MC.SomeException) -> do + modifyJobResources jobs_tvar \ jobs -> + return (Just e, addToken tok jobs) + Right _ -> do + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jobs + labelThread tid "release_thread" + return Idle -- | When there are pending jobs but no free tokens, -- spawn a thread to acquire a new token from the semaphore. @@ -363,13 +410,14 @@ tryRelease _ _ = retry -- | Wait for an active thread to finish. Once it finishes: -- -- - set the 'JobserverAction' to 'Idle', +-- - clear the 'activeChild' handle, -- - update the number of capabilities to reflect the number -- of owned tokens from the semaphore. tryNoticeIdle :: JobserverOptions - -> TVar JobResources + -> Jobserver -> JobserverState -> STM (IO JobserverState) -tryNoticeIdle opts jobs_tvar jobserver_state +tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar | otherwise @@ -381,6 +429,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do mb_ex <- takeTMVar threadFinished_tmvar for_ mb_ex MC.throwM + writeTVar active_tvar Nothing Jobs { tokensOwned } <- readTVar jobs_tvar can_change_numcaps <- readTVar can_change_numcaps_tvar guard can_change_numcaps @@ -404,11 +453,11 @@ tryStopThread :: TVar JobResources -> STM (IO JobserverState) tryStopThread jobs_tvar jsj = do case jobserverAction jsj of - Acquiring { activeWaitId = wait_id } -> do + Acquiring { activeThreadId = tid } -> do jobs <- readTVar jobs_tvar guard $ null (jobsWaiting jobs) return do - interruptWaitOnSemaphore wait_id + killThread tid return $ jsj { jobserverAction = Idle } _ -> retry @@ -430,30 +479,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar }) action <- atomically $ asum $ (\x -> x s) <$> [ tryRelease sjs , tryAcquire opts sjs - , tryNoticeIdle opts jobs_tvar + , tryNoticeIdle opts sjs , tryStopThread jobs_tvar ] s <- action loop s --- | Create a new jobserver using the given semaphore handle. -makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ()) -makeJobserver sem_name = do - semaphore <- openSemaphore sem_name +-- | Create a new jobserver using the given semaphore identifier. +makeJobserver :: SemaphoreIdentifier -> IO (AbstractSem, IO ()) +makeJobserver sem_ident = do + semaphore <- openSemaphore sem_ident >>= either MC.throwM pure let init_jobs = Jobs { tokensOwned = 1 , tokensFree = 1 , jobsWaiting = NilOL + , heldTokens = [] } jobs_tvar <- newTVarIO init_jobs + active_tvar <- newTVarIO Nothing let opts = defaultJobserverOptions -- TODO: allow this to be configured - sjs = Jobserver { jSemaphore = semaphore - , jobs = jobs_tvar } + sjs = Jobserver { jSemaphore = semaphore + , jobs = jobs_tvar + , activeChild = active_tvar } loop_finished_mvar <- newEmptyMVar loop_tid <- forkIOWithUnmask \ unmask -> do r <- try $ unmask $ jobserverLoop opts sjs + -- Always-run exit handler: any child the loop spawned is still alive + -- in its own thread, so drain it before touching jobs_tvar. No one + -- else can mutate the resources once both are dead. + drainActiveChild sjs + releaseAllHeld sjs putMVar loop_finished_mvar $ case r of Left e @@ -467,8 +524,8 @@ makeJobserver sem_name = do acquireSem = acquireJob jobs_tvar releaseSem = releaseJob jobs_tvar cleanupSem = do - -- this is interruptible - cleanupJobserver sjs + -- Trigger the loop's exit handler; it drains the active child and + -- releases all held tokens, then signals loop_finished_mvar. killThread loop_tid mb_ex <- takeMVar loop_finished_mvar for_ mb_ex MC.throwM @@ -477,12 +534,12 @@ makeJobserver sem_name = do -- | Implement an abstract semaphore using a semaphore 'Jobserver' -- which queries the system semaphore of the given name for resources. -runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use +runJSemAbstractSem :: SemaphoreIdentifier -- ^ the semaphore identifier (from @-jsem@) -> (AbstractSem -> IO a) -- ^ the operation to run -- which requires a semaphore -> IO a -runJSemAbstractSem sem action = MC.mask \ unmask -> do - (abs, cleanup) <- makeJobserver sem +runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do + (abs, cleanup) <- makeJobserver sem_ident r <- try $ unmask $ action abs case r of Left (e1 :: MC.SomeException) -> do @@ -517,8 +574,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre is increased, the token is immediately reused (see `modifyJobResources`). The `jobServerLoop` interacts with the system semaphore: when there are pending -jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a -token is obtained, it increases the owned count. +jobs, `acquireThread` forks a child that calls the interruptible +`waitOnSemaphore`. The child is forked in the masked state, so the only place +an async exception can be delivered is the wait itself; once the wait returns, +the child's STM commit always completes, recording either the new token in +`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar) +pair is also published in `activeChild` so the loop's exit handler can drain +the child on shutdown even after the in-loop `JobserverState` is gone. When GHC has free tokens (tokens from the semaphore that it is not using), no pending jobs, and the debounce has expired, then `releaseThread` will @@ -531,6 +593,12 @@ This second token is no longer needed, so we should cancel the wait (as it would not be used to do any work, and not be returned until the debounce). We only need to kill `acquireJob`, because `releaseJob` never blocks. +Shutdown starts with `killThread loop_tid`. The loop's exit handler then +runs `drainActiveChild` followed by `releaseAllHeld`; only then does the +loop signal `loop_finished_mvar`. This sequence makes the heldTokens +snapshot consistent because no other thread can mutate it once the loop and +its child are both dead. + Note [Eventlog Messages for jsem] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be tricky to verify that the work is shared adequately across different @@ -540,3 +608,5 @@ to analyse this output and report statistics about core saturation in the GitHub repo (https://github.com/mpickering/ghc-jsem-analyse) -} + +#endif ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -289,6 +289,8 @@ import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) import GHC.Toolchain import GHC.Toolchain.Program +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion ) + import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -2445,6 +2447,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnUnusableUnpackPragmas -> warnSpec x Opt_WarnPatternNamespaceSpecifier -> warnSpec x Opt_WarnUnrecognisedModifiers -> warnSpec x + Opt_WarnSemaphoreOpenFailure -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups @@ -3628,6 +3631,8 @@ compilerInfo dflags ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make@. ("Support parallel --make", "YES"), + -- The semaphore protocol version supported by @-jsem@. + ("Semaphore version", show (getSemaphoreProtocolVersion semaphoreVersion)), -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in -- installed package info. ("Support reexported-modules", "YES"), ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -403,6 +403,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284 GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599 GhcDiagnosticCode "DriverMissingLinkableForModule" = 47338 + GhcDiagnosticCode "DriverSemaphoreOpenFailure" = 19877 -- Constraint solver diagnostic codes GhcDiagnosticCode "BadTelescope" = 97739 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Types.Hint ( , StarIsType(..) , UntickedPromotedThing(..) , AssumedDerivingStrategy(..) + , SemaphoreUpgradeTarget(..) , SigLike(..) , pprUntickedConstructor, isBareSymbol , suggestExtension @@ -538,6 +539,28 @@ data GhcHint {-| Suggest adding signature to modifier -} | SuggestModifierSignature (HsModifier GhcRn) Name + {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to + support the given semaphore protocol version. + + Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure' + carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'. + -} + | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int + -- ^ The 'Int' is the required protocol version. + +-- | What the user should upgrade to resolve an @-jsem@ semaphore +-- protocol version mismatch. +data SemaphoreUpgradeTarget + = UpgradeCabalInstall + -- ^ Jobserver is @cabal-install@ (we are building a Cabal package) + -- and speaks an older protocol than GHC. + | UpgradeJobserver + -- ^ Jobserver (not @cabal-install@) speaks an older protocol than + -- GHC. + | UpgradeGHC + -- ^ Jobserver speaks a newer protocol than GHC. + deriving (Eq, Show) + -- | The deriving strategy that was assumed when not explicitly listed in the -- source. This is used solely by the missing-deriving-strategies warning. -- There's no `Via` case because we never assume that. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -306,6 +306,20 @@ instance Outputable GhcHint where (text "Perhaps it should have a kind signature, like") 2 (hsep [text "%(" <> ppr ty, text "::", ppr name <> text ")"]) + SuggestUpgradeForSemaphoreVersionMismatch target required + -> case target of + UpgradeCabalInstall -> + text "The cabal-install jobserver uses an older semaphore protocol." + $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") + UpgradeJobserver -> + text "The jobserver uses an older semaphore protocol." + $$ (text "Upgrade it to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") + UpgradeGHC -> + text "The jobserver uses a newer semaphore protocol than this GHC." + $$ (text "Upgrade GHC to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2721,6 +2721,23 @@ of ``-W(no-)*``. f :: a %True -> a g :: a %(k :: Int) -> a +.. ghc-flag:: -Wsemaphore-open-failure + :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore. + :type: dynamic + :reverse: -Wno-semaphore-open-failure + :category: + + :since: 10.0.1 + + Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore + cannot be opened (e.g. the socket does not exist, the protocol + version is incompatible, or a system error occurred). When this + occurs, GHC ignores ``-jsem`` and compiles modules sequentially. + + A common cause is ``cabal-install`` and GHC being built against + different versions of the ``semaphore-compat`` library; upgrading + both to versions that use the same protocol resolves the mismatch. + ---- If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice. ===================================== docs/users_guide/using.rst ===================================== @@ -797,7 +797,12 @@ There are two kinds of participants in the GHC Jobserver protocol: Perform compilation in parallel when possible, coordinating with other processes through the semaphore ⟨sem⟩ (specified as a string). - Error if the semaphore doesn't exist. + + If the semaphore cannot be opened (e.g. the socket does not exist + or its protocol version is incompatible with this GHC), GHC emits + a :ghc-flag:`-Wsemaphore-open-failure` warning and compiles + sequentially, using only the implicit token inherited from the + parent process. Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`, and vice-versa. ===================================== hadrian/src/Flavour.hs ===================================== @@ -149,10 +149,6 @@ werror = -- unix has many unused imports , package unix ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"] - -- semaphore-compat relies on sem_getvalue as provided by unix, which is - -- not implemented on Darwin and therefore throws a deprecation warning - , package semaphoreCompat - ? mconcat [arg "-Wwarn=deprecations"] ] , builder Ghc ? package rts ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1 +Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -21,6 +21,7 @@ [GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode) [GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration) [GHC-66599] is untested (constructor = DriverNoConfiguredLLVMToolchain) +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure) [GHC-81325] is untested (constructor = ExpectingMoreArguments) [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt) [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d21ad32bdd809a1c7dd1d2a1becc2e7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d21ad32bdd809a1c7dd1d2a1becc2e7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/process-bump] libraries/process: bump submodule to v1.6.29.0
by Magnus (＠MangoIV) 25 May '26

25 May '26

Magnus pushed to branch wip/mangoiv/process-bump at Glasgow Haskell Compiler / GHC Commits: adaf0fc5 by mangoiv at 2026-05-25T12:11:53+02:00 libraries/process: bump submodule to v1.6.29.0 This submodule bump resolves a segfault on macos 15. Fixes #27144 - - - - - 1 changed file: - libraries/process Changes: ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 72e5b7c75a17f543262674259b2ebf4a3bda390c +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adaf0fc520d6479d2aa1e66422713e1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adaf0fc520d6479d2aa1e66422713e1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/process-bump] libraries/process: bump submodule
by Magnus (＠MangoIV) 25 May '26

25 May '26

Magnus pushed to branch wip/mangoiv/process-bump at Glasgow Haskell Compiler / GHC Commits: 78d16acc by mangoiv at 2026-05-25T12:07:29+02:00 libraries/process: bump submodule This submodule bump resolves a segfault on macos 15. Fixes #27144 - - - - - 1 changed file: - libraries/process Changes: ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 72e5b7c75a17f543262674259b2ebf4a3bda390c +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78d16accdd40b7d5c2d2865f3a7da0b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78d16accdd40b7d5c2d2865f3a7da0b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/mangoiv/process-bump
by Magnus (＠MangoIV) 25 May '26

25 May '26

Magnus pushed new branch wip/mangoiv/process-bump at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mangoiv/process-bump You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Implement List.elem via foldr
by Marge Bot (＠marge-bot) 25 May '26

25 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 72c8de5c by Simon Jakobi at 2026-05-23T18:41:42-04:00 Implement List.elem via foldr ...in order to allow specialization to Eq instances. The implementation of notElem is updated for consistency.` Corresponding CLC proposal: https://github.com/haskell/core-libraries-committee/issues/412 Addresses #27096. - - - - - 3268c610 by Alan Zimmerman at 2026-05-23T18:42:30-04:00 EPA: Fix span for qualified multiline string Fix the span for a qualified multiline string like Text.""" I'm a multiline Text value ! """ to extend to the end of the entire string, not just the first line. Closes #27274 - - - - - 1f096790 by Alan Zimmerman at 2026-05-23T18:43:20-04:00 EPA: Fix exact printing namespace-specified wildcards Ensures correct printing of imports of the form import Data.Bool (data True(data ..)) import Data.Bool (data True(type ..)) Closes #27291 - - - - - 56ada7c0 by Mrjtjmn at 2026-05-23T18:44:19-04:00 Fix ambiguous syntax of BangPatterns in users guide Update documentation for the BangPatterns extension to specify how surrounding whitespace affects interpretation of `!`. * Only when there is whitespace before `!` and no whitespace after, it is recognized as a BangPattern. * Other cases `⟨varid⟩!⟨varid⟩`, `⟨varid⟩ ! ⟨varid⟩`, `⟨varid⟩! ⟨varid⟩` are treated as infix operators. - - - - - 56cdb867 by Zubin Duggal at 2026-05-25T12:35:45+05:30 Update to semaphore-compat 2.0.0 using v2 of the protocol On Linux and other POSIX platforms, GHC's -jsem jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix domain sockets in place of POSIX named semaphores. This avoids the libc-ABI issues that affected the old implementation. Windows is unaffected and continues to use the v1 protocol (Win32 named semaphores); its reported protocol version remains v1. When GHC receives a -jsem name whose protocol version it does not support, it emits a -Wsemaphore-version-mismatch warning and falls back to -j<N> rather than crashing. ghc --info exposes the supported version in a new "Semaphore version" entry so cabal-install can detect a mismatch before invoking GHC. Users on a cabal-install that predates the v2 update will continue to build successfully on Linux/POSIX, but will lose the cross-process -jsem coordination and fall back to -j<N> per GHC invocation. Users must upgrade to a cabal-install that supports protocol v2 to recover full parallelism. Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot heldTokens and release them before killing the loop, while the loop's in-flight acquire/release children could still be mutating it. Cleanup now runs inside the loop's own exit handler, after draining the active child via a new activeChild TVar, so the snapshot has no concurrent mutator. See also: - GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673 - cabal-install patch: https://github.com/haskell/cabal/pull/11628 - semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8 Bump semaphore-compat submodule to 2.0.0 Fixes #25087 and #27253 - - - - - 10fd4346 by Simon Jakobi at 2026-05-25T05:57:41-04:00 Ensure that SetOps.{minusList,unionListsOrd} can be specialized ...by marking them INLINABLE. Haddock allocates 0.1–0.3% less as a result. This also removes some redundant constraints on unionListsOrd. - - - - - 4d8d8e37 by Cheng Shao at 2026-05-25T05:57:42-04:00 wasm: ensure post-linker output is synchronous ESM This patch fixes wasm backend's post-linker output script to ensure it's synchronous ESM and doesn't use top-level await, which doesn't work in ServiceWorkers. Fixes #27257. - - - - - 31 changed files: - + changelog.d/elem-via-foldr-27096 - + changelog.d/jobserver-leak-fix - + changelog.d/semaphore-v2 - + changelog.d/wasm-fix-serviceworker - compiler/GHC/Data/List/SetOps.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/exts/stolen_syntax.rst - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Flavour.hs - libraries/base/changelog.md - libraries/base/tests/perf/ElemNoFusion_O1.stderr - libraries/base/tests/perf/ElemNoFusion_O2.stderr - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/printer/Makefile - + testsuite/tests/printer/PprQualifiedStrings.hs - + testsuite/tests/printer/Test27291.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/jsffi/prelude.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d050864decf6aa31c8dd000fe0f2b5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d050864decf6aa31c8dd000fe0f2b5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27261] Trim the continuation in mkDupableContWithDmds
by sheaf (＠sheaf) 25 May '26

25 May '26

sheaf pushed to branch wip/T27261 at Glasgow Haskell Compiler / GHC Commits: cebc6fc5 by Simon Peyton Jones at 2026-05-25T11:41:51+02:00 Trim the continuation in mkDupableContWithDmds When there are no remaining argument demands, it means the application is bottoming. In this case, we can trim the continuation to avoid the panic that was observed in #27261. See Note [Trimming the continuation for bottoming functions] in GHC.Core.Opt.Simplify.Iteration. - - - - - 6 changed files: - + changelog.d/T27261 - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + testsuite/tests/simplCore/should_compile/T27261.hs - + testsuite/tests/simplCore/should_compile/T27261_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/T27261 ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27261 +mrs: !16084 +synopsis: + Avoid a crash in ``mkDupableContWithDmds`` when given empty demands +description: + The case of an empty list of remaining argument demands is now explicitly + handled by trimming the simplifier continuation, to avoid a compiler crash + of the form ``Non-exhaustive patterns in dmd : cont_dmds`` or ``expectNonEmpty`` + in ``mkDupableContWithDmds``. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -62,6 +62,7 @@ import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName ) @@ -2444,24 +2445,9 @@ rebuildCall env arg_info _cont ---------- Bottoming applications -------------- rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont + -- When we run out of demands, it means that the call is definitely bottom. + -- See (TC2) in Note [Trimming the continuation for bottoming functions] + = rebuild env (argInfoExpr fun rev_args) (mkBottomCont cont) ---------- Simplify type applications -------------- rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) @@ -4045,6 +4031,41 @@ When we have then we can just duplicate those alts because the A and C cases will disappear immediately. This is more direct than creating join points and inlining them away. See #4930. + +Note [Trimming the continuation for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + f :: Int -> Int -> Int + f x = error "urk" + + foo = f 3 4 + +f's demand signature say "after one arg I return bottom". We can drop +the remaining arguments, thus + + foo = case f 3 of {} + +This trimming can also be done with other continuations: + * case (error "hello") of { ... } + * f (error "Hello") where f is strict + etc + +We implement the trimming in three parts: + +(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds` + with a finite list of elements (in the example above, just one). + + For comparison, note that, for non-bottoming functions, the `RemainingArgDmds` + always finishes with an infinite list of `topDmd`. + +(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the + remaining continuation. + + After discarding the continuation, the types might not match, in which case + we leave behind a (case <hole> of {}) wrapper. See the call to `mkBottomCont`. + +(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when + we run out of `RemainingArgDmds`. -} -------------------- @@ -4079,10 +4100,10 @@ mkDupableCont env cont = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont mkDupableContWithDmds - :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + :: SimplEnvIS -> RemainingArgDmds -> SimplCont -> SimplM ( SimplFloats, SimplCont) -mkDupableContWithDmds env _ cont +mkDupableContWithDmds env remaining_dmds cont -- Check the invariant | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False = pprPanic "mkDupableContWithDmds" empty @@ -4090,6 +4111,13 @@ mkDupableContWithDmds env _ cont | contIsDupable cont = return (emptyFloats env, cont) + -- No more demands => function is definitely bottom + -- => simply trim the continuation + -- c.f. the null-demands case in `rebuildCall` + -- See (TC3) in Note [Trimming the continuation for bottoming functions] + | null remaining_dmds + = return (emptyFloats env, mkBottomCont cont) + mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) @@ -4134,7 +4162,8 @@ mkDupableContWithDmds env _ , thumbsUpPlanA cont = -- Use Plan A of Note [Duplicating StrictArg] -- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $ - do { let _ :| dmds = expectNonEmpty $ ai_dmds fun + do { let _ :| dmds = expectNonEmpty (ai_dmds fun) -- See Invariant of StrictArg; + -- ai_dmds is never empty ; (floats1, cont') <- mkDupableContWithDmds env dmds cont -- Use the demands from the function to add the right -- demand info on any bindings we make for further args @@ -4180,7 +4209,10 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let dmd:|cont_dmds = expectNonEmpty dmds + do { let dmd:|cont_dmds = + -- We took care to handle an empty demand list at the start, + -- ensuring this call to 'expectNonEmpty' does not panic (#27261). + expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco @@ -4251,7 +4283,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty ; let arg_info = ArgInfo { ai_fun = join_bndr , ai_rules = [], ai_args = [] , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } + , ai_discs = Inf.repeat 0 } ; return ( addJoinFloats (emptyFloats env) $ unitJoinFloat $ NonRec join_bndr $ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -25,13 +25,13 @@ module GHC.Core.Opt.Simplify.Utils ( StaticEnv(..), isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, + contIsTrivial, contArgs, contIsRhs, mkBottomCont, hasArgs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, + ArgInfo(..), ArgSpec(..), RemainingArgDmds, mkArgInfo, addValArgTo, addTyArgTo, argInfoExpr, argSpecArg, pushOutArgs, pushArgSpecs, @@ -54,8 +54,10 @@ import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.TyCo.Compare ( eqTypeIgnoringMultiplicity ) import GHC.Core.FVs import GHC.Core.Utils +import GHC.Core.Make( mkWildValBinder ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make @@ -75,6 +77,8 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Name.Env +import GHC.Data.List.Infinite ( Infinite(..) ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -205,10 +209,10 @@ data SimplCont | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] { sc_dup :: DupFlag - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + , sc_fun :: ArgInfo -- Specifies f, e1..en, whether f has rules, etc -- plus demands and discount flags for *this* arg -- and further args - -- So ai_dmds and ai_discs are never empty + -- Invariant: ai_dmds and ai_discs are never empty , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont @@ -348,32 +352,41 @@ doesn't matter because we'll never compute them all. data ArgInfo = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + ai_fun :: OutId, -- ^ The function + ai_args :: [ArgSpec], -- ^ ...applied to these args (which are in *reverse* order) -- NB: all these argumennts are already simplified - ai_rules :: [CoreRule], -- Rules for this function - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args + ai_rules :: [CoreRule], -- ^ Rules for this function + ai_encl :: Bool, + -- ^ Flag saying whether this function or an enclosing one has rules + -- (recursively) + -- + -- @True@ means: be keener to inline in all args - ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args + ai_dmds :: RemainingArgDmds, + -- ^ Demands on remaining value arguments (beyond 'ai_args') - ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) - -- non-zero => be keener to inline - -- Always infinite + ai_discs :: Infinite Int + -- ^ Discounts for remaining value arguments (beyond 'ai_args') + -- + -- A non-zero value means: be keener to inline } -data ArgSpec - = ValArg { as_dmd :: Demand -- Demand placed on this argument - , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) +-- | 'RemainingArgDmds' gives the demands on any remaining value arguments. +-- +-- It is usually infinite (with 'topDmd's in the tail), but if it is finite it +-- guarantees that the function diverges after being applied to that number +-- of arguments. +type RemainingArgDmds = [Demand] - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) +data ArgSpec + -- | A value argument + = ValArg { as_dmd :: Demand -- ^ Demand placed on this argument + , as_arg :: OutExpr -- ^ Apply to this (coercion or value); c.f. 'ApplyToVal' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') + -- | A type argument + | TyArg { as_arg_ty :: OutType -- ^ Apply to this type; c.f. 'ApplyToTy' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') instance Outputable ArgInfo where ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules }) @@ -389,7 +402,7 @@ instance Outputable ArgSpec where addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty - | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = Inf _ discs } <- ai -- Pop the top demand and and discounts off , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } = ai { ai_args = arg_spec : ai_args ai @@ -492,12 +505,23 @@ contIsDupable (TickIt _ k) = contIsDupable k contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k --- This one doesn't look right. A value application is not trivial --- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k contIsTrivial _ = False ------------------- +contStop :: SimplCont -> SimplCont +-- ^ Get the 'Stop' at the tail of the continuation +-- +-- Always returns a continuation of form @(Stop ...)@. +contStop stop@(Stop {}) = stop +contStop (CastIt { sc_cont = k }) = contStop k +contStop (StrictBind { sc_cont = k }) = contStop k +contStop (StrictArg { sc_cont = k }) = contStop k +contStop (Select { sc_cont = k }) = contStop k +contStop (ApplyToTy { sc_cont = k }) = contStop k +contStop (ApplyToVal { sc_cont = k }) = contStop k +contStop (TickIt _ k) = contStop k + contResultType :: SimplCont -> OutType contResultType (Stop ty _ _) = ty contResultType (CastIt { sc_cont = k }) = contResultType k @@ -651,6 +675,35 @@ contEvalContext bndrs cont = go cont -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. +------------------- +mkBottomCont ::SimplCont -> SimplCont +-- ^ Given a continuation `cont`, return a `cont` /of the same type/, +-- looking like @(case \<hole\> of {})@. +-- +-- This is used when we are going to fill in the @<hole>@ with bottom. +-- See (TC2,3) in Note [Trimming the continuation for bottoming functions] +-- +-- Don't bother to trim, making a @case <hole> of {}@, if we have only +-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@. +mkBottomCont cont = go cont + where + go k@(Stop {}) = k + go (TickIt t k') = TickIt t (go k') + go k@(CastIt { sc_cont = k' }) = k { sc_cont = go k' } + go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' } + go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k -- Optimisation only + go k | Stop res_ty _ _ <- stop_cont + , hole_ty `eqTypeIgnoringMultiplicity` res_ty + = stop_cont + | otherwise + = Select { sc_alts = [] + , sc_bndr = mkWildValBinder OneTy hole_ty + , sc_env = Simplified OkDup + , sc_cont = stop_cont } + where + hole_ty = contHoleType k + stop_cont = contStop k + ------------------- mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo mkArgInfo env fun rules_for_fun cont @@ -672,16 +725,17 @@ mkArgInfo env fun rules_for_fun cont fun_has_rules = not (null rules_for_fun) - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 + vanilla_discounts, arg_discounts :: Infinite Int + vanilla_discounts = Inf.repeat 0 arg_discounts = case idUnfolding fun of CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts + -> discounts Inf.++ vanilla_discounts _ -> vanilla_discounts - vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds :: RemainingArgDmds vanilla_dmds = repeat topDmd + arg_dmds :: RemainingArgDmds arg_dmds | not (seInline env) = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] @@ -689,26 +743,22 @@ mkArgInfo env fun rules_for_fun cont = -- add_type_str fun_ty $ case splitDmdSig (idDmdSig fun) of (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isDeadEndDiv result_info then - demands -- Finite => result is bottom - else - demands ++ vanilla_dmds + | not (demands `lengthExceeds` n_val_args) + -> remaining_dmds -- Enough args, use the strictness given. | otherwise -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) <+> ppr n_val_args <+> ppr demands) $ vanilla_dmds -- Not enough args, or no strictness - add_type_strictness :: Type -> [Demand] -> [Demand] - -- If the function arg types are strict, record that in the 'strictness bits' + where + remaining_dmds :: RemainingArgDmds + -- isDeadEndDiv: if remaining_dmds is finite, result is bottom + -- See (TC1) in Note [Trimming the continuation for bottoming functions] + remaining_dmds | isDeadEndDiv result_info = demands + | otherwise = demands ++ vanilla_dmds + + add_type_strictness :: Type -> RemainingArgDmds -> RemainingArgDmds + -- If the function arg /types/ are strict, record that in the RemainingArgDmds -- No need to instantiate because unboxed types (which dominate the strict -- types) can't instantiate type variables. -- add_type_strictness is done repeatedly (for each call); @@ -915,16 +965,16 @@ the incentive to disappear when we inline `f`! lazyArgContext :: ArgInfo -> CallCtxt -- Use this for lazy arguments lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting strictArgContext :: ArgInfo -> CallCtxt strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Use this for strict arguments - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt NonRecursive + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive -- Why RhsCtxt? if we see f (g x), and f is strict, we -- want to be a bit more eager to inline g, because it may -- expose an eval (on x perhaps) that can be eliminated or ===================================== testsuite/tests/simplCore/should_compile/T27261.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-full-laziness #-} + +module T27261 (foo) where + +import T27261_aux (myError) + +foo :: [String] -> (() -> Int) -> Int +foo cs = + \ k -> ( case bar of + Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs } + in myError cs2 str + Nothing -> \ c -> c () ) + ( \ _ -> k () ) + +bar :: Maybe String +bar = Nothing +{-# NOINLINE bar #-} ===================================== testsuite/tests/simplCore/should_compile/T27261_aux.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE BangPatterns #-} + +module T27261_aux (myError) where + +myError :: [String] -> String -> a +myError !_ _ = undefined +{-# NOINLINE myError #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -601,3 +601,4 @@ test('T25718a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cebc6fc598a90471c6a563fdd65eafd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cebc6fc598a90471c6a563fdd65eafd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][ghc-9.12] 22 commits: testsuite: mark T22159 as fragile
by Magnus (＠MangoIV) 25 May '26

25 May '26

Magnus pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC Commits: 12988118 by Cheng Shao at 2026-05-13T13:47:34+02:00 testsuite: mark T22159 as fragile This patch marks T22159 as fragile on Windows for issue described in #27248. Before we get to the bottom of those failures, this unblocks newer Windows runners. (cherry picked from commit 4392aa200fcd336154f58764488a798ba3f57701) - - - - - c0b9c162 by Zubin Duggal at 2026-05-13T18:51:34+02:00 DmdAnal: Take stable unfoldings into account when determining argument demands Previously, demand analysis only looked at the RHS to compute argument demands. If the optimised RHS discarded uses of an argument that the stable unfolding still needed, it would be incorrectly marked absent. Worker/wrapper would then replace it with LitRubbish, and inlining the stable unfolding would use the rubbish value, causing a segfault. To fix, we introduce addUnfoldingDemands which analyses the stable unfolding with dmdAnal and combines its DmdType with the RHS's via the new `maxDmdType` which combines the demands of the stable unfolding with the rhs, so we can avoid any situation where we give an absent demand to something which is still used by the stable unfolding. Fixes #26416. (cherry picked from commit 870243e4f2a24730539f01ee8e3f3949c42ff312) - - - - - 5b5aac16 by Simon Jakobi at 2026-05-14T16:19:04+02:00 Fix -dsuppress-uniques for free variables in demand signatures Before: Str=b{sXyZ->S} With this patch: Str=b{S} T13143.stderr is updated accordingly. Fixes #27106. (cherry picked from commit 5b82080a3f3dd476e198130218d4da729fb5334a) - - - - - 2aacc599 by Andreas Klebinger at 2026-05-20T11:51:11+02:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 (cherry picked from commit 63ae8eb38c54eaba77949b048a3621a5f4ca76e3) - - - - - 0acea5fa by Luite Stegeman at 2026-05-20T11:51:13+02:00 bytecode: Carefully SLIDE off the end of a stack chunk The SLIDE bytecode instruction was not checking for stack chunk boundaries and could corrupt the stack underflow frame, leading to crashes. We add a check to use safe writes if we cross the chunk boundary and also handle stack underflow if Sp is advanced past the underflow frame. fix #27001 (cherry picked from commit 72b20fc0ad4b6ad12c67f686af5cb42700656886) - - - - - b2e91dc8 by Andreas Klebinger at 2026-05-20T11:51:13+02:00 Configure: Fix check for --target support in stage0 CC The check FP_PROG_CC_LINKER_TARGET used $CC unconditionally to check for --target support. However this fails for the stage0 config where the C compiler used is not $CC but $CC_STAGE0. Since we already pass the compiler under test into the macro I simply changed it to use that instead. Fixes #26999 (cherry picked from commit 43638643adbe999de8d2288a40bdd15c602f6481) - - - - - 682654f0 by Ian Duncan at 2026-05-20T11:51:14+02:00 AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written MOVK (move with keep) modifies only a 16-bit slice of the destination register, so the destination is both read and written. The register allocator must know this to avoid clobbering live values. Update regUsageOfInstr to list the destination in both src and dst sets. No regression test: triggering the misallocation requires specific register pressure around a MOVK sequence, which is difficult to reliably provoke from Haskell source. (cherry picked from commit 2823b03966e495581f4695f07649c5885306b656) - - - - - a50fabdf by Zubin Duggal at 2026-05-20T11:51:14+02:00 compiler/ffi: Collapse void pointer chains in capi wrappers New gcc/clang treat -Wincompatible-pointer-types as an error by default. Since C only allows implicit conversion from void*, not void**, capi wrappers for functions taking e.g. abstract** would fail to compile when the Haskell type Ptr (Ptr Abstract) was naively translated to void**. Collapse nested void pointers to a single void* when the pointee type has no known C representation. Fixes #26852 (cherry picked from commit 80e2dd4f084eff9cc857b31daf9ea2e9e460c727) - - - - - b62022a9 by Zubin Duggal at 2026-05-20T11:51:14+02:00 hadrian: Don't include the package hash in the haddock directory Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html` The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not part of a standard cabal substitution. Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it. Fixes #26635 (cherry picked from commit 07267f79d91169f474cacc8bcd38d76a6e97887d) - - - - - 0f95ad43 by ARATA Mizuki at 2026-05-20T11:51:14+02:00 rts: Align stack to 64-byte boundary in StgRun on x86 When LLVM spills AVX/AVX-512 vector registers to the stack, it requires 32-byte (__m256) or 64-byte (__m512) alignment. If the stack is not sufficiently aligned, LLVM inserts a realignment prologue that reserves %rbp as a frame pointer, conflicting with GHC's use of %rbp as an STG callee-saved register and breaking the tail-call-based calling convention. Previously, GHC worked around this by lying to LLVM about the stack alignment and rewriting aligned vector loads/stores (VMOVDQA, VMOVAPS) to unaligned ones (VMOVDQU, VMOVUPS) in the LLVM Mangler. This had two problems: - It did not extend to AVX-512, which requires 64-byte alignment. (#26595) - When Haskell calls a C function that takes __m256/__m512 arguments on the stack, the callee requires genuine alignment, which could cause a segfault. (#26822) This patch genuinely aligns the stack to 64 bytes in StgRun by saving the original stack pointer before alignment and restoring it in StgReturn. We now unconditionally advertise 64-byte stack alignment to LLVM for all x86 targets, making rewriteAVX in the LLVM Mangler unnecessary. STG_RUN_STACK_FRAME_SIZE is increased from 48 to 56 bytes on non-Windows x86-64 to store the saved stack pointer. Closes #26595 and #26822 Co-Authored-By: Claude Opus 4.5 <noreply(a)anthropic.com> (cherry picked from commit a5ec467ee3d4e77c026437a545981269acde3434) - - - - - 6726c914 by Wen Kokke at 2026-05-20T11:51:14+02:00 Fix race condition between flushEventLog and start/endEventLogging. This commit changes `flushEventLog` to acquire/release the `state_change` mutex to prevent interleaving with `startEventLogging` and `endEventLogging`. In the current RTS, `flushEventLog` _does not_ acquire this mutex, which may lead to eventlog corruption on the following interleaving: - `startEventLogging` writes the new `EventLogWriter` to `event_log_writer`. - `flushEventLog` flushes some events to `event_log_writer`. - `startEventLogging` writes the eventlog header to `event_log_writer`. This causes the eventlog to be written out in an unreadable state, with one or more events preceding the eventlog header. This commit renames the old function to `flushEventLog_` and defines `flushEventLog` simply as: ```c void flushEventLog(Capability **cap USED_IF_THREADS) { ACQUIRE_LOCK(&state_change_mutex); flushEventLog_(cap); RELEASE_LOCK(&state_change_mutex); } ``` The old function is still needed internally within the compilation unit, where it is used in `endEventLogging` in a context where the `state_change` mutex has already been acquired. I've chosen to mark `flushEventLog_` as static and let other uses of `flushEventLog` within the RTS refer to the new version. There is one use in `hs_init_ghc` via `flushTrace`, where the new locking behaviour should be harmless, and one use in `handle_tick`, which I believe was likely vulnerable to the same race condition, so the new locking behaviour is desirable. I have not added a test. The behaviour is highly non-deterministic and requires a program that concurrently calls `flushEventLog` and `startEventLogging`/`endEventLogging`. I encountered the issue while developing `eventlog-socket` and within that context have verified that my patch likely addresses the issue: a test that used to fail within the first dozen or so runs now has been running on repeat for several hours. (cherry picked from commit 3d6492ce311611707e80b2594103ddbe93fc6c76) - - - - - d99bb8e1 by mangoiv at 2026-05-20T14:52:56+02:00 rts: cast Sp_plusW to StgPtr to appease gcc - - - - - 8fde70d7 by mangoiv at 2026-05-20T14:52:56+02:00 rts: disable out of bounds array warning for sometimes inlined rts function - - - - - 1957e964 by Duncan Coutts at 2026-05-22T15:48:38+02:00 Handle heap allocation failure in I/O primops The current I/O managers do not use allocateMightFail, but future ones will. To support this properly we need to be able to return to the primop with a failure. We simply use a bool return value. Currently however, we will just throw an exception rather than calling the GC because that's what all the other primops do too. For the general issue of primops invoking GC and retrying, see https://gitlab.haskell.org/ghc/ghc/-/issues/24105 (cherry picked from commit 62ae97de67f8cc59fc702e26a9e29eda1f84d461) - - - - - 789790d2 by Luite Stegeman at 2026-05-22T15:48:38+02:00 Windows: remove StgAsyncIOResult and fix crash/leaks In stg_block_async{_void}, a stack slot was reserved for an StgAsyncIOResult. This slot would be filled by the IO manager upon completion of the async call. However, if the blocked thread was interrupted by an async exception, we would end up in an invalid state: - If the blocked computation was never re-entered, the StgAsyncIOResult would never be freed. - If the blocked computation was re-entered, the thread would find an unitialized stack slot for the StgAsyncIOResult, leading to a crash reading its fields, or freeing the pointer. We fix this by removing the StgAsyncIOResult altogether and writing the result directly to the stack. Fixes #26341 (cherry picked from commit fcf092dda534cc38637d1f7920aa0dae58fe5273) - - - - - 716a1340 by Brian J. Cardiff at 2026-05-22T15:48:38+02:00 configure: Accept happy-2.2 In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build (cherry picked from commit 4f2840f2bb729ef1a6660f9f5c46906b7b838147) - - - - - 1cbf9aed by sheaf at 2026-05-22T15:48:38+02:00 Careful with ticked join points in mergeCaseAlts This commit backports the fix to GHC.Core.Utils.mergeCaseAlts that was carried out in f726fcc4fb0b59f8ad2e2fa80f1b03efdaf73c30. That is, this commit addresses the regression that was introduced by e026bdf275e287005f2c2e534d3ba034ebf11c01, which allowed mergeCaseAlts to move ticks in between a join point and one of its jumps, which results in disaster (see #26929 but also #26642, #26693). See (MC6) in Note [Merge Nested Cases] for a detailed explanation. (cherry picked from commit 08bc245be70d95801bc1138804ed1de9474fbdc0) (cherry picked from commit 974586eb5b6a924e8ce3ea8c4b2180ea9c0f3801) - - - - - 30d967d8 by Zubin Duggal at 2026-05-22T15:48:38+02:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 (cherry picked from commit bc4b44870d096d43e8cbc530da1fd613d9e4514f) - - - - - 0ccecfc5 by mangoiv at 2026-05-22T15:48:38+02:00 profiling: partial backport of 2dadf3b0 to fix #27121 This backports fix and test for #27121 from 2dadf3b0 since the entirety of the patch is not backportable without also backporting two larger refactorings. - - - - - 26da4dd4 by sheaf at 2026-05-22T15:48:38+02:00 Deal with 'noSpec' in 'coreExprToPmLit' This commit makes two separate changes relating to 'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit': 1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical, which led to the introduction of 'nospec' wrappers in the generated Core. This reverts that accident by declaring deferred errors as being canonical, avoiding spurious 'nospec' wrapping. 2. Look through magic identity-like Ids such as 'nospec', 'inline' and 'lazy' in 'coreExprAsPmLit', just like Core Prep does. There might genuinely be incoherent evidence, but that shouldn't obstruct the pattern match checker. See test T27124a. Fixes #25926 #27124 ------------------------- Metric Decrease: T3294 ------------------------- (cherry picked from commit e8a196c65cee32f06c3d99b74af33457511408c7) - - - - - ba7b8b5d by Luite Stegeman at 2026-05-22T15:48:38+02:00 CodeOutput: Fix finalizers on multiple platforms - ELF platforms: emit .fini_array section - wasm32/Darwin: emit initializer with __cxa_atexit call - Windows: use -Wl,--whole-archive to prevent dropping finalizer symbols - rts linker: fix crash/assertion failure unloading objects with finalizers fixes #27072 (cherry picked from commit 014087e7a5753687161a24a1b2bc55c7bf7273fd) - - - - - c18b40a6 by Luite Stegeman at 2026-05-22T15:48:38+02:00 rts: add a few missing i386 relocations in the rts linker (cherry picked from commit 04d143c02e82e9ca03eb75849959d369d07fb81a) - - - - - 110 changed files: - + changelog.d/T27124.md - + changelog.d/fix-finalizers-27072 - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Config.hs - compiler/GHC/CmmToLlvm/Mangler.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Config/CmmToLlvm.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/ForeignStubs.hs - hadrian/bindist/Makefile - hadrian/src/CommandLine.hs - hadrian/src/Context.hs - hadrian/src/Settings/Builders/Cabal.hs - m4/fp_prog_cc_linker_target.m4 - m4/fptools_happy.m4 - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/IOManager.h - rts/Interpreter.c - rts/Linker.c - rts/LinkerInternals.h - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/StgCRun.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/eventlog/EventLog.c - rts/include/rts/Constants.h - rts/include/rts/storage/ClosureMacros.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/linker/Elf.c - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - + testsuite/tests/bytecode/T27001.hs - + testsuite/tests/bytecode/T27001.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/codeGen/should_run/T27072d.hs - + testsuite/tests/codeGen/should_run/T27072d.stdout - + testsuite/tests/codeGen/should_run/T27072d_c.c - + testsuite/tests/codeGen/should_run/T27072d_check.c - + testsuite/tests/codeGen/should_run/T27072w.hs - + testsuite/tests/codeGen/should_run/T27072w.stdout - + testsuite/tests/codeGen/should_run/T27072w_c.c - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/concurrent/should_run/T26341.hs - + testsuite/tests/concurrent/should_run/T26341.stdout - + testsuite/tests/concurrent/should_run/T26341a.hs - + testsuite/tests/concurrent/should_run/T26341a.stdout - + testsuite/tests/concurrent/should_run/T26341b.hs - + testsuite/tests/concurrent/should_run/T26341b.stdout - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/dmdanal/should_compile/T13143.stderr - testsuite/tests/dmdanal/should_compile/T18894.stderr - + testsuite/tests/dmdanal/should_compile/T27106.hs - + testsuite/tests/dmdanal/should_compile/T27106.stderr - testsuite/tests/dmdanal/should_compile/all.T - + testsuite/tests/dmdanal/should_run/M1.hs - + testsuite/tests/dmdanal/should_run/T26416.hs - + testsuite/tests/dmdanal/should_run/T26416.stdout - testsuite/tests/dmdanal/should_run/all.T - testsuite/tests/dmdanal/sigs/T21081.stderr - + testsuite/tests/ffi/should_compile/T26852.h - + testsuite/tests/ffi/should_compile/T26852.hs - + testsuite/tests/ffi/should_compile/T26852.stderr - testsuite/tests/ffi/should_compile/all.T - testsuite/tests/ffi/should_run/all.T - + testsuite/tests/overloadedstrings/should_fail/T25926.hs - + testsuite/tests/overloadedstrings/should_fail/T25926.stderr - + testsuite/tests/overloadedstrings/should_fail/T27124.hs - + testsuite/tests/overloadedstrings/should_fail/T27124.stderr - + testsuite/tests/overloadedstrings/should_fail/all.T - + testsuite/tests/overloadedstrings/should_run/T27124a.hs - testsuite/tests/overloadedstrings/should_run/all.T - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/rts/linker/T27072/Lib.c - + testsuite/tests/rts/linker/T27072/Makefile - + testsuite/tests/rts/linker/T27072/T27072.stdout - + testsuite/tests/rts/linker/T27072/all.T - + testsuite/tests/rts/linker/T27072/main.c - + testsuite/tests/simd/should_run/StackAlignment32.hs - + testsuite/tests/simd/should_run/StackAlignment32.stdout - + testsuite/tests/simd/should_run/StackAlignment32_main.c - + testsuite/tests/simd/should_run/StackAlignment64.hs - + testsuite/tests/simd/should_run/StackAlignment64.stdout - + testsuite/tests/simd/should_run/StackAlignment64_main.c - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26642.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/all.T - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5846d4f91f85b0776f6fb71f62d252… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5846d4f91f85b0776f6fb71f62d252… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27261] Trim the continuation in mkDupableContWithDmds
by sheaf (＠sheaf) 25 May '26

25 May '26

sheaf pushed to branch wip/T27261 at Glasgow Haskell Compiler / GHC Commits: 56d6e3bb by Simon Peyton Jones at 2026-05-25T11:33:08+02:00 Trim the continuation in mkDupableContWithDmds When there are no remaining argument demands, it means the application is bottoming. In this case, we can trim the continuation to avoid the panic that was observed in #27261. See Note [Trimming the continuation for bottoming functions] in GHC.Core.Opt.Simplify.Iteration. - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + testsuite/tests/simplCore/should_compile/T27261.hs - + testsuite/tests/simplCore/should_compile/T27261_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -62,6 +62,7 @@ import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName ) @@ -2444,24 +2445,9 @@ rebuildCall env arg_info _cont ---------- Bottoming applications -------------- rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont + -- When we run out of demands, it means that the call is definitely bottom. + -- See (TC2) in Note [Trimming the continuation for bottoming functions] + = rebuild env (argInfoExpr fun rev_args) (mkBottomCont cont) ---------- Simplify type applications -------------- rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) @@ -4045,6 +4031,41 @@ When we have then we can just duplicate those alts because the A and C cases will disappear immediately. This is more direct than creating join points and inlining them away. See #4930. + +Note [Trimming the continuation for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + f :: Int -> Int -> Int + f x = error "urk" + + foo = f 3 4 + +f's demand signature say "after one arg I return bottom". We can drop +the remaining arguments, thus + + foo = case f 3 of {} + +This trimming can also be done with other continuations: + * case (error "hello") of { ... } + * f (error "Hello") where f is strict + etc + +We implement the trimming in three parts: + +(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds` + with a finite list of elements (in the example above, just one). + + For comparison, note that, for non-bottoming functions, the `RemainingArgDmds` + always finishes with an infinite list of `topDmd`. + +(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the + remaining continuation. + + After discarding the continuation, the types might not match, in which case + we leave behind a (case <hole> of {}) wrapper. See the call to `mkBottomCont`. + +(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when + we run out of `RemainingArgDmds`. -} -------------------- @@ -4079,10 +4100,10 @@ mkDupableCont env cont = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont mkDupableContWithDmds - :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + :: SimplEnvIS -> RemainingArgDmds -> SimplCont -> SimplM ( SimplFloats, SimplCont) -mkDupableContWithDmds env _ cont +mkDupableContWithDmds env remaining_dmds cont -- Check the invariant | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False = pprPanic "mkDupableContWithDmds" empty @@ -4090,6 +4111,13 @@ mkDupableContWithDmds env _ cont | contIsDupable cont = return (emptyFloats env, cont) + -- No more demands => function is definitely bottom + -- => simply trim the continuation + -- c.f. the null-demands case in `rebuildCall` + -- See (TC3) in Note [Trimming the continuation for bottoming functions] + | null remaining_dmds + = return (emptyFloats env, mkBottomCont cont) + mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) @@ -4134,7 +4162,8 @@ mkDupableContWithDmds env _ , thumbsUpPlanA cont = -- Use Plan A of Note [Duplicating StrictArg] -- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $ - do { let _ :| dmds = expectNonEmpty $ ai_dmds fun + do { let _ :| dmds = expectNonEmpty (ai_dmds fun) -- See Invariant of StrictArg; + -- ai_dmds is never empty ; (floats1, cont') <- mkDupableContWithDmds env dmds cont -- Use the demands from the function to add the right -- demand info on any bindings we make for further args @@ -4180,7 +4209,10 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let dmd:|cont_dmds = expectNonEmpty dmds + do { let dmd:|cont_dmds = + -- We took care to handle an empty demand list at the start, + -- ensuring this call to 'expectNonEmpty' does not panic (#27261). + expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco @@ -4251,7 +4283,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty ; let arg_info = ArgInfo { ai_fun = join_bndr , ai_rules = [], ai_args = [] , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } + , ai_discs = Inf.repeat 0 } ; return ( addJoinFloats (emptyFloats env) $ unitJoinFloat $ NonRec join_bndr $ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -25,13 +25,13 @@ module GHC.Core.Opt.Simplify.Utils ( StaticEnv(..), isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, + contIsTrivial, contArgs, contIsRhs, mkBottomCont, hasArgs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, + ArgInfo(..), ArgSpec(..), RemainingArgDmds, mkArgInfo, addValArgTo, addTyArgTo, argInfoExpr, argSpecArg, pushOutArgs, pushArgSpecs, @@ -54,8 +54,10 @@ import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.TyCo.Compare ( eqTypeIgnoringMultiplicity ) import GHC.Core.FVs import GHC.Core.Utils +import GHC.Core.Make( mkWildValBinder ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make @@ -75,6 +77,8 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Name.Env +import GHC.Data.List.Infinite ( Infinite(..) ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -205,10 +209,10 @@ data SimplCont | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] { sc_dup :: DupFlag - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + , sc_fun :: ArgInfo -- Specifies f, e1..en, whether f has rules, etc -- plus demands and discount flags for *this* arg -- and further args - -- So ai_dmds and ai_discs are never empty + -- Invariant: ai_dmds and ai_discs are never empty , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont @@ -348,32 +352,41 @@ doesn't matter because we'll never compute them all. data ArgInfo = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + ai_fun :: OutId, -- ^ The function + ai_args :: [ArgSpec], -- ^ ...applied to these args (which are in *reverse* order) -- NB: all these argumennts are already simplified - ai_rules :: [CoreRule], -- Rules for this function - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args + ai_rules :: [CoreRule], -- ^ Rules for this function + ai_encl :: Bool, + -- ^ Flag saying whether this function or an enclosing one has rules + -- (recursively) + -- + -- @True@ means: be keener to inline in all args - ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args + ai_dmds :: RemainingArgDmds, + -- ^ Demands on remaining value arguments (beyond 'ai_args') - ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) - -- non-zero => be keener to inline - -- Always infinite + ai_discs :: Infinite Int + -- ^ Discounts for remaining value arguments (beyond 'ai_args') + -- + -- A non-zero value means: be keener to inline } -data ArgSpec - = ValArg { as_dmd :: Demand -- Demand placed on this argument - , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) +-- | 'RemainingArgDmds' gives the demands on any remaining value arguments. +-- +-- It is usually infinite (with 'topDmd's in the tail), but if it is finite it +-- guarantees that the function diverges after being applied to that number +-- of arguments. +type RemainingArgDmds = [Demand] - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) +data ArgSpec + -- | A value argument + = ValArg { as_dmd :: Demand -- ^ Demand placed on this argument + , as_arg :: OutExpr -- ^ Apply to this (coercion or value); c.f. 'ApplyToVal' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') + -- | A type argument + | TyArg { as_arg_ty :: OutType -- ^ Apply to this type; c.f. 'ApplyToTy' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') instance Outputable ArgInfo where ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules }) @@ -389,7 +402,7 @@ instance Outputable ArgSpec where addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty - | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = Inf _ discs } <- ai -- Pop the top demand and and discounts off , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } = ai { ai_args = arg_spec : ai_args ai @@ -492,12 +505,23 @@ contIsDupable (TickIt _ k) = contIsDupable k contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k --- This one doesn't look right. A value application is not trivial --- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k contIsTrivial _ = False ------------------- +contStop :: SimplCont -> SimplCont +-- ^ Get the 'Stop' at the tail of the continuation +-- +-- Always returns a continuation of form @(Stop ...)@. +contStop stop@(Stop {}) = stop +contStop (CastIt { sc_cont = k }) = contStop k +contStop (StrictBind { sc_cont = k }) = contStop k +contStop (StrictArg { sc_cont = k }) = contStop k +contStop (Select { sc_cont = k }) = contStop k +contStop (ApplyToTy { sc_cont = k }) = contStop k +contStop (ApplyToVal { sc_cont = k }) = contStop k +contStop (TickIt _ k) = contStop k + contResultType :: SimplCont -> OutType contResultType (Stop ty _ _) = ty contResultType (CastIt { sc_cont = k }) = contResultType k @@ -651,6 +675,35 @@ contEvalContext bndrs cont = go cont -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. +------------------- +mkBottomCont ::SimplCont -> SimplCont +-- ^ Given a continuation `cont`, return a `cont` /of the same type/, +-- looking like @(case \<hole\> of {})@. +-- +-- This is used when we are going to fill in the @<hole>@ with bottom. +-- See (TC2,3) in Note [Trimming the continuation for bottoming functions] +-- +-- Don't bother to trim, making a @case <hole> of {}@, if we have only +-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@. +mkBottomCont cont = go cont + where + go k@(Stop {}) = k + go (TickIt t k') = TickIt t (go k') + go k@(CastIt { sc_cont = k' }) = k { sc_cont = go k' } + go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' } + go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k -- Optimisation only + go k | Stop res_ty _ _ <- stop_cont + , hole_ty `eqTypeIgnoringMultiplicity` res_ty + = stop_cont + | otherwise + = Select { sc_alts = [] + , sc_bndr = mkWildValBinder OneTy hole_ty + , sc_env = Simplified OkDup + , sc_cont = stop_cont } + where + hole_ty = contHoleType k + stop_cont = contStop k + ------------------- mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo mkArgInfo env fun rules_for_fun cont @@ -672,16 +725,17 @@ mkArgInfo env fun rules_for_fun cont fun_has_rules = not (null rules_for_fun) - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 + vanilla_discounts, arg_discounts :: Infinite Int + vanilla_discounts = Inf.repeat 0 arg_discounts = case idUnfolding fun of CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts + -> discounts Inf.++ vanilla_discounts _ -> vanilla_discounts - vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds :: RemainingArgDmds vanilla_dmds = repeat topDmd + arg_dmds :: RemainingArgDmds arg_dmds | not (seInline env) = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] @@ -689,26 +743,22 @@ mkArgInfo env fun rules_for_fun cont = -- add_type_str fun_ty $ case splitDmdSig (idDmdSig fun) of (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isDeadEndDiv result_info then - demands -- Finite => result is bottom - else - demands ++ vanilla_dmds + | not (demands `lengthExceeds` n_val_args) + -> remaining_dmds -- Enough args, use the strictness given. | otherwise -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) <+> ppr n_val_args <+> ppr demands) $ vanilla_dmds -- Not enough args, or no strictness - add_type_strictness :: Type -> [Demand] -> [Demand] - -- If the function arg types are strict, record that in the 'strictness bits' + where + remaining_dmds :: RemainingArgDmds + -- isDeadEndDiv: if remaining_dmds is finite, result is bottom + -- See (TC1) in Note [Trimming the continuation for bottoming functions] + remaining_dmds | isDeadEndDiv result_info = demands + | otherwise = demands ++ vanilla_dmds + + add_type_strictness :: Type -> RemainingArgDmds -> RemainingArgDmds + -- If the function arg /types/ are strict, record that in the RemainingArgDmds -- No need to instantiate because unboxed types (which dominate the strict -- types) can't instantiate type variables. -- add_type_strictness is done repeatedly (for each call); @@ -915,16 +965,16 @@ the incentive to disappear when we inline `f`! lazyArgContext :: ArgInfo -> CallCtxt -- Use this for lazy arguments lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting strictArgContext :: ArgInfo -> CallCtxt strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Use this for strict arguments - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt NonRecursive + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive -- Why RhsCtxt? if we see f (g x), and f is strict, we -- want to be a bit more eager to inline g, because it may -- expose an eval (on x perhaps) that can be eliminated or ===================================== testsuite/tests/simplCore/should_compile/T27261.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-full-laziness #-} + +module T27261 (foo) where + +import T27261_aux (myError) + +foo :: [String] -> (() -> Int) -> Int +foo cs = + \ k -> ( case bar of + Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs } + in myError cs2 str + Nothing -> \ c -> c () ) + ( \ _ -> k () ) + +bar :: Maybe String +bar = Nothing +{-# NOINLINE bar #-} ===================================== testsuite/tests/simplCore/should_compile/T27261_aux.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE BangPatterns #-} + +module T27261_aux (myError) where + +myError :: [String] -> String -> a +myError !_ _ = undefined +{-# NOINLINE myError #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -601,3 +601,4 @@ test('T25718a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56d6e3bb1d438b880c2d1a255f82dd6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56d6e3bb1d438b880c2d1a255f82dd6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/set-ops] Ensure that SetOps.{minusList,unionListsOrd} can be specialized
by Simon Jakobi (＠sjakobi2) 25 May '26

25 May '26

Simon Jakobi pushed to branch wip/sjakobi/set-ops at Glasgow Haskell Compiler / GHC Commits: 092fcbbe by Simon Jakobi at 2026-05-25T09:06:36+02:00 Ensure that SetOps.{minusList,unionListsOrd} can be specialized ...by marking them INLINABLE. Haddock allocates 0.1–0.3% less as a result. This also removes some redundant constraints on unionListsOrd. - - - - - 1 changed file: - compiler/GHC/Data/List/SetOps.hs Changes: ===================================== compiler/GHC/Data/List/SetOps.hs ===================================== @@ -60,12 +60,13 @@ getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $ -- -- Uses a set internally to record duplicates. This makes it slightly slower for -- very small lists but avoids quadratic behaviour for large lists. -unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a] +unionListsOrd :: Ord a => [a] -> [a] -> [a] unionListsOrd xs ys - -- Since both arguments don't have internal duplicates we can just take all of xs - -- and every element of ys that's not already in xs. + -- Since both arguments don't have internal duplicates we can just take all of ys + -- and every element of xs that's not already in ys. = let set_ys = S.fromList ys in (filter (\e -> not $ S.member e set_ys) xs) ++ ys +{-# INLINABLE unionListsOrd #-} -- Ensure the function can be specialized. -- | Assumes that the arguments contain no duplicates unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] @@ -108,6 +109,7 @@ minusList xs [y] = filter (/= y) xs minusList xs ys = filter (`S.notMember` yss) xs where yss = S.fromList ys +{-# INLINABLE minusList #-} -- Ensure the function can be specialized. {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/092fcbbe8965e7f89b75a5e78469596… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/092fcbbe8965e7f89b75a5e78469596… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/semaphore-v2] 8 commits: Use "grimily" instead of "grimly"
by Zubin (＠wz1000) 25 May '26

25 May '26

Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC Commits: 6f9d7c71 by Markus Läll at 2026-05-21T15:25:34-04:00 Use "grimily" instead of "grimly" Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221 - - - - - 50e999ca by fendor at 2026-05-21T15:26:18-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. - - - - - 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. - - - - - 72c8de5c by Simon Jakobi at 2026-05-23T18:41:42-04:00 Implement List.elem via foldr ...in order to allow specialization to Eq instances. The implementation of notElem is updated for consistency.` Corresponding CLC proposal: https://github.com/haskell/core-libraries-committee/issues/412 Addresses #27096. - - - - - 3268c610 by Alan Zimmerman at 2026-05-23T18:42:30-04:00 EPA: Fix span for qualified multiline string Fix the span for a qualified multiline string like Text.""" I'm a multiline Text value ! """ to extend to the end of the entire string, not just the first line. Closes #27274 - - - - - 1f096790 by Alan Zimmerman at 2026-05-23T18:43:20-04:00 EPA: Fix exact printing namespace-specified wildcards Ensures correct printing of imports of the form import Data.Bool (data True(data ..)) import Data.Bool (data True(type ..)) Closes #27291 - - - - - 56ada7c0 by Mrjtjmn at 2026-05-23T18:44:19-04:00 Fix ambiguous syntax of BangPatterns in users guide Update documentation for the BangPatterns extension to specify how surrounding whitespace affects interpretation of `!`. * Only when there is whitespace before `!` and no whitespace after, it is recognized as a BangPattern. * Other cases `⟨varid⟩!⟨varid⟩`, `⟨varid⟩ ! ⟨varid⟩`, `⟨varid⟩! ⟨varid⟩` are treated as infix operators. - - - - - 56cdb867 by Zubin Duggal at 2026-05-25T12:35:45+05:30 Update to semaphore-compat 2.0.0 using v2 of the protocol On Linux and other POSIX platforms, GHC's -jsem jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix domain sockets in place of POSIX named semaphores. This avoids the libc-ABI issues that affected the old implementation. Windows is unaffected and continues to use the v1 protocol (Win32 named semaphores); its reported protocol version remains v1. When GHC receives a -jsem name whose protocol version it does not support, it emits a -Wsemaphore-version-mismatch warning and falls back to -j<N> rather than crashing. ghc --info exposes the supported version in a new "Semaphore version" entry so cabal-install can detect a mismatch before invoking GHC. Users on a cabal-install that predates the v2 update will continue to build successfully on Linux/POSIX, but will lose the cross-process -jsem coordination and fall back to -j<N> per GHC invocation. Users must upgrade to a cabal-install that supports protocol v2 to recover full parallelism. Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot heldTokens and release them before killing the loop, while the loop's in-flight acquire/release children could still be mutating it. Cleanup now runs inside the loop's own exit handler, after draining the active child via a new activeChild TVar, so the snapshot has no concurrent mutator. See also: - GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673 - cabal-install patch: https://github.com/haskell/cabal/pull/11628 - semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8 Bump semaphore-compat submodule to 2.0.0 Fixes #25087 and #27253 - - - - - 43 changed files: - + changelog.d/elem-via-foldr-27096 - + changelog.d/ghc-pkg-faster-closure - + changelog.d/jobserver-leak-fix - + changelog.d/semaphore-v2 - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/Supply.hs - docs/users_guide/exts/stolen_syntax.rst - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Flavour.hs - libraries/base/changelog.md - libraries/base/tests/perf/ElemNoFusion_O1.stderr - libraries/base/tests/perf/ElemNoFusion_O2.stderr - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/ghc-api/T27273.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/PprQualifiedStrings.hs - + testsuite/tests/printer/Test27291.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/ghc-pkg/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1170e99240b04e9e4013d31ccea9f8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1170e99240b04e9e4013d31ccea9f8… You're receiving this email because of your account on gitlab.haskell.org.

1 0