- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/o0-fmax-simplifier-iterations-2] compiler: set -fmax-simplifier-iterations=2 for -O0
by Cheng Shao (＠TerrorJack) 04 Jun '26

04 Jun '26

Cheng Shao pushed to branch wip/o0-fmax-simplifier-iterations-2 at Glasgow Haskell Compiler / GHC Commits: 0dacd039 by Cheng Shao at 2026-06-04T11:01:34+00:00 compiler: set -fmax-simplifier-iterations=2 for -O0 This patch sets `-fmax-simplifier-iterations=2` as the new default under `-O0` for faster compilation of unoptimized code. See added note for details. Closes #27326. - - - - - 4 changed files: - + changelog.d/ghc-o0-fmax-simplifier-iterations-2 - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - docs/users_guide/using-optimisation.rst Changes: ===================================== changelog.d/ghc-o0-fmax-simplifier-iterations-2 ===================================== @@ -0,0 +1,13 @@ +section: compiler +synopsis: Set ``-fmax-simplifier-iterations=2`` for ``-O0`` +issues: #27326 +mrs: !16136 + +description: { + The maximum number of simplifier iterations + (``-fmax-simplifier-iterations``) is now tied to the optimisation + level: at most 2 iterations at ``-O0`` (previously 4) and still 4 at + ``-O1``/``-O2``. This speeds up unoptimised compilation. An explicit + ``-fmax-simplifier-iterations=⟨n⟩`` still overrides the default, as + long as it appears after the ``-O`` flag on the command line. +} ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -576,7 +576,8 @@ defaultDynFlags mySettings = verbosity = 0, debugLevel = 0, simplPhases = 2, - maxSimplIterations = 4, + maxSimplIterations = 2, -- The -O0 default. 'updOptLevel' raises this to 4 at -O1/-O2. See + -- Note [Simplifier iterations and the optimisation level]. ruleCheck = Nothing, binBlobThreshold = Just 500000, -- 500K is a good default (see #16190) maxRelevantBinds = Just 6, ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -786,15 +786,45 @@ setInteractivePrint f d = d { interactivePrint = Just f} ----------------------------------------------------------------------------- -- Setting the optimisation level +{- Note [Simplifier iterations and the optimisation level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At -O0 the only Core-to-Core pass that runs is the final simplifier pass (see +'GHC.Core.Opt.Pipeline.getCoreToDo'); every optimisation-specific pass is gated +off. We therefore want as few simplifier iterations as possible at -O0, since +the later iterations only chase optimisation opportunities the user opted out of +by choosing -O0. + +We cannot drop to a *single* iteration, though. The final simplifier pass is +still load-bearing for correctness: a single iteration can leave a recursive +superclass dictionary with an unreduced superclass selector applied to it, which +then builds an infinite dictionary tower and diverges (<<loop>> at -O, OOM at +-O0). See #21973 and test T21973b. The fix needs (at least) two iterations: the +first inlines the dictionary functions to expose a constructor, and the second +reduces the superclass selector against it, making the recursive dictionary +dead. Empirically two iterations suffice across the known reproducers; the +simplifier offers no proof of a fixed bound, so we keep a small margin rather +than the bare minimum. + +So we tie 'maxSimplIterations' to the optimisation level: 2 iterations at -O0 +and 4 at -O1/-O2. This is a noticeable win for unoptimised compilation, and most +noticeable for the byte-code interpreter (GHCi), which defaults to -O0 and codegen +does less work compared to other backends. + +An explicit -fmax-simplifier-iterations=⟨n⟩ still overrides this, as long as it +appears after the -O flag on the command line (the usual flag-ordering rule for +options that -O adjusts). +-} + updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool) -- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place updOptLevelChanged n dfs - = (dfs3, changed1 || changed2 || changed3) + = (dfs4, changed1 || changed2 || changed3 || changed4) where final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 (dfs1, changed1) = foldr unset (dfs , False) remove_gopts (dfs2, changed2) = foldr set (dfs1, False) extra_gopts (dfs3, changed3) = setLlvmOptLevel dfs2 + (dfs4, changed4) = setSimplIterations dfs3 extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] @@ -814,6 +844,14 @@ updOptLevelChanged n dfs | llvmOptLevel dfs /= llvm_n = (dfs{ llvmOptLevel = llvm_n }, True) | otherwise = (dfs, False) + -- See Note [Simplifier iterations and the optimisation level] + simpl_iters = if final_n == 0 then 2 else 4 + + setSimplIterations dfs + | maxSimplIterations dfs /= simpl_iters = + (dfs{ maxSimplIterations = simpl_iters }, True) + | otherwise = (dfs, False) + updOptLevel :: Int -> DynFlags -> DynFlags -- ^ Sets the 'DynFlags' to be appropriate to the optimisation level updOptLevel n = fst . updOptLevelChanged n ===================================== docs/users_guide/using-optimisation.rst ===================================== @@ -914,11 +914,12 @@ as such you shouldn't need to set any of them explicitly. A flag :ghc-flag:`-Wincomplete-patterns` and :ghc-flag:`-Wincomplete-uni-patterns`. .. ghc-flag:: -fmax-simplifier-iterations=⟨n⟩ - :shortdesc: *default: 4.* Set the max iterations for the simplifier. + :shortdesc: *default: 2 at :ghc-flag:`-O0`, 4 otherwise.* Set the max iterations + for the simplifier. :type: dynamic :category: - :default: 4 + :default: 2 at :ghc-flag:`-O0`, 4 at :ghc-flag:`-O1` and :ghc-flag:`-O2` Sets the maximal number of iterations for the simplifier. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0dacd03911ce1e8dd38771797e7b56b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0dacd03911ce1e8dd38771797e7b56b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/o0-fmax-simplifier-iterations-2
by Cheng Shao (＠TerrorJack) 04 Jun '26

04 Jun '26

Cheng Shao pushed new branch wip/o0-fmax-simplifier-iterations-2 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/o0-fmax-simplifier-iterations… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/no-nbsps] Don't use non-breaking spaces
by Simon Hengel (＠sol) 04 Jun '26

04 Jun '26

