GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

e650ec3e

by Ben Gamari at 2025-05-23T03:42:46-04:00

base: Forward port changelog language from 9.12

94cd9ca4
by Ben Gamari at 2025-05-23T03:42:46-04:00
```
base: Fix RestructuredText-isms in changelog
```

7722232c

by Ben Gamari at 2025-05-23T03:42:46-04:00

base: Note strictness changes made in 4.16.0.0

Addresses #25886.

3f4b823c

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker: Factor out ProddableBlocks machinery

6e23fef2

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker: Improve efficiency of proddable blocks structure

Previously the linker's "proddable blocks" check relied on a simple
linked list of spans. This resulted in extremely poor complexity while
linking objects with lots of small sections (e.g. objects built with
split sections).

Rework the mechanism to instead use a simple interval set implemented
via binary search.

Fixes #26009.

ea74860c

by Ben Gamari at 2025-05-23T03:43:28-04:00

testsuite: Add simple functional test for ProddableBlockSet

74c4db46

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS

The `LOAD_LIBRARY_SEARCH_USER_DIRS` and
`LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and
have been available every since. As we no longer support Windows XP we
can drop this check.

Addresses #26009.

972d81d6
by Ben Gamari at 2025-05-23T03:43:28-04:00
```
rts/linker/PEi386: Clean up code style
```

8a1073a5

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/Hash: Factor out hashBuffer

This is a useful helper which can be used for non-strings as well.

44f509f2

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker/PEi386: Fix incorrect use of break in nested for

Previously the happy path of PEi386 used `break` in a double-`for` loop
resulting in redundant calls to `LoadLibraryEx`.

Fixes #26052.

bfb12783
by Ben Gamari at 2025-05-23T03:43:28-04:00
```
rts: Correctly mark const arguments
```

08469ff8

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker/PEi386: Don't repeatedly load DLLs

Previously every DLL-imported symbol would result in a call to
`LoadLibraryEx`. This ended up constituting over 40% of the runtime of
`ghc --interactive -e 42` on Windows. Avoid this by maintaining a
hash-set of loaded DLL names, skipping the call if we have already
loaded the requested DLL.

Addresses #26009.

823d1ccf

by Ben Gamari at 2025-05-23T03:43:28-04:00

rts/linker: Expand comment describing ProddableBlockSet

f9501cef

by Sylvain Henry at 2025-05-23T10:21:43-04:00

Remove emptyModBreaks

Remove emptyModBreaks and track the absence of ModBreaks with `Maybe
ModBreaks`. It avoids testing for null pointers...

f422b3c7

by Ben Gamari at 2025-05-23T10:21:45-04:00

base: Expose Backtraces constructor and fields

This was specified in the proposal (CLC #199) yet somehow didn't make it
into the implementation.

Fixes #26049.

30 changed files:

compiler/GHC.hs
compiler/GHC/ByteCode/Types.hs
compiler/GHC/HsToCore/Breakpoints.hs
compiler/GHC/Runtime/Debugger/Breakpoints.hs
compiler/GHC/Runtime/Eval.hs
compiler/GHC/Runtime/Interpreter.hs
compiler/GHC/StgToByteCode.hs
ghc/GHCi/UI.hs
libraries/base/changelog.md
libraries/base/src/Control/Exception/Backtrace.hs
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
rts/Hash.c
rts/Hash.h
rts/Linker.c
rts/LinkerInternals.h
rts/PathUtils.c
rts/PathUtils.h
rts/linker/Elf.c
rts/linker/MachO.c
rts/linker/PEi386.c
rts/linker/PEi386.h
+ rts/linker/ProddableBlocks.c
+ rts/linker/ProddableBlocks.h
rts/rts.cabal
testsuite/tests/interface-stability/base-exports.stdout
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
testsuite/tests/interface-stability/base-exports.stdout-mingw32
testsuite/tests/interface-stability/base-exports.stdout-ws-32
+ testsuite/tests/rts/TestProddableBlockSet.c
testsuite/tests/rts/all.T

Changes:

compiler/GHC.hs

@@ -1307,7 +1307,7 @@ typecheckModule pmod = do
             minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,
             minf_iface     = Nothing,
             minf_safe      = safe,
 -           minf_modBreaks = emptyModBreaks
 +           minf_modBreaks = Nothing
           }}
  -- | Desugar a typechecked module.
@@ -1461,7 +1461,7 @@ data ModuleInfo = ModuleInfo {
          minf_instances :: [ClsInst],
          minf_iface     :: Maybe ModIface,
          minf_safe      :: SafeHaskellMode,
 -        minf_modBreaks :: ModBreaks
 +        minf_modBreaks :: Maybe ModBreaks
+   }
          -- We don't want HomeModInfo here, because a ModuleInfo applies
          -- to package modules too.
@@ -1490,7 +1490,7 @@ getPackageModuleInfo hsc_env mdl
                          minf_instances = error "getModuleInfo: instances for package module unimplemented",
                          minf_iface     = Just iface,
                          minf_safe      = getSafeMode $ mi_trust iface,
 -                        minf_modBreaks = emptyModBreaks
 +                        minf_modBreaks = Nothing
                  }))
  availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
@@ -1567,7 +1567,7 @@ modInfoIface = minf_iface
  modInfoSafe :: ModuleInfo -> SafeHaskellMode
  modInfoSafe = minf_safe
 -modInfoModBreaks :: ModuleInfo -> ModBreaks
 +modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks
  modInfoModBreaks = minf_modBreaks
  isDictonaryId :: Id -> Bool

compiler/GHC/ByteCode/Types.hs

@@ -19,7 +19,7 @@ module GHC.ByteCode.Types
    , ItblEnv, ItblPtr(..)
    , AddrEnv, AddrPtr(..)
    , CgBreakInfo(..)
 -  , ModBreaks (..), BreakIndex, emptyModBreaks
 +  , ModBreaks (..), BreakIndex
    , CCostCentre
    , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag
    ) where
@@ -45,12 +45,11 @@ import Foreign
  import Data.Array
  import Data.ByteString (ByteString)
  import Data.IntMap (IntMap)
 -import qualified Data.IntMap as IntMap
  import qualified GHC.Exts.Heap as Heap
  import GHC.Stack.CCS
  import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
  import GHC.Iface.Syntax
 -import Language.Haskell.Syntax.Module.Name (ModuleName, mkModuleNameFS)
 +import Language.Haskell.Syntax.Module.Name (ModuleName)
  import GHC.Unit.Types (UnitId(..))
  -- -----------------------------------------------------------------------------
@@ -250,7 +249,7 @@ data CCostCentre
  -- | All the information about the breakpoints for a module
  data ModBreaks
     = ModBreaks
 -   { modBreaks_flags :: ForeignRef BreakArray
 +   { modBreaks_flags :: !(ForeignRef BreakArray)
          -- ^ The array of flags, one per breakpoint,
          -- indicating which breakpoints are enabled.
     , modBreaks_locs :: !(Array BreakIndex SrcSpan)
@@ -281,20 +280,6 @@ seqModBreaks ModBreaks{..} =
    rnf modBreaks_module `seq`
    rnf modBreaks_module_unitid
 --- | Construct an empty ModBreaks
 -emptyModBreaks :: ModBreaks
 -emptyModBreaks = ModBreaks
 -   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
 -         -- ToDo: can we avoid this?
 -   , modBreaks_locs  = array (0,-1) []
 -   , modBreaks_vars  = array (0,-1) []
 -   , modBreaks_decls = array (0,-1) []
 -   , modBreaks_ccs = array (0,-1) []
 -   , modBreaks_breakInfo = IntMap.empty
 -   , modBreaks_module = mkModuleNameFS nilFS
 -   , modBreaks_module_unitid = UnitId nilFS
 -   }
+-
  {-
  Note [Field modBreaks_decls]
  ~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/HsToCore/Breakpoints.hs

@@ -18,6 +18,7 @@ import GHC.Utils.Outputable as Outputable
  import Data.List (intersperse)
  import Data.Array
 +import qualified Data.IntMap as IntMap
  -- | Initialize memory for breakpoint data that is shared between the bytecode
  -- generator and the interpreter.
@@ -38,15 +39,16 @@ mkModBreaks interp mod extendedMixEntries
             locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]
             varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]
             declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
 -    return $ emptyModBreaks
 -                       { modBreaks_flags  = breakArray
 -                       , modBreaks_locs   = locsTicks
 -                       , modBreaks_vars   = varsTicks
 -                       , modBreaks_decls  = declsTicks
 -                       , modBreaks_ccs    = ccs
 -                       , modBreaks_module = moduleName mod
 -                       , modBreaks_module_unitid = toUnitId $ moduleUnit mod
 -                       }
 +    return $ ModBreaks
 +      { modBreaks_flags  = breakArray
 +      , modBreaks_locs   = locsTicks
 +      , modBreaks_vars   = varsTicks
 +      , modBreaks_decls  = declsTicks
 +      , modBreaks_ccs    = ccs
 +      , modBreaks_breakInfo = IntMap.empty
 +      , modBreaks_module = moduleName mod
 +      , modBreaks_module_unitid = toUnitId $ moduleUnit mod
 +      }
  mkCCSArray
    :: Interp -> Module -> Int -> [Tick]

compiler/GHC/Runtime/Debugger/Breakpoints.hs

@@ -145,15 +145,17 @@ resolveFunctionBreakpoint inp = do
      validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"
      validateBP _ fun_str (Just modl) = do
          isInterpr <- GHC.moduleIsInterpreted modl
 -        (_, decls) <- getModBreak modl
          mb_err_msg <- case isInterpr of
 -          False -> pure $ Just $ text "Module" <+> quotes (ppr modl)
 -                        <+> text "is not interpreted"
 -          True -> case fun_str `elem` (intercalate "." <$> elems decls) of
 -                False -> pure $ Just $
 -                   text "No breakpoint found for" <+> quotes (text fun_str)
 -                   <+> text "in module" <+> quotes (ppr modl)
 -                True  -> pure Nothing
 +          False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted"
 +          True -> do
 +            mb_modbreaks <- getModBreak modl
 +            let found = case mb_modbreaks of
 +                  Nothing -> False
 +                  Just mb -> fun_str `elem` (intercalate "." <$> elems (GHC.modBreaks_decls mb))
 +            if found
 +              then pure Nothing
 +              else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str)
 +                                  <+> text "in module" <+> quotes (ppr modl)
          pure mb_err_msg
  -- | The aim of this function is to find the breakpoints for all the RHSs of
@@ -184,8 +186,7 @@ type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
  makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray)
  makeModuleLineMap m = do
    mi <- GHC.getModuleInfo m
 -  return $
 -    mkTickArray . assocs . GHC.modBreaks_locs . GHC.modInfoModBreaks <$> mi
 +  return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi)
    where
      mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray
      mkTickArray ticks
@@ -195,15 +196,12 @@ makeModuleLineMap m = do
              max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
              srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]
 --- | Get the 'modBreaks_locs' and 'modBreaks_decls' of the given 'Module'
 +-- | Get the 'ModBreaks' of the given 'Module' when available
  getModBreak :: GHC.GhcMonad m
 -            => Module -> m (Array Int SrcSpan, Array Int [String])
 +            => Module -> m (Maybe ModBreaks)
  getModBreak m = do
     mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
 -   let modBreaks  = GHC.modInfoModBreaks mod_info
 -   let ticks      = GHC.modBreaks_locs  modBreaks
 -   let decls      = GHC.modBreaks_decls modBreaks
 -   return (ticks, decls)
 +   pure $ GHC.modInfoModBreaks mod_info
  --------------------------------------------------------------------------------
  -- Getting current breakpoint information

compiler/GHC/Runtime/Eval.hs

@@ -522,9 +522,8 @@ result_fs = fsLit "_result"
  -- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
  readModBreaks :: HscEnv -> Module -> IO ModBreaks
 -readModBreaks hsc_env mod =
 -  getModBreaks . expectJust <$>
 -    HUG.lookupHugByModule mod (hsc_HUG hsc_env)
 +readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env)
++
  bindLocalsAtBreakpoint
          :: HscEnv

compiler/GHC/Runtime/Interpreter.hs

@@ -435,22 +435,24 @@ handleSeqHValueStatus interp unit_env eval_status =
        resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
        let put x = putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe x))
 +      let nothing_case = put $ brackets . ppr $ mkGeneralSrcSpan (fsLit "<unknown>")
        case maybe_break of
 -        Nothing ->
 +        Nothing -> nothing_case
            -- Nothing case - should not occur!
            -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
 -          put $ brackets . ppr $
 -            mkGeneralSrcSpan (fsLit "<unknown>")
          Just break -> do
            let bi = evalBreakpointToId break
            -- Just case: Stopped at a breakpoint, extract SrcSpan information
            -- from the breakpoint.
 -          breaks_tick <- getModBreaks . expectJust <$>
 +          mb_modbreaks <- getModBreaks . expectJust <$>
                            lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
 -          put $ brackets . ppr $
 -            (modBreaks_locs breaks_tick) ! ibi_tick_index bi
 +          case mb_modbreaks of
 +            -- Nothing case - should not occur! We should have the appropriate
 +            -- breakpoint information
 +            Nothing -> nothing_case
 +            Just modbreaks -> put $ brackets . ppr $ (modBreaks_locs modbreaks) ! ibi_tick_index bi
        -- resume the seq (:force) processing in the iserv process
        withForeignRef resume_ctxt_fhv $ \hval -> do
@@ -737,14 +739,14 @@ fromEvalResult :: EvalResult a -> IO a
  fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
  fromEvalResult (EvalSuccess a) = return a
 -getModBreaks :: HomeModInfo -> ModBreaks
 +getModBreaks :: HomeModInfo -> Maybe ModBreaks
  getModBreaks hmi
    | Just linkable <- homeModInfoByteCode hmi,
      -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
      [cbc] <- linkableBCOs linkable
 -  = fromMaybe emptyModBreaks (bc_breaks cbc)
 +  = bc_breaks cbc
    | otherwise
 -  = emptyModBreaks -- probably object code
 +  = Nothing -- probably object code
  -- | Interpreter uses Profiling way
  interpreterProfiled :: Interp -> Bool

compiler/GHC/StgToByteCode.hs

@@ -439,8 +439,8 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs
  --
  -- If the breakpoint is inlined from another module, look it up in the home
  -- package table.
 --- If the module doesn't exist there, or its module pointer is null (which means
 --- that the 'ModBreaks' value is uninitialized), skip the instruction.
 +-- If the module doesn't exist there, or if the 'ModBreaks' value is
 +-- uninitialized, skip the instruction (i.e. return Nothing).
  break_info ::
    HscEnv ->
    Module ->
@@ -449,18 +449,11 @@ break_info ::
    BcM (Maybe ModBreaks)
  break_info hsc_env mod current_mod current_mod_breaks
    | mod == current_mod
 -  = pure $ check_mod_ptr =<< current_mod_breaks
 +  = pure current_mod_breaks
    | otherwise
    = ioToBc (lookupHpt (hsc_HPT hsc_env) (moduleName mod)) >>= \case
 -      Just hp -> pure $ check_mod_ptr (getModBreaks hp)
 +      Just hp -> pure $ getModBreaks hp
        Nothing -> pure Nothing
 -  where
 -    check_mod_ptr mb
 -      | mod_ptr <- modBreaks_module mb
 -      , not $ nullFS $ moduleNameFS mod_ptr
 -      = Just mb
 -      | otherwise
 -      = Nothing
  getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
  getVarOffSets platform depth env = map getOffSet

ghc/GHCi/UI.hs

@@ -3629,8 +3629,10 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
      -- Return all possible bids for a given Module
      bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
      bidsByModule nonquals mod = do
 -      (_, decls) <- getModBreak mod
 -      let bids = nub $ declPath <$> elems decls
 +      mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod
 +      let bids = case mb_decls of
 +            Just decls -> nub $ declPath <$> elems decls
 +            Nothing -> []
        pure $ case (moduleName mod) `elem` nonquals of
                True  -> bids
                False -> (combineModIdent (showModule mod)) <$> bids
@@ -3656,11 +3658,14 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
      -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
      addNestedDecls :: GhciMonad m => (String, Module) -> m [String]
      addNestedDecls (ident, mod) = do
 -        (_, decls) <- getModBreak mod
 -        let (mod_str, topLvl, _) = splitIdent ident
 -            ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
 -            bids = nub $ declPath <$> ident_decls
 -        pure $ map (combineModIdent mod_str) bids
 +        mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod
 +        case mb_decls of
 +          Nothing -> pure []
 +          Just decls -> do
 +            let (mod_str, topLvl, _) = splitIdent ident
 +                ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
 +                bids = nub $ declPath <$> ident_decls
 +            pure $ map (combineModIdent mod_str) bids
  completeModule = wrapIdentCompleterMod $ \w -> do
    hsc_env <- GHC.getSession
@@ -4066,7 +4071,7 @@ breakById inp = do
    case mb_error of
      Left sdoc -> printForUser sdoc
      Right (mod, mod_info, fun_str) -> do
 -      let modBreaks = GHC.modInfoModBreaks mod_info
 +      let modBreaks = expectJust (GHC.modInfoModBreaks mod_info)
        findBreakAndSet mod $ \_ -> findBreakForBind fun_str modBreaks
  breakSyntax :: a

libraries/base/changelog.md

@@ -22,11 +22,13 @@
        * `GHC.TypeNats.Internal`
        * `GHC.ExecutionStack.Internal`.
    * Deprecate `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329)
 +  * Expose constructor and field of `Backtraces` from `Control.Exception.Backtrace`, as per [CLC #199](https://github.com/haskell/core-libraries-committee/issues/199#issuecomment-1954662391)
    * Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)).
 -## 4.21.0.0 *TBA*
 +## 4.21.0.0 *December 2024*
 +  * Shipped with GHC 9.12.1
    * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55))
    * Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))
    * Deprecate export of `Bounded` class from `Data.Enum` ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))
