May 2026 - ghc-commits

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Trim the continuation in mkDupableContWithDmds
by Marge Bot (＠marge-bot) 27 May '26

27 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: bb2925e6 by Simon Peyton Jones at 2026-05-27T00:40:42-04: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. - - - - - 2a5a3a4f by Cheng Shao at 2026-05-27T00:40:43-04:00 ghci: fix module name string lifetime in hs_hpc_module invocation This patch makes hpcAddModule pass a properly malloced module name string to hs_hpc_module, instead of using useAsCString which causes use-after-free of module name string. Fixes #27297. Co-authored-by: Codex <codex(a)openai.com> - - - - - f716714b by sheaf at 2026-05-27T00:40:43-04:00 Relax acceptance threshold for T10421 As seen in #27289, the 1% acceptance threshold for this text was overly narrow, resulting in spurious test failures. This commit widens the acceptance threshold to 2%. Fixes #27289. - - - - - 11 changed files: - + changelog.d/T27261 - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + libraries/ghc-boot/GHC/Data/ShortByteString.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/perf/compiler/all.T - + 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 ===================================== libraries/ghc-boot/GHC/Data/ShortByteString.hs ===================================== @@ -0,0 +1,17 @@ +module GHC.Data.ShortByteString + ( newCStringFromSBS + ) where + +import Prelude + +import qualified Data.ByteString.Short as SBS +import Foreign +import Foreign.C + +newCStringFromSBS :: SBS.ShortByteString -> IO CString +newCStringFromSBS sbs = + SBS.useAsCStringLen sbs $ \(src, len) -> do + dst <- mallocBytes (len + 1) + copyBytes dst src len + pokeByteOff dst len (0 :: Word8) + pure dst ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -51,6 +51,7 @@ Library exposed-modules: GHC.BaseDir + GHC.Data.ShortByteString GHC.Data.ShortText GHC.Data.SizedSeq GHC.Data.SmallArray ===================================== libraries/ghci/GHCi/Coverage.hs ===================================== @@ -9,9 +9,9 @@ import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS import Data.Word import Foreign +import GHC.Data.ShortByteString import GHC.Foreign (CString) import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString) import GHCi.ObjLink (lookupSymbol) @@ -31,17 +31,19 @@ hpcAddModule :: -- ^ Name of the ticks array found in the c-stub. IO () hpcAddModule modlName ticks hash tickboxes = do - SBS.useAsCString modlName $ \modlNameLiteral -> do - -- we need to find the reference to the ticks array. - lookupSymbol tickboxes >>= \ case - Nothing -> do - -- the symbol is not found, this is a bug! - throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes - Just tickBoxRef -> do - -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. - hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) - -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. - hpc_startup + -- we need to find the reference to the ticks array. + lookupSymbol tickboxes >>= \ case + Nothing -> do + -- the symbol is not found, this is a bug! + throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes + Just tickBoxRef -> do + -- hs_hpc_module stores the module name pointer in the RTS hash table + -- until exitHpc, so pass a malloced C string. + modlNameLiteral <- newCStringFromSBS modlName + -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. + hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) + -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. + hpc_startup foreign import ccall unsafe "hs_hpc_module" hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO () ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -37,6 +37,9 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B +#if defined(PROFILING) +import GHC.Data.ShortByteString +#endif import GHC.Exts import qualified GHC.Exts.Heap as Heap import GHC.Stack @@ -447,13 +450,6 @@ mkCostCentres mod ccs = do c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan - newCStringFromSBS sbs = do - let len = BS.length sbs - buf <- mallocBytes $ len + 1 - BS.copyToPtr sbs 0 buf (fromIntegral len) - pokeByteOff buf len (0 :: Word8) - pure buf - foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -678,7 +678,7 @@ test ('T18140', ['-v0 -O']) test('T10421', [ only_ways(['normal']), - collect_compiler_runtime(1) + collect_compiler_runtime(2) # 1% tolerance was too small (#27289) ], multimod_compile, ['T10421', '-v0 -O']) ===================================== 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/-/compare/5392a8243d766492592cb521eab44b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5392a8243d766492592cb521eab44b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] Do much less simplification
by Simon Peyton Jones (＠simonpj) 26 May '26