Simon Hengel pushed to branch wip/sol/no-nbsps at Glasgow Haskell Compiler / GHC Commits: 6b609a98 by Simon Hengel at 2026-06-04T17:52:15+07:00 Don't use non-breaking spaces - - - - - 7 changed files: - compiler/GHC/Driver/Backend.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Utils/Logger.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs Changes: ===================================== compiler/GHC/Driver/Backend.hs ===================================== @@ -184,7 +184,7 @@ import GHC.Platform -- about enumerating them. Just one set of error messages has been -- ported to have an open-world assumption: these are the error -- messages associated with type checking of foreign imports and --- exports. To allow other errors to be issued with an open-world +-- exports. To allow other errors to be issued with an open-world -- assumption, use functions `backendValidityOfCImport` and -- `backendValidityOfCExport` as models, and have a look at how the -- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and @@ -225,11 +225,11 @@ platformJSSupported platform | otherwise = False --- | A value of type @Backend@ represents one of GHC's back ends. +-- | A value of type @Backend@ represents one of GHC's back ends. -- The set of back ends cannot be extended except by modifying the -- definition of @Backend@ in this module. -- --- The @Backend@ type is abstract; that is, its value constructors are +-- The @Backend@ type is abstract; that is, its value constructors are -- not exported. It's crucial that they not be exported, because a -- value of type @Backend@ carries only the back end's /name/, not its -- behavior or properties. If @Backend@ were not abstract, then code ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -289,7 +289,7 @@ instance HasHaddock (Located (HsModule GhcPs)) where pure $ L l_mod $ mod { hsmodExports = hsmodExports' , hsmodDecls = hsmodDecls' - , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } } + , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } } lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -177,7 +177,7 @@ resolveFunctionBreakpoint inp = do -- for -- (a) this binder only (it maybe a top-level or a nested declaration) -- (b) that do not have an enclosing breakpoint -findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakTickIndex, RealSrcSpan)] +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakTickIndex, RealSrcSpan)] findBreakForBind str_name modbreaks = filter (not . enclosed) ticks where ticks = [ (index, span) @@ -226,7 +226,7 @@ getModBreak m = do -- source breakpoint, it means all *ocurrences* of that breakpoint across -- modules should be stopped at -- hence we keep a trie from BreakpointId to -- the list of internal break ids using it. --- See also Note [Breakpoint identifiers] +-- See also Note [Breakpoint identifiers] type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId]) -- | Lookup all InternalBreakpointIds matching the given BreakpointId ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -75,7 +75,7 @@ enableGhcStepMode _ = EvalStepSingle -- and the SrcSpan of a breakpoint we hit, return @True@ if we should stop at -- this breakpoint. -- --- In particular, this will always be @False@ for @'RunToCompletion'@ and +-- In particular, this will always be @False@ for @'RunToCompletion'@ and -- @'RunAndLogSteps'@. We'd need further information e.g. about the user -- breakpoints to determine whether to break in those modes. breakHere :: Bool -- ^ Was this breakpoint explicitly active (in the @BreakArray@s)? ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -293,22 +293,22 @@ ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} = return $ hcat $ - [ char '_' - , whenPprDebug $ + [ char '_' + , whenPprDebug $ space <> dcolon <> pprSigmaType ty - ] ++ - [ whenPprDebug $ + ] ++ + [ whenPprDebug $ space <> char '<' <> text (ipSrcFile ipe) <> char ':' <> text (ipSrcSpan ipe) <> char '>' - | Just ipe <- [mipe] + | Just ipe <- [mipe] , not $ null $ ipSrcFile ipe - ] + ] ppr_termM1 Suspension{ty=ty, bound_to=Just n} | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -413,7 +413,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- | The default 'LogAction' parametrized over the standard output and standard error handles. -- Allows clients to replicate the log message formatting of GHC with custom handles. -defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction +defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags msg_class srcSpan msg | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg | otherwise = case msg_class of ===================================== libraries/ghc-internal/src/GHC/Internal/Lexeme.hs ===================================== @@ -44,7 +44,7 @@ okSymChar c _ -> False startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool -startsVarSym c = okSymChar c && c /= ':' -- Infix Ids +startsVarSym c = okSymChar c && c /= ':' -- Infix Ids startsConSym c = c == ':' -- Infix data constructors startsVarId c = c == '_' || case generalCategory c of -- Ordinary Ids LowercaseLetter -> True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b609a988d14836a0120d29234153d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b609a988d14836a0120d29234153d8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sol/no-nbsps
by Simon Hengel (＠sol) 04 Jun '26

04 Jun '26

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

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Further Up and Further In
by Wolfgang Jeltsch (＠jeltsch) 04 Jun '26

04 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 0c9fded2 by Wolfgang Jeltsch at 2026-06-04T13:33:04+03:00 Further Up and Further In - - - - - 1 changed file: - compiler/GHC/ByteCode/Show.hs Changes: ===================================== compiler/GHC/ByteCode/Show.hs ===================================== @@ -11,6 +11,7 @@ import Control.Exception (assert) import Data.Eq ((==)) import Data.Bits (FiniteBits, finiteBitSize) import Data.Function (($), (.)) +import Data.Tuple (uncurry) import Data.Bool (Bool, otherwise, not) import Data.Int (Int) import Data.Word (Word, Word16) @@ -37,6 +38,7 @@ import GHC.Utils.Outputable defaultDumpStyle, SDoc, text, + (<>), (<+>), hsep, vcat, @@ -60,7 +62,7 @@ import GHC.ByteCode.Serialize (readOnDiskModuleByteCode) import GHC.Driver.Env.Types (HscEnv) import GHCi.ResolvedBCO (BCOByteArray, fromBCOByteArray) import GHCi.FFI (FFIType) -import GHCi.Message (ConInfoTable) +import GHCi.Message (ConInfoTable (..)) -- | […] showByteCode :: Logger -> HscEnv -> FilePath -> IO () @@ -109,7 +111,7 @@ pprByteCodeObjects currentModule = entry (text "bytecode objects:") . pprByteCodeObject :: Module -> UnlinkedBCO -> SDoc pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of UnlinkedBCO {..} - -> entry (text "ordinary bytecode object" <+> ppr unlinkedBCOName) $ + -> entry (text "ordinary object" <+> ppr unlinkedBCOName <> text ":") $ vcat [ pprArity $ unlinkedBCOArity, pprInstructions $ unlinkedBCOInstrs, @@ -118,7 +120,12 @@ pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of pprPointers currentModule $ unlinkedBCOPtrs ] UnlinkedStaticCon {..} - -> entry (text "static constructor object" <+> ppr unlinkedStaticConName) $ + -> entry ( + text "static-construction object" <+> + ppr unlinkedStaticConName <> + text ":" + ) + $ vcat [ pprDataConstructorName $ unlinkedStaticConDataConName, pprLiftedness $ not unlinkedStaticConIsUnlifted, @@ -219,9 +226,50 @@ pprPointer currentModule pointer = case pointer of -- | […] pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc -pprDataConstructorInfoTables - = entry (text "data constructor info tables:") . - pprDataConstructorInfoTables +pprDataConstructorInfoTables = entry (text "data constructor info tables:") . + vcatOrNone . + map (uncurry pprDataConstructorInfoTableOf) + +-- | […] +pprDataConstructorInfoTableOf :: Name -> ConInfoTable -> SDoc +pprDataConstructorInfoTableOf dataConstrName ConInfoTable {..} + = entry (text "info table of" <+> ppr dataConstrName <> text ":") $ + vcat [ + pprTablePositioning $ conItblTablesNextToCode, + pprLiteralCount $ conItblNPtrs, + pprPointerCount $ conItblPtrs, + pprConstructorTag $ conItblConTag, + pprPointerTag $ conItblPtrTag, + pprDescription $ conItblDescr + ] +{-FIXME: + Check based on any answers to my message on 4 June 2026, 13:17 EEST whether + the current handling of `conItblPtrs` and `conItblNPtrs` is correct. +-} + +-- | […] +pprTablePositioning :: Bool -> SDoc +pprTablePositioning = entry (text "tables next to code:") . noOrYes + +-- | […] +pprLiteralCount :: Int -> SDoc +pprLiteralCount = entry (text "number of literals:") . ppr + +-- | […] +pprPointerCount :: Int -> SDoc +pprPointerCount = entry (text "number of pointers:") . ppr + +-- | […] +pprConstructorTag :: Int -> SDoc +pprConstructorTag = entry (text "constructor tag:") . ppr + +-- | […] +pprPointerTag :: Int -> SDoc +pprPointerTag = entry (text "pointer tag:") . ppr + +-- | […] +pprDescription :: ByteString -> SDoc +pprDescription = entry (text "description:") . pprByteString -- | […] pprTopLevelStrings :: [(Name, ByteString)] -> SDoc @@ -240,9 +288,8 @@ pprBreakpointsData = pprBreakpointsData -- | […] pprStaticPointerTableEntries :: [SptEntry] -> SDoc -pprStaticPointerTableEntries - = entry (text "static-pointer table entries:") . - pprStaticPointerTableEntries +pprStaticPointerTableEntries = entry (text "static-pointer table entries:") . + pprStaticPointerTableEntries -- | […] pprHPCInfo :: Strict.Maybe ByteCodeHpcInfo -> SDoc @@ -255,14 +302,13 @@ pprHPCInfoData = pprHPCInfoData -- | […] pprObjectFileContents :: [ByteString] -> SDoc -pprObjectFileContents - = entry (text "contents of object files:") . - vcatOrNone . - zipWith pprEntry [0 ..] - where +pprObjectFileContents = entry (text "contents of object files:") . + vcatOrNone . + zipWith pprContentOfObjectFile [0 ..] - pprEntry :: Int -> ByteString -> SDoc - pprEntry ix content = entry (text "file" <+> ppr ix) (pprByteString content) +pprContentOfObjectFile :: Int -> ByteString -> SDoc +pprContentOfObjectFile ix = entry (text "file" <+> ppr ix <> text ":") . + pprByteString -- | […] pprByteString :: ByteString -> SDoc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c9fded226c95ebe6325361a5d30acd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c9fded226c95ebe6325361a5d30acd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/hadrian-aclocal_path] 3 commits: Avoid mkTick in Core Prep breaking ANF
by David Eichmann (＠DavidEichmann) 04 Jun '26