@@ -311,29 +313,29 @@
    * Re-export the `IsList` typeclass from the new `GHC.IsList` module.
 -  * There's a new special function ``withDict`` in ``GHC.Exts``: ::
 +  * There's a new special function `withDict` in `GHC.Exts`: ::
          withDict :: forall {rr :: RuntimeRep} cls meth (r :: TYPE rr). WithDict cls meth => meth -> (cls => r) -> r
 -    where ``cls`` must be a class containing exactly one method, whose type
 -    must be ``meth``.
 +    where `cls` must be a class containing exactly one method, whose type
 +    must be `meth`.
 -    This function converts ``meth`` to a type class dictionary.
 -    It removes the need for ``unsafeCoerce`` in implementation of reflection
 +    This function converts `meth` to a type class dictionary.
 +    It removes the need for `unsafeCoerce` in implementation of reflection
      libraries. It should be used with care, because it can introduce
      incoherent instances.
 -    For example, the ``withTypeable`` function from the
 -    ``Type.Reflection`` module can now be defined as: ::
 +    For example, the `withTypeable` function from the
 +    `Type.Reflection` module can now be defined as: ::
            withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()
                         => TypeRep a -> (Typeable a => r) -> r
            withTypeable rep k = withDict @(Typeable a) rep k
      Note that the explicit type application is required, as the call to
 -    ``withDict`` would be ambiguous otherwise.
 +    `withDict` would be ambiguous otherwise.
 -    This replaces the old ``GHC.Exts.magicDict``, which required
 +    This replaces the old `GHC.Exts.magicDict`, which required
      an intermediate data type and was less reliable.
    * `Data.Word.Word64` and `Data.Int.Int64` are now always represented by
