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-...)
* 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