04 Jun '26

David Eichmann pushed to branch wip/davide/hadrian-aclocal_path at Glasgow Haskell Compiler / GHC Commits: f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00 Avoid mkTick in Core Prep breaking ANF As discovered in #27182, mkTick can break ANF. This patch introduces a variant of mkTick that skips the single optimisation that could break ANF. This is preferrable over switching to the raw Tick constructor, as the latter may introduce spurious cost centres in profiling reports. This is a temporary measure until we more thoroughly refactor how mkTick works (see #27141). See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. Fixes #27182 - - - - - cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00 clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements" - - - - - a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 9 changed files: - boot - + changelog.d/T27182.md - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T Changes: ===================================== boot ===================================== @@ -52,9 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': - # Get the normalized ACLOCAL_PATH for Windows - # This is necessary since on Windows this will be a Windows - # path, which autoreconf doesn't know doesn't know how to handle. + # Convert ACLOCAL_PATH env variable to unix style paths on Windows + # See Note [Autoreconf unix paths from ACLOCAL_PATH] ac_local = os.getenv('ACLOCAL_PATH', '') ac_local_arg = re.sub(r';', r':', ac_local) ac_local_arg = re.sub(r'\\', r'/', ac_local_arg) ===================================== changelog.d/T27182.md ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27182 +mrs: !16003 +synopsis: + Fix `getStgArgFromTrivialArg` panic in CoreToStg +description: + Avoid a `getStgArgFromTrivialArg` panic in CoreToStg due to a call to `mkTick` + in Core Prep which invalidated ANF. ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -2149,7 +2149,7 @@ primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp MutableByteArray# s -> State# s -> (# State# s, Int# #) - {Return the number of elements in the array, correctly accounting for + {Return the number of bytes in the array, correctly accounting for the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'. @since 0.5.0.0} ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Core.Utils ( -- * Constructing expressions mkCast, mkCastMCo, mkPiMCo, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + mkTickCpe, bindNonRec, needsCaseBinding, needsCaseBindingL, mkAltExpr, mkDefaultCase, mkSingleAltCase, @@ -319,7 +320,18 @@ mkCast expr co -- * Split profiling ticks into counting/scoping parts so that the two parts -- can be placed independently into the AST. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' orig_expr +mkTick = mk_tick False + +-- | A version of 'mkTick' that preserves ANF, for use in Core Prep. +-- +-- See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. +mkTickCpe :: CoreTickish -> CoreExpr -> CoreExpr +mkTickCpe = mk_tick True + +-- | Internal function used to define both 'mkTick' and 'mkTickCpe' +-- without duplication. +mk_tick :: Bool -> CoreTickish -> CoreExpr -> CoreExpr +mk_tick preserve_anf t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. @@ -343,7 +355,7 @@ mkTick t orig_expr = mkTick' orig_expr -- Push SCCs into lambdas. -- See (PSCC2) in Note [Pushing SCCs inwards]. | can_split - -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ Lam x $ mk_tick preserve_anf (mkNoCount t) e App f arg -- All ticks float inwards through non-runtime arguments, as per @@ -353,7 +365,9 @@ mkTick t orig_expr = mkTick' orig_expr -- Push SCCs into saturated constructor applications. -- See (PSCC3) in Note [Pushing SCCs inwards]. - | isSaturatedConApp expr + | not preserve_anf -- this optimisation breaks ANF; + -- see Note [mkTick breaks ANF] in GHC.CoreToStg.Prep + , isSaturatedConApp expr , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre then tickHNFArgs t expr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -801,7 +801,9 @@ cpeBodyF env (Tick tickish expr) ; return (FloatTick tickish `consFloat` floats, body) } | otherwise = do { body <- cpeBody env expr - ; return (emptyFloats, mkTick tickish' body) } + ; return (emptyFloats, mkTickCpe tickish' body) } + -- Use mkTickCpe and not mkTick, as the latter may break ANF (#27182). + -- See (TickANF2) in Note [mkTick breaks ANF]. where tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' @@ -905,6 +907,28 @@ cpeBodyF env (Case scrut bndr ty alts) ; rhs' <- cpeBody env2 rhs ; return (Alt con bs' rhs') } +{- Note [mkTick breaks ANF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +mkTick does not preserve the ANF property as required by Core Prep (see +Note [CorePrep invariants]), as seen in #27182. Given: + + mkTick scc<foo> (\ (eta :: Char -> Bool) -> BindP (p :: Int) eta) + +mkTick will push the SCC into the constructor application, resulting in: + + \ (eta :: Char -> Bool) -> BindP (p :: Int) (scc<oneM> eta) + +To avoid this problem (at least until 'mkTick' is more thoroughly reworked to +avoid this infelicity, see #27141), we define a variant of 'mkTick', called +'mkTickCpe', which does not push ticks into constructor applications (this is +the only optimisation done by 'mkTick' that can break ANF). + +We prefer using a small variant of 'mkTick' rather than using the 'Tick' +constructor, as the latter can slightly degrade profiling reports by failing to +combine ticks (can result in spurious cost centres with 0 entries appearing in +profiling reports). +-} + -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- @@ -1207,7 +1231,7 @@ cpeApp top_env expr rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of -- See Note [Ticks and mandatory eta expansion] _ | not (null rt_ticks), req_depth <= 0 - -> let tick_fun = foldr mkTick fun' rt_ticks + -> let tick_fun = foldr mkTickCpe fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth AIApp (Type arg_ty) @@ -2307,7 +2331,7 @@ wrapBinds floats body mk_bind (UnsafeEqualityCase scrut b con bs) body = mkSingleAltCase scrut b con bs body mk_bind (FloatTick tickish) body - = mkTick tickish body + = mkTickCpe tickish body -- | Put floats at top-level deFloatTop :: Floats -> [CoreBind] @@ -2735,7 +2759,7 @@ newVar env ty wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) wrapTicks floats expr | (floats1, ticks1) <- fold_fun go floats - = (floats1, foldrOL mkTick expr ticks1) + = (floats1, foldrOL mkTickCpe expr ticks1) where fold_fun f floats = let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats) in (floats { fs_binds = binds }, ticks) @@ -2755,8 +2779,8 @@ wrapTicks floats expr wrap t (Float bind bound info) = Float (wrapBind t bind) bound info wrap _ f = pprPanic "Unexpected FloatingBind" (ppr f) - wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTickCpe t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTickCpe t) pairs) ------------------------------------------------------------------------------ -- Numeric literals ===================================== hadrian/src/Hadrian/Oracles/Path.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Hadrian.Oracles.Path ( - lookupInPath, fixAbsolutePathOnWindows, pathOracle + lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows, + pathOracle ) where import Control.Monad @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path = else return path +-- | Fix a unix path list on Windows: +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin" +fixUnixPathsOnWindows :: FilePath -> Action FilePath +fixUnixPathsOnWindows paths = + if isWindows + then askOracle $ UnixPathList paths + else return paths + newtype LookupInPath = LookupInPath String deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult LookupInPath = String @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult WindowsPath = String +newtype UnixPathList = UnixPathList FilePath + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult UnixPathList = String + -- | Oracles for looking up paths. These are slow and require caching. pathOracle :: Rules () pathOracle = do @@ -50,6 +63,12 @@ pathOracle = do putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath return windowsPath + void $ addOracleCache $ \(UnixPathList paths) -> do + Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths] + let unixPaths = unifyPath $ dropWhileEnd isSpace out + putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths + return unixPaths + void $ addOracleCache $ \(LookupInPath name) -> do path <- liftIO getSearchPath exes <- liftIO (findExecutablesInDirectories path name) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -3,18 +3,19 @@ module Rules.BinaryDist where import CommandLine import Context +import Data.Either +import qualified Data.Set as Set import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) +import Oracles.Flavour import Oracles.Setting import Packages +import Rules.Generate (generateSettings) import Settings +import qualified System.Directory.Extra as IO import Settings.Program (programContext) import Target import Utilities -import qualified System.Directory.Extra as IO -import Data.Either -import qualified Data.Set as Set -import Oracles.Flavour -import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -343,7 +344,25 @@ bindistRules = do ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib") - buildWithCmdOptions [] $ + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- + -- style paths. This happens because MSYS2 automatically converts env variables to + -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. + -- This is done both in the boot Python script and here when building a bindist. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] -- We clean after ourselves, moving the configure script we generated in -- our bindist dir ===================================== testsuite/tests/profiling/should_compile/T27182.hs ===================================== @@ -0,0 +1,6 @@ +module T27182 ( oneM ) where + +data Parser = BindP Int ( Char -> Bool ) + +oneM :: Int -> ( Char -> Bool ) -> Parser +oneM p = BindP p ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -22,3 +22,4 @@ test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', test('T20938', [test_opts], compile, ['-O -prof']) test('T26056', [test_opts], compile, ['-O -prof']) test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-v0 -O -prof -fprof-auto']) +test('T27182', [test_opts], compile, ['-O -prof -fprof-late']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53e0626b3dc3f4a79045fa1560990d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53e0626b3dc3f4a79045fa1560990d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: always keep response files
by David Eichmann (＠DavidEichmann) 04 Jun '26