@@ -351,17 +353,17 @@
    * Shipped with GHC 9.2.4
 -  * winio: make consoleReadNonBlocking not wait for any events at all.
 +  * winio: make `consoleReadNonBlocking` not wait for any events at all.
 -  * winio: Add support to console handles to handleToHANDLE
 +  * winio: Add support to console handles to `handleToHANDLE`
  ## 4.16.2.0 *May 2022*
    * Shipped with GHC 9.2.2
 -  * Export GHC.Event.Internal on Windows (#21245)
 +  * Export `GHC.Event.Internal` on Windows (#21245)
 -  # Documentation Fixes
 +  * Documentation Fixes
  ## 4.16.1.0 *Feb 2022*
@@ -430,10 +432,17 @@
      - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument,
        and whose `Semigroup` instances are defined using `(.&.)`, `(.|.)`, `xor`
 -      and ```\x y -> complement (x `xor` y)```, respectively.
 +      and `\x y -> complement (x `xor` y)`, respectively.
      - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`.
 +  * Various folding operations in `GHC.List` are now implemented via strict
 +    folds:
 +    - `sum`
 +    - `product`
 +    - `maximum`
 +    - `minimum`
++
  ## 4.15.0.0 *Feb 2021*
    * Shipped with GHC 9.0.1

libraries/base/src/Control/Exception/Backtrace.hs

@@ -51,7 +51,7 @@ module Control.Exception.Backtrace
      , getBacktraceMechanismState
      , setBacktraceMechanismState
        -- * Collecting backtraces
 -    , Backtraces
 +    , Backtraces(..)
      , displayBacktraces
      , collectBacktraces
      ) where

libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs

@@ -9,7 +9,7 @@ module GHC.Internal.Exception.Backtrace
      , getBacktraceMechanismState
      , setBacktraceMechanismState
        -- * Collecting backtraces
 -    , Backtraces
 +    , Backtraces(..)
      , displayBacktraces
      , collectBacktraces
      ) where

rts/Hash.c

@@ -94,13 +94,13 @@ hashWord(const HashTable *table, StgWord key)
+ }
  int
 -hashStr(const HashTable *table, StgWord w)
 +hashBuffer(const HashTable *table, const void *buf, size_t len)
+ {
 -    const char *key = (char*) w;
 +    const char *key = (char*) buf;
  #if WORD_SIZE_IN_BITS == 64
 -    StgWord h = XXH3_64bits_withSeed (key, strlen(key), 1048583);
 +    StgWord h = XXH3_64bits_withSeed (key, len, 1048583);
  #else
 -    StgWord h = XXH32 (key, strlen(key), 1048583);
 +    StgWord h = XXH32 (key, len, 1048583);
  #endif
      /* Mod the size of the hash table (a power of 2) */
@@ -114,6 +114,13 @@ hashStr(const HashTable *table, StgWord w)
      return bucket;
+ }
 +int
 +hashStr(const HashTable *table, StgWord w)
 +{
 +    const char *key = (char*) w;
 +    return hashBuffer(table, key, strlen(key));
 +}
++
  STATIC_INLINE int
  compareWord(StgWord key1, StgWord key2)
+ {

rts/Hash.h

@@ -69,6 +69,10 @@ void *      removeStrHashTable ( StrHashTable *table, const char * key,
   */
  typedef int HashFunction(const HashTable *table, StgWord key);
  typedef int CompareFunction(StgWord key1, StgWord key2);
++
 +// Helper for implementing hash functions
 +int hashBuffer(const HashTable *table, const void *buf, size_t len);
++
  int hashWord(const HashTable *table, StgWord key);
  int hashStr(const HashTable *table, StgWord w);
  void        insertHashTable_ ( HashTable *table, StgWord key,
@@ -79,6 +83,7 @@ void *      removeHashTable_ ( HashTable *table, StgWord key,
                                 const void *data, HashFunction f,
                                 CompareFunction cmp );
++
  /* Freeing hash tables
   */
  void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) );

rts/Linker.c

@@ -1194,7 +1194,7 @@ void freeObjectCode (ObjectCode *oc)
          stgFree(oc->sections);
+     }
 -    freeProddableBlocks(oc);
 +    freeProddableBlocks(&oc->proddables);
      freeSegments(oc);
      /* Free symbol_extras.  On x86_64 Windows, symbol_extras are allocated
@@ -1279,7 +1279,7 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
     oc->sections          = NULL;
     oc->n_segments        = 0;
     oc->segments          = NULL;
 -   oc->proddables        = NULL;
 +   initProddableBlockSet(&oc->proddables);
     oc->foreign_exports   = NULL;
  #if defined(NEED_SYMBOL_EXTRAS)
     oc->symbol_extras     = NULL;
@@ -1834,50 +1834,6 @@ OStatus getObjectLoadStatus (pathchar *path)
      return r;
+ }
 -/* -----------------------------------------------------------------------------
 - * Sanity checking.  For each ObjectCode, maintain a list of address ranges
 - * which may be prodded during relocation, and abort if we try and write
 - * outside any of these.
 - */
 -void
 -addProddableBlock ( ObjectCode* oc, void* start, int size )
 -{
 -   ProddableBlock* pb
 -      = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
+-
 -   IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size));
 -   ASSERT(size > 0);
 -   pb->start      = start;
 -   pb->size       = size;
 -   pb->next       = oc->proddables;
 -   oc->proddables = pb;
 -}
+-
 -void
 -checkProddableBlock (ObjectCode *oc, void *addr, size_t size )
 -{
 -   ProddableBlock* pb;
+-
 -   for (pb = oc->proddables; pb != NULL; pb = pb->next) {
 -      char* s = (char*)(pb->start);
 -      char* e = s + pb->size;
 -      char* a = (char*)addr;
 -      if (a >= s && (a+size) <= e) return;
 -   }
 -   barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr);
 -}
+-
 -void freeProddableBlocks (ObjectCode *oc)
 -{
 -    ProddableBlock *pb, *next;
+-
 -    for (pb = oc->proddables; pb != NULL; pb = next) {
 -        next = pb->next;
 -        stgFree(pb);
 -    }
 -    oc->proddables = NULL;
 -}
+-
  /* -----------------------------------------------------------------------------
   * Section management.
   */

rts/LinkerInternals.h

@@ -12,6 +12,7 @@
  #include "RtsSymbols.h"
  #include "Hash.h"
  #include "linker/M32Alloc.h"
 +#include "linker/ProddableBlocks.h"
  #if RTS_LINKER_USE_MMAP
  #include <sys/mman.h>
@@ -175,14 +176,6 @@ struct _Section {
    struct SectionFormatInfo* info;
  };
 -typedef
 -   struct _ProddableBlock {
 -      void* start;
 -      int   size;
 -      struct _ProddableBlock* next;
 -   }
 -   ProddableBlock;
+-
  typedef struct _Segment {
      void *start;                /* page aligned start address of a segment */
      size_t size;                /* page rounded size of a segment */
@@ -328,7 +321,7 @@ struct _ObjectCode {
      /* SANITY CHECK ONLY: a list of the only memory regions which may
         safely be prodded during relocation.  Any attempt to prod
         outside one of these is an error in the linker. */
 -    ProddableBlock* proddables;
 +    ProddableBlockSet proddables;
  #if defined(NEED_SYMBOL_EXTRAS)
      SymbolExtra    *symbol_extras;
@@ -434,10 +427,6 @@ void exitLinker( void );
  void freeObjectCode (ObjectCode *oc);
  SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo);
 -void addProddableBlock ( ObjectCode* oc, void* start, int size );
 -void checkProddableBlock (ObjectCode *oc, void *addr, size_t size );
 -void freeProddableBlocks (ObjectCode *oc);
+-
  void addSection (Section *s, SectionKind kind, SectionAlloc alloc,
                   void* start, StgWord size, StgWord mapped_offset,
                   void* mapped_start, StgWord mapped_size);

rts/PathUtils.c

@@ -13,7 +13,7 @@
  #include <wchar.h>
  #endif
 -pathchar* pathdup(pathchar *path)
 +pathchar* pathdup(const pathchar *path)
+ {
      pathchar *ret;
  #if defined(mingw32_HOST_OS)
@@ -26,7 +26,7 @@ pathchar* pathdup(pathchar *path)
      return ret;
+ }
 -pathchar* pathdir(pathchar *path)
 +pathchar* pathdir(const pathchar *path)
+ {
      pathchar *ret;
  #if defined(mingw32_HOST_OS)
@@ -40,7 +40,8 @@ pathchar* pathdir(pathchar *path)
      stgFree(drive);
      stgFree(dirName);
  #else
 -    pathchar* dirName = dirname(path);
 +    // N.B. cast is safe as we do not modify dirName
 +    const pathchar* dirName = dirname((pathchar *) path);
      size_t memberLen  = pathlen(dirName);
      ret = stgMallocBytes(pathsize * (memberLen + 2), "pathdir(path)");
      strcpy(ret, dirName);
@@ -50,7 +51,7 @@ pathchar* pathdir(pathchar *path)
      return ret;
+ }
 -pathchar* mkPath(char* path)
 +pathchar* mkPath(const char* path)
+ {
  #if defined(mingw32_HOST_OS)
      size_t required = mbstowcs(NULL, path, 0);
@@ -66,7 +67,7 @@ pathchar* mkPath(char* path)
  #endif
+ }
 -HsBool endsWithPath(pathchar* base, pathchar* str) {
 +HsBool endsWithPath(const pathchar* base, const pathchar* str) {
      int blen = pathlen(base);
      int slen = pathlen(str);
      return (blen >= slen) && (0 == pathcmp(base + blen - slen, str));

rts/PathUtils.h

@@ -37,9 +37,9 @@
  #include "BeginPrivate.h"
 -pathchar* pathdup(pathchar *path);
 -pathchar* pathdir(pathchar *path);
 -pathchar* mkPath(char* path);
 -HsBool endsWithPath(pathchar* base, pathchar* str);
 +pathchar* pathdup(const pathchar *path);
 +pathchar* pathdir(const pathchar *path);
 +pathchar* mkPath(const char* path);
 +HsBool endsWithPath(const pathchar* base, const pathchar* str);
  #include "EndPrivate.h"

rts/linker/Elf.c

@@ -924,7 +924,7 @@ ocGetNames_ELF ( ObjectCode* oc )
            oc->sections[i].info->stubs = NULL;
  #endif
 -          addProddableBlock(oc, start, size);
 +          addProddableBlock(&oc->proddables, start, size);
        } else {
            addSection(&oc->sections[i], kind, alloc, oc->image+offset, size,
 , 0, 0);
@@ -1272,7 +1272,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
                  debugBelch("Reloc: P = %p   S = %p   A = %p   type=%d\n",
                             (void*)P, (void*)S, (void*)A, reloc_type ));
  #if defined(DEBUG)
 -       checkProddableBlock ( oc, pP, sizeof(Elf_Word) );
 +       checkProddableBlock ( &oc->proddables, pP, sizeof(Elf_Word) );
  #else
         (void) pP; /* suppress unused varialbe warning in non-debug build */
  #endif
@@ -1684,7 +1684,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
  #if defined(DEBUG)
        IF_DEBUG(linker_verbose,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
                                           (void*)P, (void*)S, (void*)A ));
 -      checkProddableBlock(oc, (void*)P, sizeof(Elf_Word));
 +      checkProddableBlock(&oc->proddables, (void*)P, sizeof(Elf_Word));
  #endif
  #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)

rts/linker/MachO.c

@@ -253,7 +253,7 @@ resolveImports(
              return 0;
+         }
 -        checkProddableBlock(oc,
 +        checkProddableBlock(&oc->proddables,
                              ((void**)(oc->image + sect->offset)) + i,
                              sizeof(void *));
          ((void**)(oc->image + sect->offset))[i] = addr;
@@ -287,7 +287,7 @@ decodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri) {
      /* the instruction. It is 32bit wide */
      uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address);
 -    checkProddableBlock(oc, (void*)p, 1 << ri->r_length);
 +    checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length);
      switch(ri->r_type) {
          case ARM64_RELOC_UNSIGNED: {
@@ -364,7 +364,7 @@ encodeAddend(ObjectCode * oc, Section * section,
               MachORelocationInfo * ri, int64_t addend) {
      uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address);
 -    checkProddableBlock(oc, (void*)p, 1 << ri->r_length);
 +    checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length);
      switch (ri->r_type) {
          case ARM64_RELOC_UNSIGNED: {
@@ -788,7 +788,7 @@ relocateSection(ObjectCode* oc, int curSection)
              default:
                  barf("Unknown size.");
+         }
 -        checkProddableBlock(oc,thingPtr,relocLenBytes);
 +        checkProddableBlock(&oc->proddables,thingPtr,relocLenBytes);
          /*
           * With SIGNED_N the relocation is not at the end of the
@@ -1034,9 +1034,9 @@ relocateSection(ObjectCode* oc, int curSection)
           */
          if (0 == reloc->r_extern) {
              if (reloc->r_pcrel) {
 -                checkProddableBlock(oc, (void *)((char *)thing + baseValue), 1);
 +                checkProddableBlock(&oc->proddables, (void *)((char *)thing + baseValue), 1);
              } else {
 -                checkProddableBlock(oc, (void *)thing, 1);
 +                checkProddableBlock(&oc->proddables, (void *)thing, 1);
+             }
+         }
@@ -1343,7 +1343,7 @@ ocGetNames_MachO(ObjectCode* oc)
                  secArray[sec_idx].info->stub_size = 0;
                  secArray[sec_idx].info->stubs = NULL;
  #endif
 -                addProddableBlock(oc, start, section->size);
 +                addProddableBlock(&oc->proddables, start, section->size);
+             }
              curMem = (char*) secMem + section->size;

rts/linker/PEi386.c

@@ -378,7 +378,7 @@ static size_t makeSymbolExtra_PEi386(
  #endif
  static void addDLLHandle(
 -    pathchar* dll_name,
 +    const pathchar* dll_name,
      HINSTANCE instance);
  static bool verifyCOFFHeader(
@@ -427,8 +427,52 @@ const int default_alignment = 8;
     the pointer as a redirect.  Essentially it's a DATA DLL reference.  */
  const void* __rts_iob_func = (void*)&__acrt_iob_func;
 +/*
 + * Note [Avoiding repeated DLL loading]
 + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every
 + * DLL-imported symbol, we use a hash-map to keep track of which DLLs have
 + * already been loaded. This hash-map is keyed on the dll_name passed to
 + * addDLL_PEi386 and is mapped to its HINSTANCE. This serves as a quick check
 + * to avoid repeated calls to LoadLibraryEx for the identical DLL. See #26009.
 + */
++
 +typedef struct {
 +    HashTable *hash;
 +} LoadedDllCache;
++
 +LoadedDllCache loaded_dll_cache;
++
 +static void initLoadedDllCache(LoadedDllCache *cache) {
 +    cache->hash = allocHashTable();
 +}
++
 +static int hash_path(const HashTable *table, StgWord w)
 +{
 +    const pathchar *key = (pathchar*) w;
 +    return hashBuffer(table, key, sizeof(pathchar) * wcslen(key));
 +}
++
 +static int compare_path(StgWord key1, StgWord key2)
 +{
 +    return wcscmp((pathchar*) key1, (pathchar*) key2) == 0;
 +}
++
 +static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance)
 +{
 +    insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path);
 +}
++
 +static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name)
 +{
 +    void *result = lookupHashTable_(cache->hash, (StgWord) dll_name, hash_path, compare_path);
 +    return (HINSTANCE) result;
 +}
++
  void initLinker_PEi386(void)
+ {
 +    initLoadedDllCache(&loaded_dll_cache);
++
      if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"),
                                 symhash, "__image_base__",
                                 GetModuleHandleW (NULL), HS_BOOL_TRUE,
@@ -440,10 +484,11 @@ void initLinker_PEi386(void)
      addDLLHandle(WSTR("*.exe"), GetModuleHandle(NULL));
  #endif
 -  /* Register the cleanup routine as an exit handler,  this gives other exit handlers
 -     a chance to run which may need linker information.  Exit handlers are ran in
 -     reverse registration order so this needs to be before the linker loads anything.  */
 -  atexit (exitLinker_PEi386);
 +    /* Register the cleanup routine as an exit handler,  this gives other exit handlers
 +     * a chance to run which may need linker information.  Exit handlers are ran in
 +     * reverse registration order so this needs to be before the linker loads anything.
 +     */
 +    atexit (exitLinker_PEi386);
+ }
  void exitLinker_PEi386(void)
@@ -454,7 +499,7 @@ void exitLinker_PEi386(void)
  static OpenedDLL* opened_dlls = NULL;
  /* Adds a DLL instance to the list of DLLs in which to search for symbols. */
 -static void addDLLHandle(pathchar* dll_name, HINSTANCE instance) {
 +static void addDLLHandle(const pathchar* dll_name, HINSTANCE instance) {
      IF_DEBUG(linker, debugBelch("addDLLHandle(%" PATH_FMT ")...\n", dll_name));
      /* At this point, we actually know what was loaded.
@@ -796,14 +841,19 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym )
+ }
  const char *
 -addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded )
 +addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded )
+ {
 -   /* ------------------- Win32 DLL loader ------------------- */
+-
 -   pathchar*  buf;
 -   HINSTANCE  instance;
+-
 -   IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name));
 +    /* ------------------- Win32 DLL loader ------------------- */
 +    IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name));
++
 +    // See Note [Avoiding repeated DLL loading]
 +    HINSTANCE instance = isDllLoaded(&loaded_dll_cache, dll_name);
 +    if (instance) {
 +        if (loaded) {
 +            *loaded = instance;
 +        }
 +        return NULL;
 +    }
      /* The file name has no suffix (yet) so that we can try
         both foo.dll and foo.drv
@@ -816,45 +866,32 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded )
          extension. */
      size_t bufsize = pathlen(dll_name) + 10;
 -    buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL");
 +    pathchar *buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL");
      /* These are ordered by probability of success and order we'd like them.  */
      const wchar_t *formats[] = { L"%ls.DLL", L"%ls.DRV", L"lib%ls.DLL", L"%ls" };
      const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 };
 -    int cFormat, cFlag;
 -    int flags_start = 1; /* Assume we don't support the new API.  */
+-
 -    /* Detect if newer API are available, if not, skip the first flags entry.  */
 -    if (GetProcAddress((HMODULE)LoadLibraryW(L"Kernel32.DLL"), "AddDllDirectory")) {
 -        flags_start = 0;
 -    }
+-
      /* Iterate through the possible flags and formats.  */
 -    for (cFlag = flags_start; cFlag < 2; cFlag++)
 -    {
 -        for (cFormat = 0; cFormat < 4; cFormat++)
 -        {
 +    for (int cFlag = 0; cFlag < 2; cFlag++) {
 +        for (int cFormat = 0; cFormat < 4; cFormat++) {
              snwprintf(buf, bufsize, formats[cFormat], dll_name);
              instance = LoadLibraryExW(buf, NULL, flags[cFlag]);
              if (instance == NULL) {
 -                if (GetLastError() != ERROR_MOD_NOT_FOUND)
 -                {
 +                if (GetLastError() != ERROR_MOD_NOT_FOUND) {
                      goto error;
+                 }
 -            }
 -            else
 -            {
 -                break; /* We're done. DLL has been loaded.  */
 +            } else {
 +                goto loaded; /* We're done. DLL has been loaded.  */
+             }
+         }
+     }
 -    /* Check if we managed to load the DLL.  */
 -    if (instance == NULL) {
 -        goto error;
 -    }
 +    // We failed to load
 +    goto error;
 +loaded:
 +    addLoadedDll(&loaded_dll_cache, dll_name, instance);
      addDLLHandle(buf, instance);
      if (loaded) {
          *loaded = instance;
@@ -1658,7 +1695,7 @@ ocGetNames_PEi386 ( ObjectCode* oc )
+       }
        addSection(section, kind, SECTION_NOMEM, start, sz, 0, 0, 0);
 -      addProddableBlock(oc, oc->sections[i].start, sz);
 +      addProddableBlock(&oc->proddables, oc->sections[i].start, sz);
+    }
     /* Copy exported symbols into the ObjectCode. */
@@ -1690,7 +1727,7 @@ ocGetNames_PEi386 ( ObjectCode* oc )
                    SECTIONKIND_RWDATA, SECTION_MALLOC,
                    bss, globalBssSize, 0, 0, 0);
         IF_DEBUG(linker_verbose, debugBelch("bss @ %p %" FMT_Word "\n", bss, globalBssSize));
 -       addProddableBlock(oc, bss, globalBssSize);
 +       addProddableBlock(&oc->proddables, bss, globalBssSize);
     } else {
         addSection(&oc->sections[oc->n_sections-1],
                    SECTIONKIND_OTHER, SECTION_NOMEM, NULL, 0, 0, 0, 0);
@@ -2067,13 +2104,13 @@ ocResolve_PEi386 ( ObjectCode* oc )
           IF_DEBUG(linker_verbose, debugBelch("S=%zx\n", S));
           /* All supported relocations write at least 4 bytes */
 -         checkProddableBlock(oc, pP, 4);
 +         checkProddableBlock(&oc->proddables, pP, 4);
           switch (reloc->Type) {
  #if defined(x86_64_HOST_ARCH)
              case 1: /* R_X86_64_64 (ELF constant 1) - IMAGE_REL_AMD64_ADDR64 (PE constant 1) */
+                {
                     uint64_t A;
 -                   checkProddableBlock(oc, pP, 8);
 +                   checkProddableBlock(&oc->proddables, pP, 8);
                     A = *(uint64_t*)pP;
                     *(uint64_t *)pP = S + A;
                     break;
@@ -2114,7 +2151,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
+                {
                     /* mingw will emit this for a pc-rel 64 relocation */
                     uint64_t A;
 -                   checkProddableBlock(oc, pP, 8);
 +                   checkProddableBlock(&oc->proddables, pP, 8);
                     A = *(uint64_t*)pP;
                     *(uint64_t *)pP = S + A - (intptr_t)pP;
                     break;

rts/linker/PEi386.h

@@ -45,7 +45,7 @@ typedef struct _COFF_HEADER_INFO {
  void initLinker_PEi386( void );
  void exitLinker_PEi386( void );
 -const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *instance  );
 +const char * addDLL_PEi386( const pathchar *dll_name, HINSTANCE *instance  );
  void freePreloadObjectFile_PEi386( ObjectCode *oc );
  bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f);

rts/linker/ProddableBlocks.c

 +/* -----------------------------------------------------------------------------
 + *
 + * (c) The GHC Team, 2025
 + *
 + * RTS Object Linker
 + *
 + * ---------------------------------------------------------------------------*/
++
++
 +/*
 + * Note [Proddable blocks]
 + * ~~~~~~~~~~~~~~~~~~~~~~~
 + * For each ObjectCode, we maintain a ProddableBlockSet representing the set of
 + * address ranges containing data belonging to the object. This set is
 + * represented here as an array of intervals sorted by start address. This
 + * allows us to efficiently query and insert via binary search. Array resizing
 + * is done according to an exponential growth schedule.
 + *
 + * While performing relocations we check against this set and and abort if we
 + * try and write outside any of these.
 + */
++
 +#include "Rts.h"
 +#include "RtsUtils.h"
 +#include "linker/ProddableBlocks.h"
++
 +#include <stdlib.h>
 +#include <string.h>
++
 +typedef struct _ProddableBlock {
 +    uintptr_t start;  // inclusive
 +    uintptr_t end;    // inclusive
 +} ProddableBlock;
++
 +void
 +initProddableBlockSet ( ProddableBlockSet* set )
 +{
 +    set->data = NULL;
 +    set->capacity = 0;
 +    set->size = 0;
 +}
++
 +void
 +freeProddableBlocks (ProddableBlockSet *set)
 +{
 +    stgFree(set->data);
 +    set->data = NULL;
 +    set->size = 0;
 +    set->capacity = 0;
 +}
++
 +// Binary search for the first interval with start >= value. Returns index or
 +// size if none.
 +static size_t
 +findLower(const ProddableBlockSet *set, uintptr_t value)
 +{
 +    size_t l = 0;
 +    size_t r = set->size;
 +    while (l < r) {
 +        size_t mid = l + (r - l) / 2;
 +        if (set->data[mid].start < value) {
 +            l = mid + 1;
 +        } else {
 +            r = mid;
 +        }
 +    }
 +    return l;
 +}
++
 +// Check whether a given value is a member of the set.
 +bool
 +containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end )
 +{
 +    size_t i = findLower(set, start+1);
 +    return i > 0
 +      && set->data[i-1].start <= start
 +      && end <= set->data[i-1].end;
 +}
++
 +void
 +checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size )
 +{
 +    if (! containsSpan(set, (uintptr_t) addr, (uintptr_t) addr+size)) {
 +        barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr);
 +    }
 +}
++
 +// Ensure capacity for at least new_capacity intervals
 +static void
 +ensureCapacity(ProddableBlockSet *set, size_t new_capacity) {
 +    if (new_capacity > set->capacity) {
 +        size_t cap = set->capacity ? set->capacity * 2 : 4;
 +        if (cap < new_capacity) {
 +            cap = new_capacity;
 +        }
 +        ProddableBlock *tmp = stgReallocBytes(set->data, cap * sizeof(ProddableBlock), "addProddableBlock");
 +        set->data = tmp;
 +        set->capacity = cap;
 +    }
 +}
++
 +void
 +addProddableBlock ( ProddableBlockSet* set, void* start_ptr, size_t size )
 +{
 +    const uintptr_t start = (uintptr_t) start_ptr;
 +    const uintptr_t end = (uintptr_t) start + size;
 +    size_t i = findLower(set, start);
++
 +    // check previous interval if it is overlapping or adjacent
 +    if (i > 0 && start <= set->data[i-1].end + 1) {
 +        // merge with left interval
 +        i--;
 +        if (end > set->data[i].end) {
 +            set->data[i].end = end;
 +        }
 +    } else {
 +        // insert new interval
 +        ensureCapacity(set, set->size + 1);
 +        memmove(&set->data[i+1], &set->data[i], sizeof(ProddableBlock) * (set->size - i));
 +        set->data[i].start = start;
 +        set->data[i].end = end;
 +        set->size++;
 +    }
++
 +    // coalesce overlaps on right
 +    size_t j = i;
 +    while (j < set->size && set->data[j].start <= set->data[i].end + 1) {
 +        set->data[i].end = set->data[j].end;
 +        j++;
 +    }
++
 +    if (j != i) {
 +        memmove(&set->data[i+1], &set->data[j], sizeof(ProddableBlock) * (set->size - j));
 +        set->size -= j - i - 1;
 +    }
 +}
++

rts/linker/ProddableBlocks.h

 +/* -----------------------------------------------------------------------------
 + *
 + * (c) The GHC Team, 2025
 + *
 + * RTS Object Linker
 + *
 + * ---------------------------------------------------------------------------*/
++
 +#pragma once
++
 +#include <stdbool.h>
 +#include <stddef.h>
 +#include <stdint.h>
++
 +// An interval set on uintptr_t.
 +struct _ProddableBlock;
++
 +typedef struct {
 +    size_t size;
 +    size_t capacity;
 +    // sorted list of disjoint (start,end) pairs
 +    struct _ProddableBlock *data;
 +} ProddableBlockSet;
++
 +void initProddableBlockSet ( ProddableBlockSet* set );
++
 +// Insert an interval.
 +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size );
++
 +// Check that an address belongs to the set.
 +void checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size );
++
++
 +// Free a set.
 +void freeProddableBlocks (ProddableBlockSet *set);
++
 +// For testing.
 +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end );

rts/rts.cabal

@@ -491,6 +491,7 @@ library
                   linker/MachO.c
                   linker/macho/plt.c
                   linker/macho/plt_aarch64.c
 +                 linker/ProddableBlocks.c
                   linker/PEi386.c
                   linker/SymbolExtras.c
                   linker/elf_got.c

testsuite/tests/interface-stability/base-exports.stdout

@@ -322,7 +322,7 @@ module Control.Exception.Backtrace where
    type BacktraceMechanism :: *
    data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
    type Backtraces :: *
 -  data Backtraces = ...
 +  data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
    collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
    displayBacktraces :: Backtraces -> GHC.Internal.Base.String
    getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool

testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs

@@ -322,7 +322,7 @@ module Control.Exception.Backtrace where
    type BacktraceMechanism :: *
    data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
    type Backtraces :: *
 -  data Backtraces = ...
 +  data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
    collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
    displayBacktraces :: Backtraces -> GHC.Internal.Base.String
    getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool

testsuite/tests/interface-stability/base-exports.stdout-mingw32

@@ -322,7 +322,7 @@ module Control.Exception.Backtrace where
    type BacktraceMechanism :: *
    data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
    type Backtraces :: *
 -  data Backtraces = ...
 +  data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
    collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
    displayBacktraces :: Backtraces -> GHC.Internal.Base.String
    getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool

testsuite/tests/interface-stability/base-exports.stdout-ws-32

@@ -322,7 +322,7 @@ module Control.Exception.Backtrace where
    type BacktraceMechanism :: *
    data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace
    type Backtraces :: *
 -  data Backtraces = ...
 +  data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]}
    collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces
    displayBacktraces :: Backtraces -> GHC.Internal.Base.String
    getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool

testsuite/tests/rts/TestProddableBlockSet.c

 +#include <assert.h>
 +#include <stdbool.h>
 +#include <stdint.h>
 +#include <stddef.h>
++
 +// Excerpted from ProddableBlocks.h
 +typedef struct {
 +    size_t size;
 +    size_t capacity;
 +    // sorted list of disjoint (start,end) pairs
 +    struct _ProddableBlock *data;
 +} ProddableBlockSet;
++
 +void initProddableBlockSet ( ProddableBlockSet* set );
 +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size );
 +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end );
++
 +int main () {
 +  ProddableBlockSet set;
 +  initProddableBlockSet(&set);
 +  addProddableBlock(&set, (void*) 0x20, 0x10);
 +  addProddableBlock(&set, (void*) 0x30, 0x10);
 +  addProddableBlock(&set, (void*) 0x100, 0x10);
++
 +  assert( containsSpan(&set, 0x20, 0x30));
 +  assert( containsSpan(&set, 0x30, 0x29));
 +  assert(!containsSpan(&set, 0x30, 0x49));
 +  assert(!containsSpan(&set, 0x60, 0x70));
 +  assert(!containsSpan(&set, 0x90, 0x110));
 +  assert( containsSpan(&set, 0x100, 0x101));
 +  return 0;
 +}
++

testsuite/tests/rts/all.T

@@ -641,3 +641,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
  # N.B. This will likely issue a warning on stderr but we merely care that the
  # program doesn't crash.
  test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
++
 +test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])