Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC
Commits:
083e40f1 by Rodrigo Mesquita at 2025-08-01T04:38:23-04:00
debugger: Uniquely identify breakpoints by internal id
Since b85b11994e0130ff2401dd4bbdf52330e0bcf776 (support inlining
breakpoints), a breakpoint has been identified at runtime by *two* pairs
of .
- The first, aka a 'BreakpointId', uniquely identifies a breakpoint in
the source of a module by using the Tick index. A Tick index can index
into ModBreaks.modBreaks_xxx to fetch source-level information about
where that tick originated.
- When a user specifies e.g. a line breakpoint using :break, we'll reverse
engineer what a Tick index for that line
- We update the `BreakArray` of that module (got from the
LoaderState) at that tick index to `breakOn`.
- A BCO we can stop at is headed by a BRK_FUN instruction. This
instruction stores in an operand the `tick index` it is associated
to. We look it up in the associated `BreakArray` (also an operand)
and check wheter it was set to `breakOn`.
- The second, aka the `ibi_info_mod` + `ibi_info_ix` of the
`InternalBreakpointId`, uniquely index into the `imodBreaks_breakInfo`
-- the information we gathered during code generation about the
existing breakpoint *ocurrences*.
- Note that with optimisation there may be many occurrences of the
same source-tick-breakpoint across different modules. The
`ibi_info_ix` is unique per occurrence, but the `bi_tick_ix` may be
shared. See Note [Breakpoint identifiers] about this.
- Note that besides the tick ids, info ids are also stored in
`BRK_FUN` so the break handler can refer to the associated
`CgBreakInfo`.
In light of that, the driving changes come from the desire to have the
info_id uniquely identify the breakpoint at runtime, and the source tick
id being derived from it:
- An InternalBreakpointId should uniquely identify a breakpoint just
from the code-generation identifiers of `ibi_info_ix` and `ibi_info_mod`.
So we drop `ibi_tick_mod` and `ibi_tick_ix`.
- A BRK_FUN instruction need only record the "internal breakpoint id",
not the tick-level id.
So we drop the tick mod and tick index operands.
- A BreakArray should be indexed by InternalBreakpointId rather than
BreakpointId
That means we need to do some more work when setting a breakpoint.
Specifically, we need to figure out the internal ids (occurrences of a
breakpoint) from the source-level BreakpointId we want to set the
breakpoint at (recall :break refers to breaks at the source level).
Besides this change being an improvement to the handling of breakpoints
(it's clearer to have a single unique identifier than two competing
ones), it unlocks the possibility of generating "internal" breakpoints
during Cg (needed for #26042).
It should also be easier to introduce multi-threaded-aware `BreakArrays`
following this change (needed for #26064).
Se also the new Note [ModBreaks vs InternalModBreaks]
On i386-linux:
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
- - - - -
bf03bbaa by Simon Hengel at 2025-08-01T04:39:05-04:00
Don't use MCDiagnostic for `ghcExit`
This changes the error message of `ghcExit` from
```
<no location info>: error:
Compilation had errors
```
to
```
Compilation had errors
```
- - - - -
a889ec75 by Simon Hengel at 2025-08-01T04:39:05-04:00
Respect `-fdiagnostics-as-json` for driver diagnostics (see #24113)
- - - - -
8e4e328a by Andreas Klebinger at 2025-08-01T09:10:51+00:00
rts: Support COFF BigObj files in archives.
- - - - -
25 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Utils/Error.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- libraries/ghci/GHCi/Debugger.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Disassembler.c
- rts/Exception.cmm
- rts/Interpreter.c
- rts/linker/LoadArchive.c
- testsuite/tests/corelint/T21115b.stderr
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -841,24 +841,18 @@ assembleI platform i = case i of
W8 -> emit_ bci_OP_INDEX_ADDR_08 []
_ -> unsupported_width
- BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox) -> do
+ BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do
+ p1 <- ptr $ BCOPtrBreakArray info_mod
let -- cast that checks that round-tripping through Word16 doesn't change the value
toW16 x = let r = fromIntegral x :: Word16
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- p1 <- ptr $ BCOPtrBreakArray tick_mod
- tick_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName tick_mod
- info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
- tick_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ tick_mod
- info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ info_mod
- np <- lit1 $ BCONPtrCostCentre (BreakpointId tick_mod tickx)
- emit_ bci_BRK_FUN [ Op p1
- , Op tick_addr, Op info_addr
- , Op tick_unitid_addr, Op info_unitid_addr
- , SmallOp (toW16 tickx), SmallOp (toW16 infox)
- , Op np
- ]
+ info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
+ info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod
+ np <- lit1 $ BCONPtrCostCentre ibi
+ emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr
+ , SmallOp (toW16 infox), Op np ]
BRK_ALTS active -> emit_ bci_BRK_ALTS [SmallOp (if active then 1 else 0)]
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -7,23 +7,23 @@
-- 'InternalModBreaks', and is uniquely identified at runtime by an
-- 'InternalBreakpointId'.
--
--- See Note [Breakpoint identifiers]
+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
module GHC.ByteCode.Breakpoints
( -- * Internal Mod Breaks
InternalModBreaks(..), CgBreakInfo(..)
- , mkInternalModBreaks
+ , mkInternalModBreaks, imodBreaks_module
-- ** Internal breakpoint identifier
, InternalBreakpointId(..), BreakInfoIndex
-- * Operations
- , toBreakpointId
-- ** Internal-level operations
- , getInternalBreak, addInternalBreak
+ , getInternalBreak
-- ** Source-level information operations
, getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
+ , getBreakSourceId
-- * Utils
, seqInternalModBreaks
@@ -47,6 +47,31 @@ import GHC.Utils.Panic
import Data.Array
{-
+Note [ModBreaks vs InternalModBreaks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'ModBreaks' and 'BreakpointId's must not to be confused with
+'InternalModBreaks' and 'InternalBreakId's.
+
+'ModBreaks' is constructed once during HsToCore from the information attached
+to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'
+can be queried using 'BreakpointId's, which uniquely identifies a breakpoint
+within the list of breakpoint information for a given module's 'ModBreaks'.
+
+'InternalModBreaks' are constructed during bytecode generation and are indexed
+by a 'InternalBreakpointId'. They contain all the information relevant to a
+breakpoint for code generation that can be accessed during runtime execution
+(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's
+are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'
+instruction receives 'InternalBreakpointId' as an argument.
+
+We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used
+to get source-level information about a breakpoint via the corresponding 'ModBreaks'.
+
+Notably, 'InternalModBreaks' can contain entries for so-called internal
+breakpoints, which do not necessarily have a source-level location attached to
+it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to
+introduce breakpoints during code generation for features such as stepping-out.
+
Note [Breakpoint identifiers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Before optimization a breakpoint is identified uniquely with a tick module
@@ -64,6 +89,10 @@ So every breakpoint occurrence gets assigned a module-unique *info index* and
we store it alongside the occurrence module (*info module*) in the
'InternalBreakpointId' datatype. This is the index that we use at runtime to
identify a breakpoint.
+
+When the internal breakpoint has a matching tick-level breakpoint we can fetch
+the related tick-level information by first looking up a mapping
+@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@.
-}
--------------------------------------------------------------------------------
@@ -78,19 +107,11 @@ type BreakInfoIndex = Int
-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.
-- See Note [Breakpoint identifiers]
data InternalBreakpointId = InternalBreakpointId
- { ibi_tick_mod :: !Module -- ^ Breakpoint tick module
- , ibi_tick_index :: !Int -- ^ Breakpoint tick index
- , ibi_info_mod :: !Module -- ^ Breakpoint tick module
- , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint tick index
+ { ibi_info_mod :: !Module -- ^ Breakpoint info module
+ , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index
}
deriving (Eq, Ord)
-toBreakpointId :: InternalBreakpointId -> BreakpointId
-toBreakpointId ibi = BreakpointId
- { bi_tick_mod = ibi_tick_mod ibi
- , bi_tick_index = ibi_tick_index ibi
- }
-
--------------------------------------------------------------------------------
-- * Internal Mod Breaks
--------------------------------------------------------------------------------
@@ -107,18 +128,34 @@ data InternalModBreaks = InternalModBreaks
-- 'InternalBreakpointId'.
, imodBreaks_modBreaks :: !ModBreaks
- -- ^ Store the original ModBreaks for this module, unchanged.
- -- Allows us to query about source-level breakpoint information using
- -- an internal breakpoint id.
+ -- ^ Store the ModBreaks for this module
+ --
+ -- Recall Note [Breakpoint identifiers]: for some module A, an
+ -- *occurrence* of a breakpoint in A may have been inlined from some
+ -- breakpoint *defined* in module B.
+ --
+ -- This 'ModBreaks' contains information regarding all the breakpoints
+ -- defined in the module this 'InternalModBreaks' corresponds to. It
+ -- /does not/ necessarily have information regarding all the breakpoint
+ -- occurrences registered in 'imodBreaks_breakInfo'. Some of those
+ -- occurrences may refer breakpoints inlined from other modules.
}
--- | Construct an 'InternalModBreaks'
+-- | Construct an 'InternalModBreaks'.
+--
+-- INVARIANT: The given 'ModBreaks' correspond to the same module as this
+-- 'InternalModBreaks' module (the first argument) and its breakpoint infos
+-- (the @IntMap CgBreakInfo@ argument)
mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks
mkInternalModBreaks mod im mbs =
assertPpr (mod == modBreaks_module mbs)
(text "Constructing InternalModBreaks with the ModBreaks of a different module!") $
InternalModBreaks im mbs
+-- | Get the module to which these 'InternalModBreaks' correspond
+imodBreaks_module :: InternalModBreaks -> Module
+imodBreaks_module = modBreaks_module . imodBreaks_modBreaks
+
-- | Information about a breakpoint that we know at code-generation time
-- In order to be used, this needs to be hydrated relative to the current HscEnv by
-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
@@ -128,20 +165,22 @@ data CgBreakInfo
{ cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
+ , cgb_tick_id :: !BreakpointId
+ -- ^ This field records the original breakpoint tick identifier for this
+ -- internal breakpoint info. It is used to convert a breakpoint
+ -- *occurrence* index ('InternalBreakpointId') into a *definition* index
+ -- ('BreakpointId').
+ --
+ -- The modules of breakpoint occurrence and breakpoint definition are not
+ -- necessarily the same: See Note [Breakpoint identifiers].
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
-- | Get an internal breakpoint info by 'InternalBreakpointId'
getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
-getInternalBreak (InternalBreakpointId _ _ info_mod info_ix) imbs =
- assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $
- imodBreaks_breakInfo imbs IM.! info_ix
-
--- | Add a CgBreakInfo to an 'InternalModBreaks' at 'InternalBreakpointId'
-addInternalBreak :: InternalBreakpointId -> CgBreakInfo -> InternalModBreaks -> InternalModBreaks
-addInternalBreak (InternalBreakpointId _ _ info_mod info_ix) info imbs =
- assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $
- imbs{imodBreaks_breakInfo = IM.insert info_ix info (imodBreaks_breakInfo imbs)}
+getInternalBreak (InternalBreakpointId mod ix) imbs =
+ assert_modules_match mod (imodBreaks_module imbs) $
+ imodBreaks_breakInfo imbs IM.! ix
-- | Assert that the module in the 'InternalBreakpointId' and in
-- 'InternalModBreaks' match.
@@ -155,27 +194,56 @@ assert_modules_match ibi_mod imbs_mod =
-- Tick-level Breakpoint information
--------------------------------------------------------------------------------
+-- | Get the source module and tick index for this breakpoint
+-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
+getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ in cgb_tick_id cgb
+
-- | Get the source span for this breakpoint
-getBreakLoc :: InternalBreakpointId -> InternalModBreaks -> SrcSpan
+getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
getBreakLoc = getBreakXXX modBreaks_locs
-- | Get the vars for this breakpoint
-getBreakVars :: InternalBreakpointId -> InternalModBreaks -> [OccName]
+getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
getBreakVars = getBreakXXX modBreaks_vars
-- | Get the decls for this breakpoint
-getBreakDecls :: InternalBreakpointId -> InternalModBreaks -> [String]
+getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
-- | Get the decls for this breakpoint
-getBreakCCS :: InternalBreakpointId -> InternalModBreaks -> (String, String)
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
-getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> InternalBreakpointId -> InternalModBreaks -> a
-getBreakXXX view (InternalBreakpointId tick_mod tick_id _ _) imbs =
- assert_modules_match tick_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $ do
- view (imodBreaks_modBreaks imbs) ! tick_id
+--
+-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the
+-- *occurrence* module) doesn't necessarily match the module where the
+-- tick breakpoint was defined with the relevant 'ModBreaks'.
+--
+-- When the tick module is the same as the internal module, we use the stored
+-- 'ModBreaks'. When the tick module is different, we need to look up the
+-- 'ModBreaks' in the HUG for that other module.
+--
+-- To avoid cyclic dependencies, we instead receive a function that looks up
+-- the 'ModBreaks' given a 'Module'
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
+getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ case cgb_tick_id cgb of
+ BreakpointId{bi_tick_mod, bi_tick_index}
+ | bi_tick_mod == ibi_mod
+ -> do
+ let these_mbs = imodBreaks_modBreaks imbs
+ return $ view these_mbs ! bi_tick_index
+ | otherwise
+ -> do
+ other_mbs <- lookupModule bi_tick_mod
+ return $ view other_mbs ! bi_tick_index
--------------------------------------------------------------------------------
-- Instances
@@ -190,7 +258,8 @@ seqInternalModBreaks InternalModBreaks{..} =
seqCgBreakInfo CgBreakInfo{..} =
rnf cgb_tyvars `seq`
rnf cgb_vars `seq`
- rnf cgb_resty
+ rnf cgb_resty `seq`
+ rnf cgb_tick_id
instance Outputable InternalBreakpointId where
ppr InternalBreakpointId{..} =
@@ -203,4 +272,5 @@ instance NFData InternalBreakpointId where
instance Outputable CgBreakInfo where
ppr info = text "CgBreakInfo" <+>
parens (ppr (cgb_vars info) <+>
- ppr (cgb_resty info))
+ ppr (cgb_resty info) <+>
+ ppr (cgb_tick_id info))
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -454,9 +454,8 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox))
+ ppr (BRK_FUN (InternalBreakpointId info_mod infox))
= text "BRK_FUN" <+> text "<breakarray>"
- <+> ppr tick_mod <+> ppr tickx
<+> ppr info_mod <+> ppr infox
<+> text "<cc>"
ppr (BRK_ALTS active) = text "BRK_ALTS" <+> ppr active
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -98,9 +98,9 @@ lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
BCONPtrFFIInfo (FFIInfo {..}) -> do
RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet
pure $ fromIntegral p
- BCONPtrCostCentre BreakpointId{..}
+ BCONPtrCostCentre InternalBreakpointId{..}
| interpreterProfiled interp -> do
- case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of
+ case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of
RemotePtr p -> pure $ fromIntegral p
| otherwise ->
case toRemotePtr nullPtr of
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -285,7 +285,7 @@ data BCONPtr
-- | A libffi ffi_cif function prototype.
| BCONPtrFFIInfo !FFIInfo
-- | A 'CostCentre' remote pointer array's respective 'BreakpointId'
- | BCONPtrCostCentre !BreakpointId
+ | BCONPtrCostCentre !InternalBreakpointId
instance NFData BCONPtr where
rnf x = x `seq` ()
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -704,12 +704,13 @@ toIfaceLFInfo nm lfi = case lfi of
-- Dehydrating CgBreakInfo
-dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo
-dehydrateCgBreakInfo ty_vars idOffSets tick_ty =
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
+dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
CgBreakInfo
{ cgb_tyvars = map toIfaceTvBndr ty_vars
, cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets
, cgb_resty = toIfaceType tick_ty
+ , cgb_tick_id = bid
}
{- Note [Inlining and hs-boot files]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1552,7 +1552,7 @@ wrapAction msg_wrapper hsc_env k = do
-- ThreadKilled in particular needs to actually kill the thread.
-- So rethrow that and the other async exceptions
Just (err :: SomeAsyncException) -> throwIO err
- _ -> errorMsg lcl_logger (text (show exc))
+ _ -> reportError lcl_logger neverQualify emptyDiagOpts noSrcSpan (text (show exc))
return Nothing
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -12,7 +12,7 @@
-- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed
-- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'.
--
--- See Note [Breakpoint identifiers]
+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
module GHC.HsToCore.Breakpoints
( -- * ModBreaks
mkModBreaks, ModBreaks(..)
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Settings
import GHC.Platform
import GHC.Platform.Ways
+import GHC.Driver.Errors
import GHC.Driver.Phases
import GHC.Driver.Env
import GHC.Driver.Session
@@ -50,7 +51,7 @@ import GHC.Driver.Ppr
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Finder
-import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.Monad hiding (reportDiagnostic)
import GHC.Runtime.Interpreter
import GHCi.BreakArray
@@ -124,7 +125,9 @@ import GHC.Utils.Exception
import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
import GHC.Driver.Downsweep
import qualified GHC.Runtime.Interpreter as GHCi
-import Data.Array.Base (numElements)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map.Strict as M
+import Foreign.Ptr (nullPtr)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1307,9 +1310,9 @@ load_dyn interp hsc_env crash_early dll = do
then cmdLineErrorIO err
else do
when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
- $ logMsg logger
- (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing)
- noSrcSpan $ withPprStyle defaultUserStyle (note err)
+ $ reportDiagnostic logger
+ neverQualify diag_opts
+ noSrcSpan (WarningWithFlag Opt_WarnMissedExtraSharedLib) $ withPprStyle defaultUserStyle (note err)
pure Nothing
where
diag_opts = initDiagOpts (hsc_dflags hsc_env)
@@ -1497,8 +1500,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0
, not loading_dynamic_hs_libs
, interpreterProfiled interp
= do
- let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing
- logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
+ reportDiagnostic logger neverQualify diag_opts noSrcSpan WarningWithoutFlag $ withPprStyle defaultErrStyle $
text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
text "libraries with profiling support."
@@ -1666,10 +1668,10 @@ allocateBreakArrays ::
IO (ModuleEnv (ForeignRef BreakArray))
allocateBreakArrays interp =
foldlM
- ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
+ ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do
-- If no BreakArray is assigned to this module yet, create one
if not $ elemModuleEnv modBreaks_module be0 then do
- let count = numElements modBreaks_locs
+ let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo
breakArray <- GHCi.newBreakArray interp count
evaluate $ extendModuleEnv be0 modBreaks_module breakArray
else
@@ -1679,29 +1681,51 @@ allocateBreakArrays interp =
-- | Given a list of 'InternalModBreaks' collected from a list
-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
-- enabled.
+--
+-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal
+-- breakpoint index), not by tick index
allocateCCS ::
Interp ->
- ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
+ ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) ->
[InternalModBreaks] ->
- IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
+ IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)))
allocateCCS interp ce mbss
- | interpreterProfiled interp =
- foldlM
- ( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
- ccs <-
+ | interpreterProfiled interp = do
+ -- 1. Create a mapping from source BreakpointId to CostCentre ptr
+ ccss <- M.unions <$> mapM
+ ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do
+ ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
(moduleNameString $ moduleName modBreaks_module)
(elems modBreaks_ccs)
- if not $ elemModuleEnv modBreaks_module ce0 then do
- evaluate $
- extendModuleEnv ce0 modBreaks_module $
- listArray
- (0, length ccs - 1)
- ccs
+ return $ M.fromList $
+ zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
+ )
+ mbss
+ -- 2. Create an array with one element for every InternalBreakpointId,
+ -- where every element has the CCS for the corresponding BreakpointId
+ foldlM
+ (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do
+ if not $ elemModuleEnv modBreaks_module ce then do
+ let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo
+ let ccs = IM.map
+ (\info ->
+ fromMaybe (toRemotePtr nullPtr)
+ (M.lookup (cgb_tick_id info) ccss)
+ )
+ imodBreaks_breakInfo
+ assertPpr (count == length ccs)
+ (text "expected CgBreakInfo map to have one entry per valid ix") $
+ evaluate $
+ extendModuleEnv ce0 modBreaks_module $
+ listArray
+ (0, count)
+ (IM.elems ccs)
else
return ce0
)
ce
mbss
+
| otherwise = pure ce
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -31,6 +31,9 @@ import GHC.Unit.Module.ModSummary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
+import qualified Data.IntMap.Strict as IntMap
+import qualified GHC.Unit.Home.Graph as HUG
+import qualified GHC.Unit.Home.PackageTable as HPT
--------------------------------------------------------------------------------
-- Finding Module breakpoints
@@ -213,6 +216,47 @@ getModBreak m = do
mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m
pure $ imodBreaks_modBreaks <$> modInfoModBreaks mod_info
+--------------------------------------------------------------------------------
+-- Mapping source-level BreakpointIds to IBI occurrences
+-- (See Note [Breakpoint identifiers])
+--------------------------------------------------------------------------------
+
+-- | A source-level breakpoint may have been inlined into many occurrences, now
+-- referred by 'InternalBreakpointId'. When a breakpoint is set on a certain
+-- 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]
+type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId])
+
+-- | Lookup all InternalBreakpointIds matching the given BreakpointId
+-- Nothing if BreakpointId not in map
+lookupBreakpointOccurrences :: BreakpointOccurrences -> BreakpointId -> Maybe [InternalBreakpointId]
+lookupBreakpointOccurrences bmp (BreakpointId md tick) =
+ lookupModuleEnv bmp md >>= IntMap.lookup tick
+
+-- | Construct a mapping from Source 'BreakpointId's to 'InternalBreakpointId's from the given list of 'ModInfo's
+mkBreakpointOccurrences :: forall m. GhcMonad m => m BreakpointOccurrences
+mkBreakpointOccurrences = do
+ hug <- hsc_HUG <$> getSession
+ liftIO $ foldr go (pure emptyModuleEnv) hug
+ where
+ go :: HUG.HomeUnitEnv -> IO BreakpointOccurrences -> IO BreakpointOccurrences
+ go hue mbmp = do
+ bmp <- mbmp
+ ibrkss <- HPT.concatHpt (\hmi -> maybeToList (getModBreaks hmi))
+ (HUG.homeUnitEnv_hpt hue)
+ return $ foldr addBreakToMap bmp ibrkss
+
+ addBreakToMap :: InternalModBreaks -> BreakpointOccurrences -> BreakpointOccurrences
+ addBreakToMap ibrks bmp0 = do
+ let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
+ IntMap.foldrWithKey (\info_ix cgi bmp -> do
+ let ibi = InternalBreakpointId imod info_ix
+ let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
+ extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ ) bmp0 (imodBreaks_breakInfo ibrks)
+
--------------------------------------------------------------------------------
-- Getting current breakpoint information
--------------------------------------------------------------------------------
@@ -235,9 +279,15 @@ getCurrentBreakSpan = do
getCurrentBreakModule :: GhcMonad m => m (Maybe Module)
getCurrentBreakModule = do
resumes <- getResumeContext
- return $ case resumes of
- [] -> Nothing
+ hug <- hsc_HUG <$> getSession
+ liftIO $ case resumes of
+ [] -> pure Nothing
(r:_) -> case resumeHistoryIx r of
- 0 -> ibi_tick_mod <$> resumeBreakpointId r
- ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1)
+ 0 -> case resumeBreakpointId r of
+ Nothing -> pure Nothing
+ Just ibi -> do
+ brks <- readIModBreaks hug ibi
+ return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
+ ix ->
+ Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Runtime.Eval (
abandon, abandonAll,
getResumeContext,
getHistorySpan,
- getModBreaks, readModBreaks,
+ getModBreaks, readIModBreaks, readIModModBreaks,
getHistoryModule,
setupBreakpoint,
back, forward,
@@ -147,14 +147,17 @@ getResumeContext = withSession (return . ic_resume . hsc_IC)
mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History
mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi
-getHistoryModule :: History -> Module
-getHistoryModule = ibi_tick_mod . historyBreakpointId
+getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
+getHistoryModule hug hist = do
+ let ibi = historyBreakpointId hist
+ brks <- readIModBreaks hug ibi
+ return $ bi_tick_mod $ getBreakSourceId ibi brks
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
let ibi = historyBreakpointId hist
- brks <- readModBreaks hug (ibi_tick_mod ibi)
- return $ getBreakLoc ibi brks
+ brks <- readIModBreaks hug ibi
+ getBreakLoc (readIModModBreaks hug) ibi brks
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
@@ -162,8 +165,8 @@ getHistorySpan hug hist = do
-- for each tick.
findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String]
findEnclosingDecls hug ibi = do
- brks <- readModBreaks hug (ibi_tick_mod ibi)
- return $ getBreakDecls ibi brks
+ brks <- readIModBreaks hug ibi
+ getBreakDecls (readIModModBreaks hug) ibi brks
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
@@ -350,15 +353,14 @@ handleRunStatus step expr bindings final_ids status history0 = do
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
let ibi = evalBreakpointToId eval_break
let hug = hsc_HUG hsc_env
- tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
- let
- span = getBreakLoc ibi tick_brks
- decl = intercalate "." $ getBreakDecls ibi tick_brks
+ info_brks <- liftIO $ readIModBreaks hug ibi
+ span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks
+ decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks
-- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
bactive <- liftIO $ do
- breakArray <- getBreakArray interp (toBreakpointId ibi) tick_brks
- breakpointStatus interp breakArray (ibi_tick_index ibi)
+ breakArray <- getBreakArray interp ibi info_brks
+ breakpointStatus interp breakArray (ibi_info_index ibi)
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
@@ -446,7 +448,7 @@ resumeExec step mbCnt
-- When the user specified a break ignore count, set it
-- in the interpreter
case (mb_brkpt, mbCnt) of
- (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt
+ (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt
_ -> return ()
let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
@@ -462,17 +464,18 @@ resumeExec step mbCnt
| otherwise -> pure prevHistoryLst
handleRunStatus step expr bindings final_ids status =<< hist'
-setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #19157
-setupBreakpoint interp bi cnt = do
+setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157
+setupBreakpoint interp ibi cnt = do
hug <- hsc_HUG <$> getSession
- modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
- breakArray <- liftIO $ getBreakArray interp bi modBreaks
- liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
+ liftIO $ do
+ modBreaks <- readIModBreaks hug ibi
+ breakArray <- getBreakArray interp ibi modBreaks
+ GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt
-getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
-getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
+getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
+getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do
breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
- case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of
+ case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of
Just ba -> return ba
Nothing -> do
modifyLoaderState interp $ \ld_st -> do
@@ -483,13 +486,12 @@ getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
- let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod
+ let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod
return
( ld_st'
, ba
)
-
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
@@ -517,8 +519,9 @@ moveHist fn = do
span <- case mb_info of
Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>")
Just ibi -> liftIO $ do
- brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi)
- return $ getBreakLoc ibi brks
+ let hug = hsc_HUG hsc_env
+ brks <- readIModBreaks hug ibi
+ getBreakLoc (readIModModBreaks hug) ibi brks
(hsc_env1, names) <-
liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info
let ic = hsc_IC hsc_env1
@@ -579,11 +582,10 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
let hug = hsc_HUG hsc_env
- info_brks <- readModBreaks hug (ibi_info_mod ibi)
- tick_brks <- readModBreaks hug (ibi_tick_mod ibi)
- let info = getInternalBreak ibi (info_brks)
+ info_brks <- readIModBreaks hug ibi
+ let info = getInternalBreak ibi info_brks
interp = hscInterp hsc_env
- occs = getBreakVars ibi tick_brks
+ occs <- getBreakVars (readIModModBreaks hug) ibi info_brks
-- Rehydrate to understand the breakpoint info relative to the current environment.
-- This design is critical to preventing leaks (#22530)
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -27,7 +27,9 @@ module GHC.Runtime.Interpreter
, getClosure
, whereFrom
, getModBreaks
- , readModBreaks
+ , readIModBreaks
+ , readIModBreaksMaybe
+ , readIModModBreaks
, seqHValue
, evalBreakpointToId
@@ -92,7 +94,6 @@ import GHC.Utils.Fingerprint
import GHC.Unit.Module
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.Graph (lookupHugByModule)
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -411,15 +412,10 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
-
toModule u n = mkModule (mkUnitId u) (mkModuleName n)
- tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
- infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
in
InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
+ { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
, ibi_info_index = eb_info_index eval_break
}
@@ -440,17 +436,18 @@ handleSeqHValueStatus interp unit_env eval_status =
-- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
Just break -> do
- let bi = evalBreakpointToId break
+ let ibi = evalBreakpointToId break
+ hug = ue_home_unit_graph unit_env
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
- mb_modbreaks <- getModBreaks . expectJust <$>
- lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
+ mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi)
case mb_modbreaks of
-- Nothing case - should not occur! We should have the appropriate
-- breakpoint information
Nothing -> nothing_case
- Just modbreaks -> put $ brackets . ppr $ getBreakLoc bi modbreaks
+ Just modbreaks -> put . brackets . ppr =<<
+ getBreakLoc (readIModModBreaks hug) ibi modbreaks
-- resume the seq (:force) processing in the iserv process
withForeignRef resume_ctxt_fhv $ \hval -> do
@@ -745,10 +742,18 @@ getModBreaks hmi
| otherwise
= Nothing -- probably object code
--- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module'
--- from the 'HomeUnitGraph'.
-readModBreaks :: HomeUnitGraph -> Module -> IO InternalModBreaks
-readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug
+-- | Read the 'InternalModBreaks' of the given home 'Module' (via
+-- 'InternalBreakpointId') from the 'HomeUnitGraph'.
+readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks
+readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi)
+
+-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
+readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks)
+readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug
+
+-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks'
+readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks
+readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod
-- -----------------------------------------------------------------------------
-- Misc utils
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -31,7 +31,6 @@ import GHC.Cmm.Utils
import GHC.Platform
import GHC.Platform.Profile
-import GHC.Runtime.Interpreter
import GHCi.FFI
import GHC.Types.Basic
import GHC.Utils.Outputable
@@ -64,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
+import GHC.Runtime.Interpreter ( interpreterProfiled )
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
@@ -79,7 +79,6 @@ import Control.Monad
import Data.Char
import GHC.Unit.Module
-import qualified GHC.Unit.Home.Graph as HUG
import Data.Coerce (coerce)
#if MIN_VERSION_rts(1,0,3)
@@ -394,65 +393,28 @@ schemeR_wrk fvs nm original_body (args, body)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do
+schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
code <- schemeE d 0 p rhs
- hsc_env <- getHscEnv
- current_mod <- getCurrentModule
mb_current_mod_breaks <- getCurrentModBreaks
case mb_current_mod_breaks of
-- if we're not generating ModBreaks for this module for some reason, we
-- can't store breakpoint occurrence information.
Nothing -> pure code
- Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
- Nothing -> pure code
- Just ModBreaks{modBreaks_module = tick_mod} -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
+ Just current_mod_breaks -> do
+ platform <- profilePlatform <$> getProfile
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+ let info_mod = modBreaks_module current_mod_breaks
+ infox <- newBreakInfo breakInfo
- let breakInstr = BRK_FUN (InternalBreakpointId tick_mod tick_no info_mod infox)
- return $ breakInstr `consOL` code
+ let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
+ return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
--- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
--- from which the breakpoint originates.
--- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs
--- to refer to pointers in GHCi's address space.
--- They are initialized in 'GHC.HsToCore.Breakpoints.mkModBreaks', called by
--- 'GHC.HsToCore.deSugar'.
---
--- Breakpoints might be disabled because we're in TH, because
--- @-fno-break-points@ was specified, or because a module was reloaded without
--- reinitializing 'ModBreaks'.
---
--- If the module stored in the breakpoint is the currently processed module, use
--- the 'ModBreaks' from the state.
--- If that is 'Nothing', consider breakpoints to be disabled and skip the
--- instruction.
---
--- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph).
--- 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 ->
- Module ->
- Maybe ModBreaks ->
- BcM (Maybe ModBreaks)
-break_info hsc_env mod current_mod current_mod_breaks
- | mod == current_mod
- = pure current_mod_breaks
- | otherwise
- = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
- Just hp -> pure $ imodBreaks_modBreaks <$> getModBreaks hp
- Nothing -> pure Nothing
-
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
getVarOffSets platform depth env = map getOffSet
where
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Errors
import GHC.Driver.Errors.Types (GhcMessage(..), DriverMessage (DriverNoConfiguredLLVMToolchain))
import GHC.Driver.CmdLine (warnsToMessages)
-import GHC.Types.SrcLoc (noLoc)
+import GHC.Types.SrcLoc (noLoc, noSrcSpan)
{-
************************************************************************
@@ -346,7 +346,7 @@ figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do
debugTraceMsg logger 2
(text "Error (figuring out LLVM version):" <+>
text (show err))
- errorMsg logger $ vcat
+ reportError logger neverQualify emptyDiagOpts noSrcSpan $ vcat
[ text "Warning:", nest 9 $
text "Couldn't figure out LLVM version!" $$
text ("Make sure you have installed LLVM between ["
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Utils.Error (
emptyMessages, mkDecorated, mkLocMessage,
mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
mkErrorMsgEnvelope,
- mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
+ mkMCDiagnostic, diagReasonSeverity,
mkPlainError,
mkPlainDiagnostic,
@@ -46,7 +46,6 @@ module GHC.Utils.Error (
-- * Issuing messages during compilation
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
- errorMsg,
fatalErrorMsg,
compilationProgressMsg,
showPass,
@@ -168,11 +167,6 @@ mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code
where
(sev, reason') = diag_reason_severity opts reason
--- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
--- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code.
-errorDiagnostic :: MessageClass
-errorDiagnostic = MCDiagnostic SevError (ResolvedDiagnosticReason ErrorWithoutFlag) Nothing
-
--
-- Creating MsgEnvelope(s)
--
@@ -318,17 +312,12 @@ sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
ghcExit :: Logger -> Int -> IO ()
ghcExit logger val
| val == 0 = exitWith ExitSuccess
- | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n")
+ | otherwise = do fatalErrorMsg logger (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val)
-- -----------------------------------------------------------------------------
-- Outputting messages from the compiler
-errorMsg :: Logger -> SDoc -> IO ()
-errorMsg logger msg
- = logMsg logger errorDiagnostic noSrcSpan $
- withPprStyle defaultErrStyle msg
-
fatalErrorMsg :: Logger -> SDoc -> IO ()
fatalErrorMsg logger msg =
logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
import GHC.Runtime.Eval.Utils
-- The GHC interface
-import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks)
+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
@@ -68,7 +68,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
Resume, SingleStep, Ghc,
GetDocsFailure(..), pushLogHookM,
getModuleGraph, handleSourceError,
- InternalBreakpointId(..) )
+ BreakpointId(..) )
import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
import GHC.Hs.ImpExp
import GHC.Hs
@@ -546,6 +546,7 @@ interactiveUI config srcs maybe_exprs = do
break_ctr = 0,
breaks = IntMap.empty,
tickarrays = emptyModuleEnv,
+ internalBreaks = emptyModuleEnv,
ghci_commands = availableCommands config,
ghci_macros = [],
last_command = Nothing,
@@ -1616,13 +1617,15 @@ toBreakIdAndLocation :: GhciMonad m
toBreakIdAndLocation Nothing = return Nothing
toBreakIdAndLocation (Just inf) = do
st <- getGHCiState
+ hug <- hsc_HUG <$> GHC.getSession
+ brks <- liftIO $ readIModBreaks hug inf
+ let bi = getBreakSourceId inf brks
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakModule loc == ibi_tick_mod inf,
- breakTick loc == ibi_tick_index inf ]
+ breakId loc == bi ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
- printForUser $ pprStopped res
+ printForUser =<< pprStopped res
-- printTypeOfNames session names
let namesSorted = sortBy compareNames names
tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
@@ -3804,22 +3807,32 @@ showBkptTable = do
showContext :: GHC.GhcMonad m => m ()
showContext = do
resumes <- GHC.getResumeContext
- printForUser $ vcat (map pp_resume (reverse resumes))
+ docs <- mapM pp_resume (reverse resumes)
+ printForUser $ vcat docs
where
- pp_resume res =
- text "--> " <> text (GHC.resumeStmt res)
- $$ nest 2 (pprStopped res)
-
-pprStopped :: GHC.Resume -> SDoc
-pprStopped res =
- text "Stopped in"
- <+> ((case mb_mod_name of
- Nothing -> empty
- Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')
- <> text (GHC.resumeDecl res))
- <> char ',' <+> ppr (GHC.resumeSpan res)
- where
- mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res
+ pp_resume res = do
+ stopped <- pprStopped res
+ return $
+ text "--> " <> text (GHC.resumeStmt res)
+ $$ nest 2 stopped
+
+pprStopped :: GHC.GhcMonad m => GHC.Resume -> m SDoc
+pprStopped res = do
+ let mibi = GHC.resumeBreakpointId res
+ mb_mod_name <- case mibi of
+ Nothing -> pure Nothing
+ Just ibi -> do
+ hug <- hsc_HUG <$> GHC.getSession
+ brks <- liftIO $ readIModBreaks hug ibi
+ return $ Just $ moduleName $
+ bi_tick_mod $ getBreakSourceId ibi brks
+ return $
+ text "Stopped in"
+ <+> ((case mb_mod_name of
+ Nothing -> empty
+ Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')
+ <> text (GHC.resumeDecl res))
+ <> char ',' <+> ppr (GHC.resumeSpan res)
showUnits :: GHC.GhcMonad m => m ()
showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do
@@ -4373,12 +4386,8 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do
result <- ignoreSwitch (words argLine)
case result of
Left sdoc -> printForUser sdoc
- Right (loc, count) -> do
- let bi = GHC.BreakpointId
- { bi_tick_mod = breakModule loc
- , bi_tick_index = breakTick loc
- }
- setupBreakpoint bi count
+ Right (loc, count) -> do
+ setupBreakpoint (breakId loc) count
ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch [break, count] = do
@@ -4395,10 +4404,13 @@ getIgnoreCount str =
where
sdocIgnore = text "Ignore count" <+> quotes (text str)
-setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m()
-setupBreakpoint loc count = do
+setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m ()
+setupBreakpoint bi count = do
hsc_env <- GHC.getSession
- GHC.setupBreakpoint (hscInterp hsc_env) loc count
+ -- Trigger all internal breaks that match this source break id
+ internal_break_ids <- getInternalBreaksOf bi
+ forM_ internal_break_ids $ \ibi -> do
+ GHC.setupBreakpoint (hscInterp hsc_env) ibi count
backCmd :: GhciMonad m => String -> m ()
backCmd arg
@@ -4489,20 +4501,20 @@ findBreakAndSet md lookupTickTree = do
some -> mapM_ breakAt some
where
breakAt (tick, pan) = do
- setBreakFlag md tick True
- (alreadySet, nm) <-
- recordBreak $ BreakLocation
- { breakModule = md
- , breakLoc = RealSrcSpan pan Strict.Nothing
- , breakTick = tick
- , onBreakCmd = ""
- , breakEnabled = True
- }
- printForUser $
- text "Breakpoint " <> ppr nm <>
- if alreadySet
- then text " was already set at " <> ppr pan
- else text " activated at " <> ppr pan
+ let bi = BreakpointId md tick
+ setBreakFlag bi True
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakLoc = RealSrcSpan pan Strict.Nothing
+ , breakId = bi
+ , onBreakCmd = ""
+ , breakEnabled = True
+ }
+ printForUser $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr pan
+ else text " activated at " <> ppr pan
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
@@ -4749,14 +4761,32 @@ turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff onOff loc
| onOff == breakEnabled loc = return loc
| otherwise = do
- setBreakFlag (breakModule loc) (breakTick loc) onOff
+ setBreakFlag (breakId loc) onOff
return loc { breakEnabled = onOff }
-setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()
-setBreakFlag md ix enaDisa = do
+setBreakFlag :: GhciMonad m => GHC.BreakpointId -> Bool -> m ()
+setBreakFlag (BreakpointId md ix) enaDisa = do
let enaDisaToCount True = breakOn
enaDisaToCount False = breakOff
- setupBreakpoint (GHC.BreakpointId md ix) $ enaDisaToCount enaDisa
+ setupBreakpoint (BreakpointId md ix) $ enaDisaToCount enaDisa
+
+-- --------------------------------------------------------------------------
+-- Find matching Internal Breakpoints
+
+-- | Find all the internal breakpoints that use the given source-level breakpoint id
+getInternalBreaksOf :: GhciMonad m => BreakpointId -> m [InternalBreakpointId]
+getInternalBreaksOf bi = do
+ st <- getGHCiState
+ let ibrks = internalBreaks st
+ case lookupBreakpointOccurrences ibrks bi of
+ Just bs -> return bs
+ Nothing -> do
+ -- Refresh the internal breakpoints map
+ bs <- mkBreakpointOccurrences
+ setGHCiState st{internalBreaks = bs}
+ return $
+ fromMaybe [] {- still not found after refresh -} $
+ lookupBreakpointOccurrences bs bi
-- ---------------------------------------------------------------------------
-- User code exception handling
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -100,6 +100,14 @@ data GHCiState = GHCiState
-- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
-- so that we don't rebuild it each time the user sets
-- a breakpoint.
+
+ internalBreaks :: BreakpointOccurrences,
+ -- ^ Keep a mapping from the source-level 'BreakpointId' to the
+ -- occurrences of that breakpoint across modules.
+ -- When we want to stop at a source 'BreakpointId', we essentially
+ -- trigger a breakpoint for all 'InternalBreakpointId's matching
+ -- the same source-id.
+
ghci_commands :: [Command],
-- ^ available ghci commands
ghci_macros :: [Command],
@@ -238,16 +246,15 @@ data LocalConfigBehaviour
data BreakLocation
= BreakLocation
- { breakModule :: !GHC.Module
- , breakLoc :: !SrcSpan
- , breakTick :: {-# UNPACK #-} !Int
+ { breakLoc :: !SrcSpan
+ , breakId :: !GHC.BreakpointId
+ -- ^ The 'BreakpointId' uniquely identifies a source-level breakpoint
, breakEnabled:: !Bool
, onBreakCmd :: String
}
instance Eq BreakLocation where
- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
- breakTick loc1 == breakTick loc2
+ loc1 == loc2 = breakId loc1 == breakId loc2
prettyLocations :: IntMap.IntMap BreakLocation -> SDoc
prettyLocations locs =
@@ -256,7 +263,7 @@ prettyLocations locs =
False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs
instance Outputable BreakLocation where
- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>
+ ppr loc = (ppr $ GHC.bi_tick_mod $ breakId loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>
if null (onBreakCmd loc)
then empty
else doubleQuotes (text (onBreakCmd loc))
=====================================
libraries/ghci/GHCi/Debugger.hs
=====================================
@@ -65,10 +65,7 @@ foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
--------------------------------------------------------------------------------
type BreakpointCallback
- = Addr# -- pointer to the breakpoint tick module name
- -> Addr# -- pointer to the breakpoint tick module unit id
- -> Int# -- breakpoint tick index
- -> Addr# -- pointer to the breakpoint info module name
+ = Addr# -- pointer to the breakpoint info module name
-> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -418,10 +418,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: String -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -345,7 +345,7 @@ withBreakAction opts breakMVar statusMVar mtid act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
+ onBreak info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -358,11 +358,9 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- tick_mod <- peekCString (Ptr tick_mod#)
- tick_mod_uid <- BS.packCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
- pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
+ pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -409,8 +407,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
=====================================
rts/Disassembler.c
=====================================
@@ -84,16 +84,23 @@ disInstr ( StgBCO *bco, int pc )
switch (instr & 0xff) {
- case bci_BRK_FUN:
- debugBelch ("BRK_FUN " ); printPtr( ptrs[instrs[pc]] );
- debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] );
- CostCentre* cc = (CostCentre*)literals[instrs[pc+5]];
+ case bci_BRK_FUN: {
+ W_ p1, info_mod, info_unit_id, info_wix, np;
+ p1 = BCO_GET_LARGE_ARG;
+ info_mod = BCO_GET_LARGE_ARG;
+ info_unit_id = BCO_GET_LARGE_ARG;
+ info_wix = BCO_NEXT;
+ np = BCO_GET_LARGE_ARG;
+ debugBelch ("BRK_FUN " ); printPtr( ptrs[p1] );
+ debugBelch("%" FMT_Word, literals[info_mod] );
+ debugBelch("%" FMT_Word, literals[info_unit_id] );
+ debugBelch("%" FMT_Word, info_wix );
+ CostCentre* cc = (CostCentre*)literals[np];
if (cc) {
debugBelch(" %s", cc->label);
}
debugBelch("\n");
- pc += 6;
- break;
+ break; }
case bci_BRK_ALTS:
debugBelch ("BRK_ALTS %d\n", BCO_NEXT);
break;
=====================================
rts/Exception.cmm
=====================================
@@ -535,23 +535,17 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(17);
- Sp(16) = exception;
- Sp(15) = stg_raise_ret_info;
- Sp(14) = exception;
- Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(12) = stg_ap_ppv_info;
- Sp(11) = 0;
- Sp(10) = stg_ap_n_info;
- Sp(9) = 0;
- Sp(8) = stg_ap_n_info;
- Sp(7) = 0;
- Sp(6) = stg_ap_n_info;
- Sp(5) = 0;
- Sp(4) = stg_ap_n_info;
- Sp(3) = 0;
- Sp(2) = stg_ap_n_info;
- Sp(1) = 0;
+ Sp = Sp - WDS(11);
+ Sp(10) = exception;
+ Sp(9) = stg_raise_ret_info;
+ Sp(8) = exception;
+ Sp(7) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(6) = stg_ap_ppv_info;
+ Sp(5) = 0;
+ Sp(4) = stg_ap_n_info;
+ Sp(3) = 0;
+ Sp(2) = stg_ap_n_info;
+ Sp(1) = 0;
R1 = ioAction;
jump RET_LBL(stg_ap_n) [R1];
}
=====================================
rts/Interpreter.c
=====================================
@@ -685,8 +685,6 @@ interpretBCO (Capability* cap)
*/
if (cap->r.rCurrentTSO->flags & TSO_STOP_AFTER_RETURN) {
- StgBCO* bco;
- StgWord16* bco_instrs;
StgHalfWord type;
/* Store the entry Sp; traverse the stack modifying Sp (using Sp macros);
@@ -706,28 +704,33 @@ interpretBCO (Capability* cap)
ASSERT(type == RET_BCO || type == STOP_FRAME);
if (type == RET_BCO) {
- bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO
+ StgBCO* bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO
ASSERT(get_itbl((StgClosure*)bco)->type == BCO);
- bco_instrs = (StgWord16*)(bco->instrs->payload);
+
+ StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
+ StgWord16 bci = instrs[0];
/* A breakpoint instruction (BRK_FUN or BRK_ALTS) is always the first
* instruction in a BCO */
- if ((bco_instrs[0] & 0xFF) == bci_BRK_FUN) {
- int brk_array, tick_index;
- StgArrBytes *breakPoints;
- StgPtr* ptrs;
+ if ((bci & 0xFF) == bci_BRK_FUN) {
+ // Define rest of variables used by BCO_* Macros
+ int bciPtr = 0;
+
+ W_ arg1_brk_array, arg4_info_index;
+ arg1_brk_array = BCO_GET_LARGE_ARG;
+ /* info_mod_name = */ BCO_GET_LARGE_ARG;
+ /* info_mod_id = */ BCO_GET_LARGE_ARG;
+ arg4_info_index = BCO_NEXT;
- ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
- brk_array = bco_instrs[1];
- tick_index = bco_instrs[6];
+ StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
+ StgArrBytes* breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
- breakPoints = (StgArrBytes *) BCO_PTR(brk_array);
// ACTIVATE the breakpoint by tick index
- ((StgInt*)breakPoints->payload)[tick_index] = 0;
+ ((StgInt*)breakPoints->payload)[arg4_info_index] = 0;
}
- else if ((bco_instrs[0] & 0xFF) == bci_BRK_ALTS) {
+ else if ((bci & 0xFF) == bci_BRK_ALTS) {
// ACTIVATE BRK_ALTS by setting its only argument to ON
- bco_instrs[1] = 1;
+ instrs[1] = 1;
}
// else: if there is no BRK instruction perhaps we should keep
// traversing; that said, the continuation should always have a BRK
@@ -1520,9 +1523,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
+ W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
#if defined(PROFILING)
- int arg8_cc;
+ W_ arg5_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break, stop_next_breakpoint;
@@ -1537,14 +1540,11 @@ run_BCO:
int size_words;
arg1_brk_array = BCO_GET_LARGE_ARG;
- arg2_tick_mod = BCO_GET_LARGE_ARG;
- arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_mod_id = BCO_GET_LARGE_ARG;
- arg5_info_mod_id = BCO_GET_LARGE_ARG;
- arg6_tick_index = BCO_NEXT;
- arg7_info_index = BCO_NEXT;
+ arg2_info_mod_name = BCO_GET_LARGE_ARG;
+ arg3_info_mod_id = BCO_GET_LARGE_ARG;
+ arg4_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg8_cc = BCO_GET_LARGE_ARG;
+ arg5_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1564,7 +1564,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg8_cc));
+ (CostCentre*)BCO_LIT(arg5_cc));
#endif
// if we are returning from a break then skip this section
@@ -1575,11 +1575,11 @@ run_BCO:
// stop the current thread if either `stop_next_breakpoint` is
// true OR if the ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_info_index];
if (stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg4_info_index] = --ignore_count;
}
else if (stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1613,10 +1613,7 @@ run_BCO:
// Arrange the stack to call the breakpoint IO action, and
// continue execution of this BCO when the IO action returns.
//
- // ioAction :: Addr# -- the breakpoint tick module
- // -> Addr# -- the breakpoint tick module unit id
- // -> Int# -- the breakpoint tick index
- // -> Addr# -- the breakpoint info module
+ // ioAction :: Addr# -- the breakpoint info module
// -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
@@ -1626,23 +1623,17 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(19);
- SpW(18) = (W_)obj;
- SpW(17) = (W_)&stg_apply_interp_info;
- SpW(16) = (W_)new_aps;
- SpW(15) = (W_)False_closure; // True <=> an exception
- SpW(14) = (W_)&stg_ap_ppv_info;
- SpW(13) = (W_)arg7_info_index;
- SpW(12) = (W_)&stg_ap_n_info;
- SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
- SpW(10) = (W_)&stg_ap_n_info;
- SpW(9) = (W_)BCO_LIT(arg3_info_mod);
- SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)arg6_tick_index;
+ Sp_subW(13);
+ SpW(12) = (W_)obj;
+ SpW(11) = (W_)&stg_apply_interp_info;
+ SpW(10) = (W_)new_aps;
+ SpW(9) = (W_)False_closure; // True <=> an exception
+ SpW(8) = (W_)&stg_ap_ppv_info;
+ SpW(7) = (W_)arg4_info_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
+ SpW(5) = (W_)BCO_LIT(arg3_info_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
- SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
+ SpW(3) = (W_)BCO_LIT(arg2_info_mod_name);
SpW(2) = (W_)&stg_ap_n_info;
SpW(1) = (W_)ioAction;
SpW(0) = (W_)&stg_enter_info;
=====================================
rts/linker/LoadArchive.c
=====================================
@@ -140,6 +140,10 @@ static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz)
if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) {
return MachO64;
}
+ // BigObj COFF files ...
+ if (sz > 8 && ((uint64_t*)buf)[0] == 0x86640002ffff0000) {
+ return COFFAmd64;
+ }
return NotObject;
}
=====================================
testsuite/tests/corelint/T21115b.stderr
=====================================
@@ -30,6 +30,6 @@ end Rec }
*** End of Offense ***
-
-<no location info>: error:
Compilation had errors
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfed1a962cc300be5735646e52be361...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfed1a962cc300be5735646e52be361...
You're receiving this email because of your account on gitlab.haskell.org.