04 Jun '26

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC Commits: a0abeeab by David Eichmann at 2026-06-04T10:43:41+01:00 Hadrian: always keep response files Now that response files are only used in a small number of cases, it's reasonable to keep all response files by default and simply remove the -r / --keep-response-files command line options. The response file paths are nolonger randomized. They are placed in the `_build/rsp` directory. This ensures we reuse file paths when rebuilding rather than leaving stale response files around. - - - - - 5 changed files: - − changelog.d/hadrian-response-files.md - hadrian/src/Builder.hs - hadrian/src/CommandLine.hs - hadrian/src/Hadrian/Builder/Ar.hs - hadrian/src/Hadrian/Utilities.hs Changes: ===================================== changelog.d/hadrian-response-files.md deleted ===================================== @@ -1,9 +0,0 @@ -section: packaging -synopsis: Add a flag to tell Hadrian to keep response files -issues: #27184 -mrs: !15906 -description: - Hadrian can now be instructed to keep response files with the new - --keep-response-files command line flag. This is helpful when debugging a - build failure, as it allows re-running the failing command line invocation - without an error due to a missing response file. ===================================== hadrian/src/Builder.hs ===================================== @@ -304,7 +304,7 @@ instance H.Builder Builder where case builder of Ar Pack stg -> do useTempFile <- arSupportsAtFile stg - if useTempFile then runAr path buildArgs buildInputs buildOptions + if useTempFile then runAr output path buildArgs buildInputs buildOptions else runArWithoutTempFile path buildArgs buildInputs buildOptions Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions @@ -343,7 +343,7 @@ instance H.Builder Builder where Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions return () - Haddock BuildPackage -> runHaddock path buildArgs buildInputs + Haddock BuildPackage -> runHaddock output path buildArgs buildInputs Ghc _ _ -> -- Use a response file for ghc invocations to avoid issues with command line @@ -352,6 +352,7 @@ instance H.Builder Builder where -- empty arguments (such as the -dep-suffix flag), but that isn't supported -- yet due to #26560. withResponseFileIfLongCmd + output (toCmdArgument [path] <> toCmdArgument buildArgs) buildInputs (toCmdArgument buildOptions) @@ -390,11 +391,13 @@ instance H.Builder Builder where -- | Invoke @haddock@ given a path to it and a list of arguments. On Windows, -- the input file arguments are passed as a response file. -runHaddock :: FilePath -- ^ path to @haddock@ +runHaddock :: FilePath -- ^ base name to use for response file + -> FilePath -- ^ path to @haddock@ -> [String] -> [FilePath] -- ^ input file paths -> Action () -runHaddock haddockPath flagArgs fileInputs = withResponseFileIfLongCmd +runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd + outputFilePath (toCmdArgument [haddockPath] <> toCmdArgument flagArgs) fileInputs (CmdArgument []) ===================================== hadrian/src/CommandLine.hs ===================================== @@ -3,8 +3,7 @@ module CommandLine ( lookupBignum, cmdBignum, cmdProgressInfo, cmdCompleteSetting, cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs, - cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs, - cmdKeepResponseFiles + cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs ) where import Data.Either @@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map import Data.List.Extra import Development.Shake hiding (Normal) import Flavour (DocTargets, DocTarget(..)) -import Hadrian.Utilities hiding (buildRoot, keepResponseFiles) +import Hadrian.Utilities hiding (buildRoot) import Settings.Parser import System.Console.GetOpt import System.Environment @@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs , testArgs :: TestArgs , docsArgs :: DocArgs , docTargets :: DocTargets - , keepResponseFiles :: Bool , prefix :: Maybe FilePath , changelogVersion :: Maybe String , completeStg :: Maybe String } @@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs , testArgs = defaultTestArgs , docsArgs = defaultDocArgs , docTargets = Set.fromList [minBound..maxBound] - , keepResponseFiles = False , prefix = Nothing , changelogVersion = Nothing , completeStg = Nothing } @@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True } readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True } readSkipDepends = Right $ \flags -> flags { skipDepends = True } -readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs) -readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True } - readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs) readUnitIdHash = Right $ \flags -> trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $ @@ -302,8 +296,6 @@ optDescrs = "Progress info style (None, Brief, Normal or Unicorn)." , Option [] ["docs"] (ReqArg readDocsArg "TARGET") "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]." - , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles) - "Keep response files created during the build (for debugging)." , Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles) "Keep all the files generated when running the testsuite." , Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER") @@ -382,7 +374,6 @@ cmdLineArgsMap = do return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities $ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities - $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities $ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest $ insertExtra (docsArgs args) -- Accessed by Rules.Documentation $ insertExtra allSettings -- Accessed by Settings @@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs cmdBignum :: Action (Maybe String) cmdBignum = bignum <$> cmdLineArgs -cmdKeepResponseFiles :: Action Bool -cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs - cmdProgressInfo :: Action ProgressInfo cmdProgressInfo = progressInfo <$> cmdLineArgs ===================================== hadrian/src/Hadrian/Builder/Ar.hs ===================================== @@ -35,14 +35,16 @@ instance NFData ArMode -- to be archived is passed via a temporary response file. Passing arguments -- via a response file is not supported by some versions of @ar@, in which -- case you should use 'runArWithoutTempFile' instead. -runAr :: FilePath -- ^ path to @ar@ +runAr :: FilePath -- ^ base name to use for response files + -> FilePath -- ^ path to @ar@ -> [String] -- ^ other arguments -> [FilePath] -- ^ input file paths -> [CmdOption] -- ^ Additional options -> Action () -runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do - writeFile' tmp $ unwords fileArgs - cmd [arPath] flagArgs ('@' : tmp) buildOptions +runAr outputFilePath arPath flagArgs fileArgs buildOptions = do + rspFile <- responseFilePath outputFilePath + writeFile' rspFile $ unwords fileArgs + cmd [arPath] flagArgs ('@' : rspFile) buildOptions -- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@ -- will be called multiple times if the list of files to be archived is too ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -16,7 +16,7 @@ module Hadrian.Utilities ( -- * Paths BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, - KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd, + withResponseFileIfLongCmd, responseFilePath, -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, @@ -49,10 +49,10 @@ import Data.Maybe import Data.Typeable (TypeRep, typeOf) import Development.Shake hiding (Normal) import Development.Shake.Classes +import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument)) import Development.Shake.FilePath import GHC.ResponseFile (escapeArgs) import System.Environment (lookupEnv) -import System.IO (hClose, openTempFile) import System.IO.Error (isPermissionError) import qualified Data.ByteString as BS @@ -62,7 +62,6 @@ import qualified System.Directory.Extra as IO import qualified System.Info.Extra as IO import qualified System.IO as IO import qualified System.FilePath.Posix as Posix -import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument)) -- | Extract a value from a singleton list, or terminate with an error message -- if the list does not contain exactly one value. @@ -323,59 +322,35 @@ buildRootRules = do isGeneratedSource :: FilePath -> Action Bool isGeneratedSource file = buildRoot <&> (`isPrefixOf` file) -newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show) - --- | Whether to retain response files after the build action that created them --- completes. Mainly useful for debugging. -keepResponseFiles :: Action Bool -keepResponseFiles = do - KeepResponseFiles keep <- userSetting (KeepResponseFiles False) - return keep - -- | Run an command with the given arguments. If the command is too long then the -- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@. --- --- With @--keep-response-files@, the file is left on disk (if used) -withResponseFileIfLongCmd :: (CmdResult c) => - CmdArgument -- ^ Command and arguments before the response file arguments. +withResponseFileIfLongCmd :: + CmdResult c + => FilePath -- ^ Response base name. The reponse file is placed in @_build/rsp/\<Response base name\>@. + -> CmdArgument -- ^ Command and arguments before the response file arguments. -> [String] -- ^ Response file aruguments. -> CmdArgument -- ^ Command arguments after the response file arguments. -> Action c -withResponseFileIfLongCmd argsPre argsResp argsPost = do +withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do let cmdLineLengh = sum [ 1 + length arg -- add one to account for space inbetween arguments | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost , Right arg <- args ] - if cmdLineLengh >= cmdLineLengthLimit - then withResponseFile $ \tmp -> do - writeFile' tmp (escapeArgs argsResp) - cmd argsPre ['@' : tmp] argsPost - else cmd argsPre argsResp argsPost - --- | Run an action with a response file path. --- --- With @--keep-response-files@, the file is left on disk. -withResponseFile :: (FilePath -> Action a) -> Action a -withResponseFile action = do - keep <- keepResponseFiles - let putVerboseResponseFile tmp = do - verbosity <- getVerbosity - when (verbosity >= Verbose) $ do - tmpContent <- liftIO (readFile tmp) - putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent) - if keep - then do - (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp" - liftIO $ hClose h - putInfo $ "Keeping response file: " ++ tmp - result <- action tmp - putVerboseResponseFile tmp - return result - else withTempFile $ \tmp -> do - result <- action tmp - putVerboseResponseFile tmp - return result + if cmdLineLengh < cmdLineLengthLimit + then cmd argsPre argsResp argsPost + else do + rspFile <- responseFilePath outputFilePath + writeFile' rspFile (escapeArgs argsResp) + cmd argsPre ['@' : rspFile] argsPost + +-- | Convert a command's output file path to a response file path to be used for that command. +-- Response files are placed in a dedicated @rps@ directory under the build directory. This avoids +-- clutering the work tree or interfearing with other build directories. +responseFilePath :: FilePath -> Action FilePath +responseFilePath outputFilePath = do + buildDir <- buildRoot + return $ buildDir </> "rsp" </> outputFilePath -- | Link a file tracking the link target. Create the target directory if -- missing. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0abeeabe793a50b1311f36c9b56fb1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0abeeabe793a50b1311f36c9b56fb1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Add treatment of `UnlinkedStaticCon`
by Wolfgang Jeltsch (＠jeltsch) 04 Jun '26