26 May '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 2fbac2c0 by Simon Peyton Jones at 2026-05-27T00:28:32+01:00 Do much less simplification , ([], Opt_OptReflCoSimpleOpt ) -- See Note [Coercion optimisation] , ([2], Opt_OptReflCoSimplifier ) -- in GHC.Core.Coercion.Opt , ([2], Opt_OptCoercion ) - - - - - 1 changed file: - compiler/GHC/Driver/DynFlags.hs Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1297,8 +1297,8 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([0,1,2], Opt_ProfManualCcs ) , ([], Opt_OptReflCoSimpleOpt ) -- See Note [Coercion optimisation] - , ([0,1,2], Opt_OptReflCoSimplifier ) -- in GHC.Core.Coercion.Opt - , ([0,1,2], Opt_OptCoercion ) + , ([2], Opt_OptReflCoSimplifier ) -- in GHC.Core.Coercion.Opt + , ([2], Opt_OptCoercion ) , ([0], Opt_IgnoreInterfacePragmas) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fbac2c09bcf660fbf0ed806f560bd5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fbac2c09bcf660fbf0ed806f560bd5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/module-graph-reuse-in-downsweep] 12 commits: Implement List.elem via foldr
by Wolfgang Jeltsch (＠jeltsch) 26 May '26

26 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep 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. - - - - - 579aa0b7 by Simon Jakobi at 2026-05-25T16:31:26-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. - - - - - cccf45da by Cheng Shao at 2026-05-25T16:32:13-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. - - - - - 8db331a3 by Zubin Duggal at 2026-05-26T04:54:03-04:00 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 - - - - - 17be4f1f by Alan Zimmerman at 2026-05-26T04:54:52-04:00 EPA: Record semicolons in HsModifier Ensure the semi colons are captured in the ParsedSource for code like %True;; %False; instance C D It makes HsModifier (and hence HsModifierOf) LocatedA, so the semi colons can be recorded as [TrailingAnn] Also rename pprHsModifiers to pprLHsModifiers to match. Closes #27294 - - - - - 8f991755 by fendor at 2026-05-26T11:02:52-04:00 Revert prog003 acceptance We thought the commit 286f1adff3e78d775ff325caff71d0cee25d710b fixed the test, but due to changes to ghci, modules loaded during the GHCi session, the test was actually no longer testing what it set out to do, "fixing" the broken test. As modules are added to the `interactive-session` home unit, the object code needs to be compiled with `-this-unit-id interactive-session`, otherwise the object code won't be used. Once this has been fixed in the test, the test fails as expected again. - - - - - 277a3687 by mangoiv at 2026-05-26T11:03:40-04:00 libraries/process: bump submodule to v1.6.29.0 This submodule bump resolves a segfault on macos 15. Fixes #27144 - - - - - 6779bb0c by mangoiv at 2026-05-26T11:03:40-04:00 libraries/unix: in submodule, don't pick branch 2.7 The 2.7 branch is outdated and the module has been advanced far beyond it anyway, so remove that line. - - - - - 59081c54 by Wolfgang Jeltsch at 2026-05-26T19:57:22+03:00 Allow `downsweep` to use nodes of an existing module graph To this end, `downsweep` has not been able to use the nodes of a module graph obtained from a previous downsweeping round. In some GHC API applications, downsweeping is performed somewhat incrementally and therefore could profit from reusing such existing results. This contribution makes this possible. Resolves #27054. Co-authored-by: Matthew Pickering <matthewtpickering(a)gmail.com> - - - - - 85 changed files: - .gitmodules - + changelog.d/bump-process - + changelog.d/elem-via-foldr-27096 - + changelog.d/jobserver-leak-fix - + changelog.d/module-graph-reuse-in-downsweep - + changelog.d/semaphore-v2 - + changelog.d/wasm-fix-serviceworker - compiler/GHC/Data/List/SetOps.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/Language/Haskell/Syntax/Type.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/process - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/A.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/B.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/C.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/D.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/X.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Y.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Z.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghci/prog003/prog003.T - testsuite/tests/ghci/prog003/prog003.script - testsuite/tests/printer/Makefile - testsuite/tests/printer/PprModifiers.hs - + testsuite/tests/printer/PprQualifiedStrings.hs - + testsuite/tests/printer/Test27291.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs - utils/haddock/haddock-api/src/Haddock/Types.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/fc751783d2fb0682adefc1c96b7cd5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fc751783d2fb0682adefc1c96b7cd5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/module-graph-reuse-in-downsweep] Add changelog entry
by Wolfgang Jeltsch (＠jeltsch) 26 May '26

