GitLab

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

Commits:

2ea465e0

by Rodrigo Mesquita at 2025-07-31T17:56:52-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 <module,index>.

- 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]

beecfb55

by Simon Hengel at 2025-07-31T17:56:53-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

```

2ff38e31

by Simon Hengel at 2025-07-31T17:56:53-04:00

Respect `-fdiagnostics-as-json` for driver diagnostics (see #24113)

24 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
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;

testsuite/tests/corelint/T21115b.stderr

@@ -30,6 +30,6 @@ end Rec }
  *** End of Offense ***
+-
 -<no location info>: error:
  Compilation had errors
++
++