04 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 7c57dd19 by Wolfgang Jeltsch at 2026-06-04T11:42:42+03:00 Add treatment of `UnlinkedStaticCon` - - - - - 1 changed file: - compiler/GHC/ByteCode/Show.hs Changes: ===================================== compiler/GHC/ByteCode/Show.hs ===================================== @@ -11,7 +11,7 @@ import Control.Exception (assert) import Data.Eq ((==)) import Data.Bits (FiniteBits, finiteBitSize) import Data.Function (($), (.)) -import Data.Bool (otherwise) +import Data.Bool (Bool, otherwise, not) import Data.Int (Int) import Data.Word (Word, Word16) import Data.Maybe (Maybe, maybe) @@ -117,21 +117,13 @@ pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of pprLiterals currentModule $ unlinkedBCOLits, pprPointers currentModule $ unlinkedBCOPtrs ] - UnlinkedStaticCon {{-..-}} - -> entry (text "static constructor object:") $ --FIXME: Remove colon and add name. + UnlinkedStaticCon {..} + -> entry (text "static constructor object" <+> ppr unlinkedStaticConName) $ vcat [ - {- - unlinkedStaticConName :: !Name, - -- ^ The name to which this static constructor is bound, not to be - -- confused with the name of the static constructor itself - -- ('unlinkedStaticConDataConName') - unlinkedStaticConDataConName :: !Name, - unlinkedStaticConLits :: !(FlatBag BCONPtr), - -- ^ non-ptrs full words, where sub-word literals have already been - -- packed into full words as needed - unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs - unlinkedStaticConIsUnlifted :: !Bool - -} + pprDataConstructorName $ unlinkedStaticConDataConName, + pprLiftedness $ not unlinkedStaticConIsUnlifted, + pprLiterals currentModule $ unlinkedStaticConLits, + pprPointers currentModule $ unlinkedStaticConPtrs ] -- | […] @@ -146,6 +138,14 @@ pprInstructions = entry (text "instructions:") . pprBCOByteArray pprBitmap :: BCOByteArray Word -> SDoc pprBitmap = entry (text "bitmap:") . pprBCOByteArray +-- | […] +pprDataConstructorName :: Name -> SDoc +pprDataConstructorName = entry (text "data constructor name:") . ppr + +-- | […] +pprLiftedness :: Bool -> SDoc +pprLiftedness = entry (text "lifted:") . noOrYes + -- | […] pprLiterals :: Module -> FlatBag BCONPtr -> SDoc pprLiterals currentModule = entry (text "literals:") . @@ -290,6 +290,10 @@ pprFixedSizeNatural num unpadded :: String unpadded = showHex num "" +-- | […] +noOrYes :: Bool -> SDoc +noOrYes bool = text (if bool then "yes" else "no") + -- | […] entry :: SDoc -> SDoc -> SDoc entry title content = hang title 2 content View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c57dd192360d54e06a8ae14bbdde93… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c57dd192360d54e06a8ae14bbdde93… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Add treatment of `UnlinkedStaticCon`
by Wolfgang Jeltsch (＠jeltsch) 04 Jun '26