26 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC Commits: fc751783 by Wolfgang Jeltsch at 2026-05-26T19:53:18+03:00 Add changelog entry - - - - - 1 changed file: - + changelog.d/module-graph-reuse-in-downsweep Changes: ===================================== changelog.d/module-graph-reuse-in-downsweep ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Allow `downsweep` to use nodes of an existing module graph +issues: #27054 +mrs: !16028 +description: { + This contribution enables `downsweep` to use the nodes of a module + graph obtained from a previous downsweeping round, which allows GHC + API applications to build module graphs somewhat incrementally. +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc751783d2fb0682adefc1c96b7cd52… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc751783d2fb0682adefc1c96b7cd52… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] Try the effect of always using Big Hammer
by Simon Peyton Jones (＠simonpj) 26 May '26

26 May '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 9a08ad41 by Simon Peyton Jones at 2026-05-26T17:47:15+01:00 Try the effect of always using Big Hammer - - - - - 1 changed file: - compiler/GHC/Driver/DynFlags.hs Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1298,7 +1298,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([], Opt_OptReflCoSimpleOpt ) -- See Note [Coercion optimisation] , ([0,1,2], Opt_OptReflCoSimplifier ) -- in GHC.Core.Coercion.Opt - , ([2], Opt_OptCoercion ) + , ([0,1,2], Opt_OptCoercion ) , ([0], Opt_IgnoreInterfacePragmas) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a08ad4109bed789036a6a0767aa8f9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a08ad4109bed789036a6a0767aa8f9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/module-graph-reuse-in-downsweep] Make the test ensure that downsweep is really incremental
by Wolfgang Jeltsch (＠jeltsch) 26 May '26

26 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC Commits: f2b9217d by Wolfgang Jeltsch at 2026-05-26T19:43:14+03:00 Make the test ensure that downsweep is really incremental - - - - - 1 changed file: - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs Changes: ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs ===================================== @@ -9,6 +9,7 @@ import Data.List (sort) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (stderr) +import System.Directory (removeFile) import Language.Haskell.Syntax.Module.Name (moduleNameString) import GHC.Utils.Ppr (Mode (PageMode)) import GHC.Utils.Outputable (vcat, defaultSDocContext, printSDocLn, ppr) @@ -84,6 +85,9 @@ main = do intermediateModuleGraph <- performDownsweepTurn Nothing "A" liftIO $ outputModuleNamesInGraph intermediateModuleGraph + _ <- liftIO $ + mapM_ (((sourceDirectory ++ "/") ++) >>> (++ ".hs") >>> removeFile) + ["A", "B", "C", "D"] finalModuleGraph <- performDownsweepTurn (Just intermediateModuleGraph) "X" liftIO $ outputModuleNamesInGraph finalModuleGraph View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2b9217d81be146903f90c1494f743c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2b9217d81be146903f90c1494f743c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 2 commits: Update to semaphore-compat 2.0.0 using v2 of the protocol
by Magnus (＠MangoIV) 26 May '26

