[Git][ghc/ghc][wip/supersven/refactor-system-cxx-std-lib-hadrian-rules] 6 commits: Trim the continuation in mkDupableContWithDmds

Sven Tennie pushed to branch wip/supersven/refactor-system-cxx-std-lib-hadrian-rules at Glasgow Haskell Compiler / GHC Commits: 4a645683 by Simon Peyton Jones at 2026-05-27T21:41:59-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. - - - - - 8ab506ff by Cheng Shao at 2026-05-27T21:42:47-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 - - - - - b0233814 by sheaf at 2026-05-27T21:43:31-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. - - - - - 827de234 by Matthew Pickering at 2026-05-28T08:32:32+00:00 hadrian: Refactor system-cxx-std-lib rules I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. Fixes #25303 Co-authored-by: Sven Tennie - - - - - a2bc3224 by Sven Tennie at 2026-05-28T08:32:32+00:00 Set shakeVersion This leads to wiping Shake's database, providing backwards compatibility to previous builds with different PackageData. - - - - - 4f2742f2 by Sven Tennie at 2026-05-28T08:32:32+00:00 Remove superfluous rule - - - - - 17 changed files: - + changelog.d/T27261 - + changelog.d/hadrian-system-cxx-std-lib-25303 - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Main.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Register.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``. ===================================== changelog.d/hadrian-system-cxx-std-lib-25303 ===================================== @@ -0,0 +1,18 @@ +section: packaging +synopsis: Fix Hadrian rules for system-cxx-std-lib package dependency +issues: #25303 +mrs: !16013 +description: { + Hadrian's handling of the ``system-cxx-std-lib`` virtual package has been + fixed and made more uniform. + + Previously, ``text`` had an ad-hoc rule outside of ``configurePackage`` to + declare a dependency on ``system-cxx-std-lib``, the dependency was not + discovered from cabal files, and the package database was not recached after + the ``.conf`` file was generated. + + The dependency is now read from cabal files via a new + ``dependsOnSystemCxxStdLib`` field in ``PackageData``, and the ``.conf`` file + is needed inside ``configurePackage`` alongside all other package + dependencies, consistent with how every other package is handled. +} ===================================== 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 \ 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 ===================================== hadrian/src/Hadrian/Haskell/Cabal/Parse.hs ===================================== @@ -81,10 +81,11 @@ parsePackageData pkg = do sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ] deps = nubOrd sorted \\ [name] depPkgs = mapMaybe findPackageByName deps + cxxStdLib = elem "system-cxx-std-lib" deps return $ PackageData name version (C.fromShortText (C.synopsis pd)) (C.fromShortText (C.description pd)) - depPkgs gpd + depPkgs cxxStdLib gpd where -- Collect an overapproximation of dependencies by ignoring conditionals collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency] @@ -138,7 +139,9 @@ configurePackage :: Context -> Action () configurePackage context@Context {..} = do putProgressInfo $ "| Configure package " ++ quote (pkgName package) gpd <- pkgGenericDescription package - depPkgs <- packageDependencies <$> readPackageData package + pd <- readPackageData package + let depPkgs = packageDependencies pd + needSystemCxxStdLib = dependsOnSystemCxxStdLib pd -- Stage packages are those we have in this stage. stagePkgs <- stagePackages stage @@ -157,7 +160,12 @@ configurePackage context@Context {..} = do -- We'll need those packages in our package database. deps <- sequence [ pkgConfFile (context { package = pkg, iplace = forceBaseAfterGhcInternal pkg }) | pkg <- depPkgs, pkg `elem` stagePkgs ] - need $ extraPreConfigureDeps ++ deps + -- system-cxx-std-lib is magic.. it doesn't have a cabal file or source code, so we have + -- to treat it specially as `pkgConfFile` uses `readPackageData` to compute the version. + systemCxxStdLib <- sequence [ systemCxxStdLibConfPath (PackageDbLoc stage iplace) | needSystemCxxStdLib ] + need $ extraPreConfigureDeps + ++ deps + ++ systemCxxStdLib -- Figure out what hooks we need. let configureFile = replaceFileName (pkgCabalFile package) "configure" ===================================== hadrian/src/Hadrian/Haskell/Cabal/Type.hs ===================================== @@ -30,6 +30,7 @@ data PackageData = PackageData , synopsis :: String , description :: String , packageDependencies :: [Package] + , dependsOnSystemCxxStdLib :: Bool , genericPackageDescription :: GenericPackageDescription } deriving (Eq, Generic, Show) ===================================== hadrian/src/Main.hs ===================================== @@ -63,7 +63,13 @@ main = do shakeColor <- shouldUseColor let options :: ShakeOptions options = shakeOptions - { shakeChange = ChangeModtimeAndDigest + { -- Bump shakeVersion whenever a type stored in the Shake oracle + -- changes its Binary representation (e.g. fields added/removed + -- from PackageData or other oracle value types). This forces + -- Shake to wipe the stale database instead of crashing on + -- deserialisation. + shakeVersion = "2" + , shakeChange = ChangeModtimeAndDigest , shakeFiles = buildRoot -/- Base.shakeFilesDir , shakeProgress = Progress.hadrianProgress cwd , shakeRebuild = rebuild ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -242,9 +242,6 @@ copyRules = do prefix -/- "html/**" <~ return "utils/haddock/haddock-api/resources" prefix -/- "latex/**" <~ return "utils/haddock/haddock-api/resources" - forM_ [Inplace, Final] $ \iplace -> - root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do - copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file generateRules :: Rules () generateRules = do ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -6,7 +6,6 @@ module Rules.Register ( import Base import Context -import Flavour import Oracles.Setting import Hadrian.BuildPath import Hadrian.Expression @@ -48,14 +47,6 @@ configurePackageRules = do isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend when isGmp $ need [buildP -/- "include/ghc-gmp.h"] - when (pkg == text) $ do - simdutf <- textWithSIMDUTF <$> flavour - when simdutf $ do - -- This is required, otherwise you get Error: hadrian: - -- Encountered missing or private dependencies: - -- system-cxx-std-lib ==1.0 - cxxStdLib <- systemCxxStdLibConfPath $ PackageDbLoc stage Inplace - need [cxxStdLib] Cabal.configurePackage ctx root -/- "**/autogen/cabal_macros.h" %> \out -> do @@ -105,6 +96,12 @@ registerPackageRules rs stage iplace = do target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] writeFileLines stamp [] + -- Special rule for registering system-cxx-std-lib + root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do + copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file + buildWithResources rs $ + target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] + -- Register a package. root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do historyDisable ===================================== 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/6b42a8f2ac8a68ca0f9dae5082957e1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b42a8f2ac8a68ca0f9dae5082957e1... You're receiving this email because of your account on gitlab.haskell.org.