04 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: f893ce2c by Wolfgang Jeltsch at 2026-06-04T11:29:05+03:00 Add treatment of `UnlinkedStaticCon` - - - - - 1 changed file: - compiler/GHC/ByteCode/Show.hs Changes: ===================================== compiler/GHC/ByteCode/Show.hs ===================================== @@ -11,7 +11,7 @@ import Control.Exception (assert) import Data.Eq ((==)) import Data.Bits (FiniteBits, finiteBitSize) import Data.Function (($), (.)) -import Data.Bool (otherwise) +import Data.Bool (Bool, otherwise) import Data.Int (Int) import Data.Word (Word, Word16) import Data.Maybe (Maybe, maybe) @@ -117,21 +117,13 @@ pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of pprLiterals currentModule $ unlinkedBCOLits, pprPointers currentModule $ unlinkedBCOPtrs ] - UnlinkedStaticCon {{-..-}} - -> entry (text "static constructor object:") $ --FIXME: Remove colon and add name. + UnlinkedStaticCon {..} + -> entry (text "static constructor object" <+> ppr unlinkedStaticConName) $ vcat [ - {- - unlinkedStaticConName :: !Name, - -- ^ The name to which this static constructor is bound, not to be - -- confused with the name of the static constructor itself - -- ('unlinkedStaticConDataConName') - unlinkedStaticConDataConName :: !Name, - unlinkedStaticConLits :: !(FlatBag BCONPtr), - -- ^ non-ptrs full words, where sub-word literals have already been - -- packed into full words as needed - unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs - unlinkedStaticConIsUnlifted :: !Bool - -} + pprDataConstructorName $ unlinkedStaticConDataConName, + pprNoOrYes $ unlinkedStaticConIsUnlifted, + pprLiterals currentModule $ unlinkedStaticConLits, + pprPointers currentModule $ unlinkedStaticConPtrs ] -- | […] @@ -146,6 +138,10 @@ pprInstructions = entry (text "instructions:") . pprBCOByteArray pprBitmap :: BCOByteArray Word -> SDoc pprBitmap = entry (text "bitmap:") . pprBCOByteArray +-- | […] +pprDataConstructorName :: Name -> SDoc +pprDataConstructorName = entry (text "data constructor name:") . ppr + -- | […] pprLiterals :: Module -> FlatBag BCONPtr -> SDoc pprLiterals currentModule = entry (text "literals:") . @@ -290,6 +286,10 @@ pprFixedSizeNatural num unpadded :: String unpadded = showHex num "" +-- | […] +pprNoOrYes :: Bool -> SDoc +pprNoOrYes bool = text (if bool then "yes" else "no") + -- | […] entry :: SDoc -> SDoc -> SDoc entry title content = hang title 2 content View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f893ce2cf51274c58515305acf3f4d6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f893ce2cf51274c58515305acf3f4d6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T26964] 2 commits: Improve -fcheck-prim-bounds runtime error messages
by Simon Jakobi (＠sjakobi2) 04 Jun '26