26 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 850d5ae2 by Zubin Duggal at 2026-05-26T18:27:39+02:00 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 (cherry picked from commit 8db331a381ae47ad9ad5c8613f5d3e2588d5dd55) - - - - - c5120e9c by mangoiv at 2026-05-26T18:27:39+02:00 libraries/process: bump submodule to v1.6.29.0 This submodule bump resolves a segfault on macos 15. Fixes #27144 (cherry picked from commit 277a3687c4b729e4d1ff4d4503a5673deba5eda7) - - - - - 18 changed files: - + changelog.d/bump-process - + 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/Make.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/process - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout Changes: ===================================== changelog.d/bump-process ===================================== @@ -0,0 +1,8 @@ +section: packaging +issues: #27144 +mrs: !16096 +synopsis: + bump submodule to v1.6.29.0 +description: + This submodule bump resolves a segfault on macos 15 with + certain command line SDK versions. ===================================== 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 ===================================== @@ -29,6 +29,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) @@ -95,6 +97,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 @@ -277,6 +293,10 @@ instance Diagnostic DriverMessage where ++ " and " ++ llvmVersionStr supportedLlvmVersionUpperBound ++ ") and reinstall GHC to ensure -fllvm works") + DriverSemaphoreOpenFailure _ err + -> mkSimpleDecorated $ + text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <> + text "; ignoring -jsem and compiling sequentially." diagnosticReason = \case DriverUnknownMessage m @@ -348,6 +368,8 @@ instance Diagnostic DriverMessage where -> ErrorWithoutFlag DriverNoConfiguredLLVMToolchain -> WarningWithoutFlag + DriverSemaphoreOpenFailure {} + -> WarningWithFlag Opt_WarnSemaphoreOpenFailure diagnosticHints = \case DriverUnknownMessage m @@ -421,5 +443,19 @@ instance Diagnostic DriverMessage where -> noHints DriverNoConfiguredLLVMToolchain -> 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 ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -40,6 +40,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 @@ -410,6 +411,17 @@ data DriverMessage where -} DriverNoConfiguredLLVMToolchain :: 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 ===================================== @@ -1070,6 +1070,7 @@ data WarningFlag = | Opt_WarnDeprecatedTypeAbstractions -- Since 9.10 | Opt_WarnDefaultedExceptionContext -- Since 9.10 | Opt_WarnViewPatternSignatures -- Since 9.12 + | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1187,6 +1188,7 @@ warnFlagNames wflag = case wflag of Opt_WarnDeprecatedTypeAbstractions -> "deprecated-type-abstractions" :| [] Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| [] Opt_WarnViewPatternSignatures -> "view-pattern-signatures" :| [] + Opt_WarnSemaphoreOpenFailure -> "semaphore-open-failure" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options @@ -1328,7 +1330,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnInconsistentFlags, Opt_WarnDataKindsTC, Opt_WarnTypeEqualityOutOfScope, - Opt_WarnViewPatternSignatures + Opt_WarnViewPatternSignatures, + Opt_WarnSemaphoreOpenFailure ] -- | Things you get with -W ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ApplicativeDo #-} @@ -54,7 +55,6 @@ import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session @@ -87,6 +87,15 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import System.Semaphore + ( SemaphoreIdentifier ) +#else +import System.Semaphore + ( SemaphoreError, SemaphoreIdentifier ) +#endif + +import GHC.Driver.Config.Diagnostic import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs @@ -113,7 +122,11 @@ import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set +#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 @@ -128,8 +141,12 @@ import System.Directory import System.FilePath import System.IO ( fixIO ) +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import GHC.Conc ( getNumProcessors ) +#else import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) import Control.Monad.IO.Class +#endif import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.LogQueue import qualified Data.Map.Strict as M @@ -668,7 +685,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 @@ -684,8 +701,8 @@ isWorkerLimitSequential (JSemLimit {}) = False data WorkerLimit = NumProcessorsLimit Int | JSemLimit - SemaphoreName - -- ^ Semaphore name to use + SemaphoreIdentifier + -- ^ Semaphore identifier from @-jsem@ deriving Eq -- | Generalized version of 'load' which also supports a custom @@ -2888,6 +2905,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 @@ -2904,12 +2922,27 @@ runNjobsAbstractSem n_jobs action = do resetNumCapabilities = set_num_caps n_capabilities MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a -runWorkerLimit worker_limit action = case worker_limit of +#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 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 runParPipelines :: WorkerLimit -- ^ How to limit work parallelism @@ -2935,7 +2968,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 @@ -3040,3 +3073,4 @@ which can be checked easily using ghc-debug. Where? See Note [ModuleNameSet, efficiency and space leaks], a variety of places in the driver are responsible. -} + ===================================== compiler/GHC/Driver/MakeSem.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NumericUnderscores #-} @@ -8,19 +9,28 @@ -- -- 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 @@ -30,6 +40,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 @@ -49,11 +68,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 @@ -84,6 +106,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 @@ -96,9 +121,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 @@ -114,12 +139,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 @@ -146,7 +173,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, @@ -192,17 +219,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. @@ -255,7 +295,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) @@ -265,61 +305,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. @@ -366,13 +413,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 @@ -384,6 +432,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 @@ -407,11 +456,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 @@ -433,30 +482,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 @@ -470,8 +527,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 @@ -480,12 +537,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 @@ -520,8 +577,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 @@ -534,6 +596,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 @@ -543,3 +611,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 ===================================== @@ -273,6 +273,8 @@ import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion ) + import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -2349,6 +2351,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnDeprecatedTypeAbstractions -> warnSpec x Opt_WarnDefaultedExceptionContext -> warnSpec x Opt_WarnViewPatternSignatures -> warnSpec x + Opt_WarnSemaphoreOpenFailure -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups @@ -3417,6 +3420,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 ===================================== @@ -325,6 +325,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "DriverModuleGraphCycle" = 92213 GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284 GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599 + 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(..) , pprUntickedConstructor, isBareSymbol , suggestExtension , suggestExtensionWithInfo @@ -505,6 +506,28 @@ data GhcHint {-| Suggest add parens to pattern `e -> p :: t` -} | SuggestParenthesizePatternRHS + {-| 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 ===================================== @@ -288,6 +288,20 @@ instance Outputable GhcHint where (hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig]) SuggestParenthesizePatternRHS -> text "Parenthesize the RHS of the view pattern" + 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 ===================================== @@ -2629,6 +2629,25 @@ of ``-W(no-)*``. To make the code forwards-compatible and silence the warning, users are advised to add parentheses manually. +.. ghc-flag:: -Wsemaphore-open-failure + :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore. + :type: dynamic + :reverse: -Wno-semaphore-open-failure + :category: + + :since: 9.12.5 + + 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. It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's sanity, not yours.) ===================================== 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 ===================================== @@ -136,10 +136,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/process ===================================== @@ -1 +1 @@ -Subproject commit f7d51387ba7f7f6079f3a9d5ce011ad9359b7dbb +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051 +Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -43,6 +43,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-06200] is untested (constructor = BlockedEquality) [GHC-81325] is untested (constructor = ExpectingMoreArguments) [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6353e7d26cd80cd53cc4ab2fb7e7ad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6353e7d26cd80cd53cc4ab2fb7e7ad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