04 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T26964 at Glasgow Haskell Compiler / GHC Commits: 64b4252e by Simon Jakobi at 2026-06-04T01:37:58+02:00 Improve -fcheck-prim-bounds runtime error messages When an array access instrumented by -fcheck-prim-bounds fails at runtime, report the failing primop, the offending index and the array size, and exit with a normal failure status. Previously the program aborted via barf with an "internal error" framed as a GHC bug, even though such failures are almost always caused by incorrect use of unsafe primops in user or library code. The primop name is threaded to the failure handlers through a new fcs_prim_op field in FCodeState, set once in cmmPrimOpApp, so the bounds-check sites themselves are unchanged. Fixes #26964, #24617. Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 6bf57c99 by Simon Jakobi at 2026-06-04T01:37:58+02:00 rts: name the primop in DEBUG ASSERT_IN_BOUNDS failures ASSERT_IN_BOUNDS passed the literal "array access" as the op name, which collided with rtsOutOfBoundsAccess's own message text ("<op>: array access out of bounds"), producing the redundant "array access: array access out of bounds". Thread the real primop name (e.g. "casIntArray#") through the macro instead, matching the native code generator's messages. Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 12 changed files: - + changelog.d/improve-check-prim-bounds-messages - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToCmm/Prim.hs - docs/users_guide/debugging.rst - rts/PrimOps.cmm - rts/RtsMessages.c - rts/include/rts/Messages.h - + testsuite/tests/codeGen/should_fail/T26964.hs - + testsuite/tests/codeGen/should_fail/T26964.stderr - + testsuite/tests/codeGen/should_fail/T26964b.hs - + testsuite/tests/codeGen/should_fail/T26964b.stderr - testsuite/tests/codeGen/should_fail/all.T Changes: ===================================== changelog.d/improve-check-prim-bounds-messages ===================================== @@ -0,0 +1,13 @@ +section: codegen +synopsis: Improve ``-fcheck-prim-bounds`` runtime error messages +issues: #26964 #24617 +mrs: !16130 + +description: { + When an array access instrumented by ``-fcheck-prim-bounds`` fails at + runtime, the program now reports the failing primop, the offending index and + the array size, and exits with a normal non-zero status. Previously it + aborted with an "internal error" framed as a GHC bug, even though such + failures are almost always caused by incorrect use of unsafe primops in user + or library code. +} ===================================== compiler/GHC/StgToCmm/Monad.hs ===================================== @@ -42,6 +42,7 @@ module GHC.StgToCmm.Monad ( SelfLoopInfo(..), setTickyCtrLabel, getTickyCtrLabel, + withCurrentPrimOpName, getCurrentPrimOpName, tickScope, getTickScope, withUpdFrameOff, getUpdFrameOff, @@ -304,6 +305,9 @@ data FCodeState = -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr , fcs_ticky :: !CLabel -- ^ Destination for ticky counts , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks + , fcs_prim_op :: Maybe String -- ^ Source name of the primop currently being + -- compiled, used by -fcheck-prim-bounds error + -- messages. } data HeapUsage -- See Note [Virtual and real heap pointers] @@ -462,6 +466,7 @@ initFCodeState p = , fcs_selfloop = Nothing , fcs_ticky = mkTopTickyCtrLabel , fcs_tickscope = GlobalScope + , fcs_prim_op = Nothing } getFCodeState :: FCode FCodeState @@ -520,6 +525,20 @@ setTickyCtrLabel ticky code = do fstate <- getFCodeState withFCodeState code (fstate {fcs_ticky = ticky}) +-- ---------------------------------------------------------------------------- +-- Track the primop currently being compiled + +-- | The source name of the primop currently being compiled (e.g. +-- @"writeArray#"@), if any. Used to produce informative @-fcheck-prim-bounds@ +-- error messages. +getCurrentPrimOpName :: FCode (Maybe String) +getCurrentPrimOpName = fcs_prim_op <$> getFCodeState + +withCurrentPrimOpName :: String -> FCode a -> FCode a +withCurrentPrimOpName name code = do + fstate <- getFCodeState + withFCodeState code (fstate {fcs_prim_op = Just name}) + -- ---------------------------------------------------------------------------- -- Manage tick scopes ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -25,11 +25,13 @@ import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils +import GHC.StgToCmm.Lit ( newStringCLit ) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Types.Basic +import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Literal.Floating import GHC.Cmm.BlockId import GHC.Cmm.Graph @@ -94,7 +96,13 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do -- if the result type isn't explicitly given, we directly use the -- result type of the primop. res_ty = fromMaybe (primOpResultType primop) mres_ty - f res_ty + -- When -fcheck-prim-bounds is on, record the primop name so that any + -- bounds-check failure handler emitted while compiling it can name it in the + -- error message. Guarded by the flag so that the common (unchecked) case pays + -- nothing: no name thunk, no FCodeState update. + if stgToCmmDoBoundsCheck cfg + then withCurrentPrimOpName (occNameString (primOpOcc primop)) (f res_ty) + else f res_ty externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args) @@ -3615,8 +3623,12 @@ emitCheckedMemcpyCall dst src n align = do emitMemcpyCall dst src n align where doCheck platform = do + name <- fromMaybe "<unknown primop>" <$> getCurrentPrimOpName + nameLbl <- newStringCLit name overlapCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) [] + emitCCallNeverReturns [] + (mkLblExpr mkMemcpyRangeOverlapLabel) + [ (CmmLit nameLbl, AddrHint) ] emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False) where rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero @@ -3728,6 +3740,25 @@ whenCheckBounds a = do False -> pure () True -> a +-- | Emit a call to the RTS @rtsOutOfBoundsAccess@ bounds-check failure +-- handler, passing the offending index, the number of accessed elements and +-- the array size, so that the runtime can produce an informative error +-- message. The name of the offending primop is read from the code generator +-- environment (see 'withCurrentPrimOpName'). +emitBoundsCheckFailed :: CmmExpr -- ^ accessed index + -> CmmExpr -- ^ number of accessed elements + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitBoundsCheckFailed idx count sz = do + name <- fromMaybe "<unknown primop>" <$> getCurrentPrimOpName + nameLbl <- newStringCLit name + emitCCallNeverReturns [] + (mkLblExpr mkOutOfBoundsAccessLabel) + [ (idx, NoHint) + , (count, NoHint) + , (sz, NoHint) + , (CmmLit nameLbl, AddrHint) ] + emitBoundsCheck :: CmmExpr -- ^ accessed index -> CmmExpr -- ^ array size (in elements) -> FCode () @@ -3735,7 +3766,7 @@ emitBoundsCheck idx sz = do assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) platform <- getPlatform boundsCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + emitBoundsCheckFailed idx (mkIntExpr platform 1) sz let isOutOfBounds = cmmUGeWord platform idx sz emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) @@ -3754,7 +3785,7 @@ emitRangeBoundsCheck idx len arrSizeExpr = do _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $ cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing boundsCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + emitBoundsCheckFailed idx len arrSize let rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg) lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg) ===================================== docs/users_guide/debugging.rst ===================================== @@ -1167,10 +1167,25 @@ Checking for consistency Typically primops operations like ``writeArray#`` exhibit unsafe behavior, relying on the user to perform any bounds checking. This flag instructs the code generator to instrument such operations with bound checking logic - which aborts the program when an out-of-bounds access is detected. + which terminates the program when an out-of-bounds access is detected. + + When a check fails, the program prints a message naming the offending + primop together with the offending index and the array size, and exits + with a non-zero status, for example:: + + myprog: writeArray#: array access out of bounds: + index 5 is not within [0, 3). + This is usually caused by incorrect use of unsafe primops in user or library code. + + The message does not identify the enclosing function or module. To obtain a + backtrace pinpointing the failing call, build with profiling and run with + ``+RTS -xc`` (see :ref:`prof-time-options`), or use :ghc-flag:`-finfo-table-map` + together with ``+RTS -xc``. Note that this is only intended to be used as a debugging measure, not as - the primary means of catching out-of-bounds accesses. + the primary means of catching out-of-bounds accesses. Currently only the + native code generator is instrumented; the JavaScript backend is unaffected + by this flag. .. ghc-flag:: -fcmm-thread-sanitizer :shortdesc: Enable ThreadSanitizer instrumentation of memory accesses. ===================================== rts/PrimOps.cmm ===================================== @@ -88,10 +88,14 @@ import CLOSURE ghc_hs_iface; #endif #if defined(DEBUG) -#define ASSERT_IN_BOUNDS(ind, sz) \ - if (ind >= sz) { ccall rtsOutOfBoundsAccess(); } +// `op` is the source name of the primop being checked (e.g. "casIntArray#"). +// NB: in some callers `ind` is a byte offset rather than an element index, so +// the index reported here may be in bytes. count is 1 since these checks cover +// a single access. +#define ASSERT_IN_BOUNDS(op, ind, sz) \ + if (ind >= sz) { ccall rtsOutOfBoundsAccess(ind, 1, sz, op); } #else -#define ASSERT_IN_BOUNDS(ind, sz) +#define ASSERT_IN_BOUNDS(op, ind, sz) #endif /*----------------------------------------------------------------------------- @@ -336,7 +340,7 @@ stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new ) { W_ p, h; - ASSERT_IN_BOUNDS(ind + WDS(1) - 1, StgArrBytes_bytes(arr)); + ASSERT_IN_BOUNDS("casIntArray#", ind + WDS(1) - 1, StgArrBytes_bytes(arr)); p = arr + SIZEOF_StgArrBytes + WDS(ind); (h) = prim %cmpxchgW(p, old, new); @@ -350,7 +354,7 @@ stg_casInt8Arrayzh( gcptr arr, W_ ind, I8 old, I8 new ) W_ p; I8 h; - ASSERT_IN_BOUNDS(ind, StgArrBytes_bytes(arr)); + ASSERT_IN_BOUNDS("casInt8Array#", ind, StgArrBytes_bytes(arr)); p = arr + SIZEOF_StgArrBytes + ind; (h) = prim %cmpxchg8(p, old, new); @@ -364,7 +368,7 @@ stg_casInt16Arrayzh( gcptr arr, W_ ind, I16 old, I16 new ) W_ p; I16 h; - ASSERT_IN_BOUNDS(ind + 1, StgArrBytes_bytes(arr)); + ASSERT_IN_BOUNDS("casInt16Array#", ind + 1, StgArrBytes_bytes(arr)); p = arr + SIZEOF_StgArrBytes + ind*2; (h) = prim %cmpxchg16(p, old, new); @@ -378,7 +382,7 @@ stg_casInt32Arrayzh( gcptr arr, W_ ind, I32 old, I32 new ) W_ p; I32 h; - ASSERT_IN_BOUNDS(ind + 3, StgArrBytes_bytes(arr)); + ASSERT_IN_BOUNDS("casInt32Array#", ind + 3, StgArrBytes_bytes(arr)); p = arr + SIZEOF_StgArrBytes + ind*4; (h) = prim %cmpxchg32(p, old, new); @@ -392,7 +396,7 @@ stg_casInt64Arrayzh( gcptr arr, W_ ind, I64 old, I64 new ) W_ p; I64 h; - ASSERT_IN_BOUNDS(ind + 7, StgArrBytes_bytes(arr)); + ASSERT_IN_BOUNDS("casInt64Array#", ind + 7, StgArrBytes_bytes(arr)); p = arr + SIZEOF_StgArrBytes + ind*8; (h) = prim %cmpxchg64(p, old, new); @@ -470,7 +474,7 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) gcptr h; W_ p, len; - ASSERT_IN_BOUNDS(ind, StgMutArrPtrs_ptrs(arr)); + ASSERT_IN_BOUNDS("casArray#", ind, StgMutArrPtrs_ptrs(arr)); p = arr + SIZEOF_StgMutArrPtrs + WDS(ind); (h) = prim %cmpxchgW(p, old, new); @@ -578,8 +582,8 @@ stg_copySmallArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n) SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info); - ASSERT_IN_BOUNDS(dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst)); - ASSERT_IN_BOUNDS(src_off + n - 1, StgSmallMutArrPtrs_ptrs(src)); + ASSERT_IN_BOUNDS("copySmallArray#", dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst)); + ASSERT_IN_BOUNDS("copySmallArray#", src_off + n - 1, StgSmallMutArrPtrs_ptrs(src)); dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off); src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off); bytes = WDS(n); @@ -601,8 +605,8 @@ stg_copySmallMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info); - ASSERT_IN_BOUNDS(dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst)); - ASSERT_IN_BOUNDS(src_off + n - 1, StgSmallMutArrPtrs_ptrs(src)); + ASSERT_IN_BOUNDS("copySmallMutableArray#", dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst)); + ASSERT_IN_BOUNDS("copySmallMutableArray#", src_off + n - 1, StgSmallMutArrPtrs_ptrs(src)); dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off); src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off); bytes = WDS(n); @@ -623,7 +627,7 @@ stg_casSmallArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) gcptr h; W_ p, len; - ASSERT_IN_BOUNDS(ind, StgSmallMutArrPtrs_ptrs(arr)); + ASSERT_IN_BOUNDS("casSmallArray#", ind, StgSmallMutArrPtrs_ptrs(arr)); p = arr + SIZEOF_StgSmallMutArrPtrs + WDS(ind); (h) = prim %cmpxchgW(p, old, new); ===================================== rts/RtsMessages.c ===================================== @@ -352,13 +352,32 @@ rtsBadAlignmentBarf(void) } void -rtsOutOfBoundsAccess(void) +rtsOutOfBoundsAccess(StgInt index, StgWord count, StgWord size, const char *op) { - barf("Encountered out of bounds array access."); + if (count <= 1) { + errorBelch("%s: array access out of bounds:\n" + " index %" FMT_Int " is not within [0, %" FMT_Word ").\n" + "This is usually caused by incorrect use of unsafe primops " + "in user or library code.", + op, index, size); + } else { + errorBelch("%s: array access out of bounds:\n" + " range of %" FMT_Word " elements starting at index %" FMT_Int + " is not within [0, %" FMT_Word ").\n" + "This is usually caused by incorrect use of unsafe primops " + "in user or library code.", + op, count, index, size); + } + stg_exit(EXIT_FAILURE); } void -rtsMemcpyRangeOverlap(void) +rtsMemcpyRangeOverlap(const char *op) { - barf("Encountered overlapping source/destination ranges in a memcpy-using op."); + errorBelch("%s: overlapping source and destination ranges in a " + "memcpy-using operation.\n" + "This is usually caused by incorrect use of unsafe primops " + "in user or library code.", + op); + stg_exit(EXIT_FAILURE); } ===================================== rts/include/rts/Messages.h ===================================== @@ -108,5 +108,5 @@ extern RtsMsgFunction rtsSysErrorMsgFn; /* Used by code generator */ void rtsBadAlignmentBarf(void) STG_NORETURN; -void rtsOutOfBoundsAccess(void) STG_NORETURN; -void rtsMemcpyRangeOverlap(void) STG_NORETURN; +void rtsOutOfBoundsAccess(StgInt index, StgWord count, StgWord size, const char *op) STG_NORETURN; +void rtsMemcpyRangeOverlap(const char *op) STG_NORETURN; ===================================== testsuite/tests/codeGen/should_fail/T26964.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +-- Test that -fcheck-prim-bounds reports the failing primop, the offending +-- index and the array size. The negative index also checks that it is reported +-- as a signed number (e.g. -1, not a huge unsigned word). + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newSmallArray# 5# () s0 of + (# s1, marr #) -> readSmallArray# marr (-1#) s1 ===================================== testsuite/tests/codeGen/should_fail/T26964.stderr ===================================== @@ -0,0 +1,3 @@ +readSmallArray#: array access out of bounds: + index -1 is not within [0, 5). +This is usually caused by incorrect use of unsafe primops in user or library code. ===================================== testsuite/tests/codeGen/should_fail/T26964b.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +-- Test that -fcheck-prim-bounds reports a failing *range* access (count > 1) +-- with the "range of N elements starting at index" wording. The source range +-- is in bounds, but the destination range [6, 10) overruns the 8-byte array. + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = IO $ \s0 -> + case newByteArray# 8# s0 of + (# s1, src #) -> + case newByteArray# 8# s1 of + (# s2, dst #) -> + case copyMutableByteArray# src 0# dst 6# 4# s2 of + s3 -> (# s3, () #) ===================================== testsuite/tests/codeGen/should_fail/T26964b.stderr ===================================== @@ -0,0 +1,3 @@ +copyMutableByteArray#: array access out of bounds: + range of 4 elements starting at index 6 is not within [0, 8). +This is usually caused by incorrect use of unsafe primops in user or library code. ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -6,8 +6,10 @@ test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main']) def check_bounds_test(name): """ A -fcheck-prim-bounds test that is expected to fail. """ + # The native backend exits with EXIT_FAILURE (1); the JS backend still + # aborts with h$exitProcess(134) (the improved messages are native-only). test(name, - [ignore_stderr, omit_ghci, exit_code(127 if opsys('mingw32') else 134)], + [ignore_stderr, omit_ghci, exit_code(134 if js_arch() else 1)], compile_and_run, ['-fcheck-prim-bounds']) check_bounds_test('CheckBoundsWriteArray') # Check past end @@ -25,3 +27,18 @@ check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') check_bounds_test('T26958') + +# Unlike the check_bounds_test cases above, these tests pin down the exact +# -fcheck-prim-bounds error message. Drop the leading "<prog>: " prefix so the +# tests don't depend on the binary's name/path (incl. Windows drive letters). +def strip_prog_prefix(s): + return re.sub(r'(?m)^.*?(\w+#: array access)', r'\1', s) + +# T26964 checks the single-element message. T26964b checks the range variant. +# Skipped on the JS backend, which emits no message and aborts with code 134. +test('T26964', + [omit_ghci, js_skip, exit_code(1), normalise_errmsg_fun(strip_prog_prefix)], + compile_and_run, ['-fcheck-prim-bounds']) +test('T26964b', + [omit_ghci, js_skip, exit_code(1), normalise_errmsg_fun(strip_prog_prefix)], + compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faeb0540a61b6f4e3fa1210ae364f4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faeb0540a61b6f4e3fa1210ae364f4… You're receiving this email because of your account on gitlab.haskell.org.

1 0