26 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 6353e7d2 by mangoiv at 2026-05-26T18:17:26+02:00 libraries/process: bump submodule to v1.6.29.0 This submodule bump resolves a segfault on macos 15. Fixes #27144 (cherry picked from commit 277a3687c4b729e4d1ff4d4503a5673deba5eda7) - - - - - 2 changed files: - + changelog.d/bump-process - libraries/process Changes: ===================================== changelog.d/bump-process ===================================== @@ -0,0 +1,8 @@ +section: packaging +issues: #27144 +mrs: !16096 +synopsis: + bump submodule to v1.6.29.0 +description: + This submodule bump resolves a segfault on macos 15 with + certain command line SDK versions. ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit f7d51387ba7f7f6079f3a9d5ce011ad9359b7dbb +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6353e7d26cd80cd53cc4ab2fb7e7ad1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6353e7d26cd80cd53cc4ab2fb7e7ad1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Revert prog003 acceptance
by Marge Bot (＠marge-bot) 26 May '26

26 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8f991755 by fendor at 2026-05-26T11:02:52-04:00 Revert prog003 acceptance We thought the commit 286f1adff3e78d775ff325caff71d0cee25d710b fixed the test, but due to changes to ghci, modules loaded during the GHCi session, the test was actually no longer testing what it set out to do, "fixing" the broken test. As modules are added to the `interactive-session` home unit, the object code needs to be compiled with `-this-unit-id interactive-session`, otherwise the object code won't be used. Once this has been fixed in the test, the test fails as expected again. - - - - - 277a3687 by mangoiv at 2026-05-26T11:03:40-04:00 libraries/process: bump submodule to v1.6.29.0 This submodule bump resolves a segfault on macos 15. Fixes #27144 - - - - - 6779bb0c by mangoiv at 2026-05-26T11:03:40-04:00 libraries/unix: in submodule, don't pick branch 2.7 The 2.7 branch is outdated and the module has been advanced far beyond it anyway, so remove that line. - - - - - f1b6fbd8 by Simon Peyton Jones at 2026-05-26T12:06:26-04: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. - - - - - 5392a824 by Cheng Shao at 2026-05-26T12:06:27-04:00 ghci: fix module name string lifetime in hs_hpc_module invocation This patch makes hpcAddModule pass a properly malloced module name string to hs_hpc_module, instead of using useAsCString which causes use-after-free of module name string. Fixes #27297. Co-authored-by: Codex <codex(a)openai.com> - - - - - 15 changed files: - .gitmodules - + changelog.d/T27261 - + changelog.d/bump-process - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + libraries/ghc-boot/GHC/Data/ShortByteString.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Run.hs - libraries/process - testsuite/tests/ghci/prog003/prog003.T - testsuite/tests/ghci/prog003/prog003.script - + testsuite/tests/simplCore/should_compile/T27261.hs - + testsuite/tests/simplCore/should_compile/T27261_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== .gitmodules ===================================== @@ -82,7 +82,6 @@ path = libraries/unix url = https://gitlab.haskell.org/ghc/packages/unix.git ignore = untracked - branch = 2.7 [submodule "libraries/semaphore-compat"] path = libraries/semaphore-compat url = https://gitlab.haskell.org/ghc/semaphore-compat.git ===================================== 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``. ===================================== changelog.d/bump-process ===================================== @@ -0,0 +1,8 @@ +section: packaging +issues: #27144 +mrs: !16096 +synopsis: + bump submodule to v1.6.29.0 +description: + This submodule bump resolves a segfault on macos 15 with + certain command line SDK versions. ===================================== 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 ===================================== libraries/ghc-boot/GHC/Data/ShortByteString.hs ===================================== @@ -0,0 +1,17 @@ +module GHC.Data.ShortByteString + ( newCStringFromSBS + ) where + +import Prelude + +import qualified Data.ByteString.Short as SBS +import Foreign +import Foreign.C + +newCStringFromSBS :: SBS.ShortByteString -> IO CString +newCStringFromSBS sbs = + SBS.useAsCStringLen sbs $ \(src, len) -> do + dst <- mallocBytes (len + 1) + copyBytes dst src len + pokeByteOff dst len (0 :: Word8) + pure dst ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -51,6 +51,7 @@ Library exposed-modules: GHC.BaseDir + GHC.Data.ShortByteString GHC.Data.ShortText GHC.Data.SizedSeq GHC.Data.SmallArray ===================================== libraries/ghci/GHCi/Coverage.hs ===================================== @@ -9,9 +9,9 @@ import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS import Data.Word import Foreign +import GHC.Data.ShortByteString import GHC.Foreign (CString) import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString) import GHCi.ObjLink (lookupSymbol) @@ -31,17 +31,19 @@ hpcAddModule :: -- ^ Name of the ticks array found in the c-stub. IO () hpcAddModule modlName ticks hash tickboxes = do - SBS.useAsCString modlName $ \modlNameLiteral -> do - -- we need to find the reference to the ticks array. - lookupSymbol tickboxes >>= \ case - Nothing -> do - -- the symbol is not found, this is a bug! - throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes - Just tickBoxRef -> do - -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. - hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) - -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. - hpc_startup + -- we need to find the reference to the ticks array. + lookupSymbol tickboxes >>= \ case + Nothing -> do + -- the symbol is not found, this is a bug! + throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes + Just tickBoxRef -> do + -- hs_hpc_module stores the module name pointer in the RTS hash table + -- until exitHpc, so pass a malloced C string. + modlNameLiteral <- newCStringFromSBS modlName + -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. + hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) + -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. + hpc_startup foreign import ccall unsafe "hs_hpc_module" hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO () ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -37,6 +37,9 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B +#if defined(PROFILING) +import GHC.Data.ShortByteString +#endif import GHC.Exts import qualified GHC.Exts.Heap as Heap import GHC.Stack @@ -447,13 +450,6 @@ mkCostCentres mod ccs = do c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan - newCStringFromSBS sbs = do - let len = BS.length sbs - buf <- mallocBytes $ len + 1 - BS.copyToPtr sbs 0 buf (fromIntegral len) - pokeByteOff buf len (0 :: Word8) - pure buf - foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 72e5b7c75a17f543262674259b2ebf4a3bda390c +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 ===================================== testsuite/tests/ghci/prog003/prog003.T ===================================== @@ -5,5 +5,6 @@ test('prog003', [extra_files(['A.hs', 'B.hs', 'C.hs', 'D1.hs', 'D2.hs']), when(opsys('mingw32'), skip), + unless(config.ghc_dynamic, expect_broken(20704)), cmd_prefix('ghciWayFlags=' + config.ghci_way_flags)], ghci_script, ['prog003.script']) ===================================== testsuite/tests/ghci/prog003/prog003.script ===================================== @@ -25,7 +25,7 @@ a 42 putStrLn "Run 3" -- compile D, check that :reload doesn't pick it up -:shell "$HC" $HC_OPTS $ghciWayFlags -c D.hs +:shell "$HC" $HC_OPTS $ghciWayFlags -this-unit-id interactive-session -c D.hs :reload :type (A.a,B.b,C.c,D.d) a 42 @@ -38,21 +38,21 @@ a 42 putStrLn "Run 5" -- D,C compiled -:shell "$HC" $HC_OPTS $ghciWayFlags -c C.hs +:shell "$HC" $HC_OPTS $ghciWayFlags -this-unit-id interactive-session -c C.hs :load A :type (A.a,B.b,C.c,D.d) a 42 putStrLn "Run 6" -- D,C,B compiled -:shell "$HC" $HC_OPTS $ghciWayFlags -c B.hs +:shell "$HC" $HC_OPTS $ghciWayFlags -this-unit-id interactive-session -c B.hs :load A :type (A.a,B.b,C.c,D.d) a 42 putStrLn "Run 7" -- D,C,B,A compiled -:shell "$HC" $HC_OPTS $ghciWayFlags -c A.hs +:shell "$HC" $HC_OPTS $ghciWayFlags -this-unit-id interactive-session -c A.hs :load A :type (A.a,B.b,C.c,D.d) a 42 @@ -80,7 +80,7 @@ a 42 putStrLn "Run 11" -- A,B,C compiled (better not use A.o, B.o, C.o) -:shell "$HC" $HC_OPTS $ghciWayFlags --make -v0 A +:shell "$HC" $HC_OPTS $ghciWayFlags --make -this-unit-id interactive-session -v0 A :shell rm D.o :load A :type (A.a,B.b,C.c,D.d) ===================================== 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/-/compare/e004dac9b225b4f8d2455aa19b761a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e004dac9b225b4f8d2455aa19b761a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T27289
by sheaf (＠sheaf) 26 May '26

26 May '26

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

1 0