Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

20 changed files:

Changes:

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -841,24 +841,18 @@ assembleI platform i = case i of
    841 841 
         W8                   -> emit_ bci_OP_INDEX_ADDR_08 []
    842 842 
         _                    -> unsupported_width
    843 843
    844 
    -  BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox) -> do
    844 
    +  BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do
    845 
    +    p1 <- ptr $ BCOPtrBreakArray info_mod
    845 846 
         let -- cast that checks that round-tripping through Word16 doesn't change the value
    846 847 
             toW16 x = let r = fromIntegral x :: Word16
    847 848 
                       in if fromIntegral r == x
    848 849 
                         then r
    849 850 
                         else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
    850 
    -    p1 <- ptr $ BCOPtrBreakArray tick_mod
    851 
    -    tick_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName tick_mod
    852 
    -    info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
    853 
    -    tick_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ tick_mod
    854 
    -    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ info_mod
    855 
    -    np <- lit1 $ BCONPtrCostCentre (BreakpointId tick_mod tickx)
    856 
    -    emit_ bci_BRK_FUN [ Op p1
    857 
    -                     , Op tick_addr, Op info_addr
    858 
    -                     , Op tick_unitid_addr, Op info_unitid_addr
    859 
    -                     , SmallOp (toW16 tickx), SmallOp (toW16 infox)
    860 
    -                     , Op np
    861 
    -                     ]
    851 
    +    info_addr        <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
    852 
    +    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS     $ moduleUnitId info_mod
    853 
    +    np               <- lit1 $ BCONPtrCostCentre ibi
    854 
    +    emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr
    855 
    +                      , SmallOp (toW16 infox), Op np ]
    862 856
    863 857 
       BRK_ALTS active -> emit_ bci_BRK_ALTS [SmallOp (if active then 1 else 0)]
    864 858

  • compiler/GHC/ByteCode/Breakpoints.hs
    ... ... @@ -7,23 +7,23 @@
    7 7 
     -- 'InternalModBreaks', and is uniquely identified at runtime by an
    8 8 
     -- 'InternalBreakpointId'.
    9 9 
     --
    10 
    --- See Note [Breakpoint identifiers]
    10 
    +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
    11 11 
     module GHC.ByteCode.Breakpoints
    12 12 
       ( -- * Internal Mod Breaks
    13 13 
         InternalModBreaks(..), CgBreakInfo(..)
    14 
    -  , mkInternalModBreaks
    14 
    +  , mkInternalModBreaks, imodBreaks_module
    15 15
    16 16 
         -- ** Internal breakpoint identifier
    17 17 
       , InternalBreakpointId(..), BreakInfoIndex
    18 18
    19 19 
         -- * Operations
    20 
    -  , toBreakpointId
    21 20
    22 21 
         -- ** Internal-level operations
    23 
    -  , getInternalBreak, addInternalBreak
    22 
    +  , getInternalBreak
    24 23
    25 24 
         -- ** Source-level information operations
    26 25 
       , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
    26 
    +  , getBreakSourceId
    27 27
    28 28 
         -- * Utils
    29 29 
       , seqInternalModBreaks
    ... ... @@ -47,6 +47,31 @@ import GHC.Utils.Panic
    47 47 
     import Data.Array
    48 48
    49 49 
     {-
    50 
    +Note [ModBreaks vs InternalModBreaks]
    51 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    52 
    +'ModBreaks' and 'BreakpointId's must not to be confused with
    53 
    +'InternalModBreaks' and 'InternalBreakId's.
    54 
    +
    55 
    +'ModBreaks' is constructed once during HsToCore from the information attached
    56 
    +to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'
    57 
    +can be queried using 'BreakpointId's, which uniquely identifies a breakpoint
    58 
    +within the list of breakpoint information for a given module's 'ModBreaks'.
    59 
    +
    60 
    +'InternalModBreaks' are constructed during bytecode generation and are indexed
    61 
    +by a 'InternalBreakpointId'. They contain all the information relevant to a
    62 
    +breakpoint for code generation that can be accessed during runtime execution
    63 
    +(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's
    64 
    +are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'
    65 
    +instruction receives 'InternalBreakpointId' as an argument.
    66 
    +
    67 
    +We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used
    68 
    +to get source-level information about a breakpoint via the corresponding 'ModBreaks'.
    69 
    +
    70 
    +Notably, 'InternalModBreaks' can contain entries for so-called internal
    71 
    +breakpoints, which do not necessarily have a source-level location attached to
    72 
    +it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to
    73 
    +introduce breakpoints during code generation for features such as stepping-out.
    74 
    +
    50 75 
     Note [Breakpoint identifiers]
    51 76 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    52 77 
     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
    64 89 
     we store it alongside the occurrence module (*info module*) in the
    65 90 
     'InternalBreakpointId' datatype. This is the index that we use at runtime to
    66 91 
     identify a breakpoint.
    92 
    +
    93 
    +When the internal breakpoint has a matching tick-level breakpoint we can fetch
    94 
    +the related tick-level information by first looking up a mapping
    95 
    +@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@.
    67 96 
     -}
    68 97
    69 98 
     --------------------------------------------------------------------------------
    ... ... @@ -78,19 +107,11 @@ type BreakInfoIndex = Int
    78 107 
     -- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.
    79 108 
     -- See Note [Breakpoint identifiers]
    80 109 
     data InternalBreakpointId = InternalBreakpointId
    81 
    -  { ibi_tick_mod   :: !Module         -- ^ Breakpoint tick module
    82 
    -  , ibi_tick_index :: !Int            -- ^ Breakpoint tick index
    83 
    -  , ibi_info_mod   :: !Module         -- ^ Breakpoint tick module
    84 
    -  , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint tick index
    110 
    +  { ibi_info_mod   :: !Module         -- ^ Breakpoint info module
    111 
    +  , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index
    85 112 
       }
    86 113 
       deriving (Eq, Ord)
    87 114
    88 
    -toBreakpointId :: InternalBreakpointId -> BreakpointId
    89 
    -toBreakpointId ibi = BreakpointId
    90 
    -  { bi_tick_mod   = ibi_tick_mod ibi
    91 
    -  , bi_tick_index = ibi_tick_index ibi
    92 
    -  }
    93 
    -
    94 115 
     --------------------------------------------------------------------------------
    95 116 
     -- * Internal Mod Breaks
    96 117 
     --------------------------------------------------------------------------------
    ... ... @@ -107,18 +128,34 @@ data InternalModBreaks = InternalModBreaks
    107 128 
             -- 'InternalBreakpointId'.
    108 129
    109 130 
           , imodBreaks_modBreaks :: !ModBreaks
    110 
    -        -- ^ Store the original ModBreaks for this module, unchanged.
    111 
    -        -- Allows us to query about source-level breakpoint information using
    112 
    -        -- an internal breakpoint id.
    131 
    +        -- ^ Store the ModBreaks for this module
    132 
    +        --
    133 
    +        -- Recall Note [Breakpoint identifiers]: for some module A, an
    134 
    +        -- *occurrence* of a breakpoint in A may have been inlined from some
    135 
    +        -- breakpoint *defined* in module B.
    136 
    +        --
    137 
    +        -- This 'ModBreaks' contains information regarding all the breakpoints
    138 
    +        -- defined in the module this 'InternalModBreaks' corresponds to. It
    139 
    +        -- /does not/ necessarily have information regarding all the breakpoint
    140 
    +        -- occurrences registered in 'imodBreaks_breakInfo'. Some of those
    141 
    +        -- occurrences may refer breakpoints inlined from other modules.
    113 142 
           }
    114 143
    115 
    --- | Construct an 'InternalModBreaks'
    144 
    +-- | Construct an 'InternalModBreaks'.
    145 
    +--
    146 
    +-- INVARIANT: The given 'ModBreaks' correspond to the same module as this
    147 
    +-- 'InternalModBreaks' module (the first argument) and its breakpoint infos
    148 
    +-- (the @IntMap CgBreakInfo@ argument)
    116 149 
     mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks
    117 150 
     mkInternalModBreaks mod im mbs =
    118 151 
       assertPpr (mod == modBreaks_module mbs)
    119 152 
         (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $
    120 153 
           InternalModBreaks im mbs
    121 154
    155 
    +-- | Get the module to which these 'InternalModBreaks' correspond
    156 
    +imodBreaks_module :: InternalModBreaks -> Module
    157 
    +imodBreaks_module = modBreaks_module . imodBreaks_modBreaks
    158 
    +
    122 159 
     -- | Information about a breakpoint that we know at code-generation time
    123 160 
     -- In order to be used, this needs to be hydrated relative to the current HscEnv by
    124 161 
     -- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
    ... ... @@ -128,20 +165,22 @@ data CgBreakInfo
    128 165 
        { cgb_tyvars  :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
    129 166 
        , cgb_vars    :: ![Maybe (IfaceIdBndr, Word)]
    130 167 
        , cgb_resty   :: !IfaceType
    168 
    +   , cgb_tick_id :: !BreakpointId
    169 
    +     -- ^ This field records the original breakpoint tick identifier for this
    170 
    +     -- internal breakpoint info. It is used to convert a breakpoint
    171 
    +     -- *occurrence* index ('InternalBreakpointId') into a *definition* index
    172 
    +     -- ('BreakpointId').
    173 
    +     --
    174 
    +     -- The modules of breakpoint occurrence and breakpoint definition are not
    175 
    +     -- necessarily the same: See Note [Breakpoint identifiers].
    131 176 
        }
    132 177 
     -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
    133 178
    134 179 
     -- | Get an internal breakpoint info by 'InternalBreakpointId'
    135 180 
     getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
    136 
    -getInternalBreak (InternalBreakpointId _ _ info_mod info_ix) imbs =
    137 
    -  assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $
    138 
    -    imodBreaks_breakInfo imbs IM.! info_ix
    139 
    -
    140 
    --- | Add a CgBreakInfo to an 'InternalModBreaks' at 'InternalBreakpointId'
    141 
    -addInternalBreak :: InternalBreakpointId -> CgBreakInfo -> InternalModBreaks -> InternalModBreaks
    142 
    -addInternalBreak (InternalBreakpointId _ _ info_mod info_ix) info imbs =
    143 
    -  assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $
    144 
    -    imbs{imodBreaks_breakInfo = IM.insert info_ix info (imodBreaks_breakInfo imbs)}
    181 
    +getInternalBreak (InternalBreakpointId mod ix) imbs =
    182 
    +  assert_modules_match mod (imodBreaks_module imbs) $
    183 
    +    imodBreaks_breakInfo imbs IM.! ix
    145 184
    146 185 
     -- | Assert that the module in the 'InternalBreakpointId' and in
    147 186 
     -- 'InternalModBreaks' match.
    ... ... @@ -155,27 +194,56 @@ assert_modules_match ibi_mod imbs_mod =
    155 194 
     -- Tick-level Breakpoint information
    156 195 
     --------------------------------------------------------------------------------
    157 196
    197 
    +-- | Get the source module and tick index for this breakpoint
    198 
    +-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
    199 
    +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
    200 
    +getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
    201 
    +  assert_modules_match ibi_mod (imodBreaks_module imbs) $
    202 
    +    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
    203 
    +     in cgb_tick_id cgb
    204 
    +
    158 205 
     -- | Get the source span for this breakpoint
    159 
    -getBreakLoc  :: InternalBreakpointId -> InternalModBreaks -> SrcSpan
    206 
    +getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
    160 207 
     getBreakLoc = getBreakXXX modBreaks_locs
    161 208
    162 209 
     -- | Get the vars for this breakpoint
    163 
    -getBreakVars  :: InternalBreakpointId -> InternalModBreaks -> [OccName]
    210 
    +getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
    164 211 
     getBreakVars = getBreakXXX modBreaks_vars
    165 212
    166 213 
     -- | Get the decls for this breakpoint
    167 
    -getBreakDecls :: InternalBreakpointId -> InternalModBreaks -> [String]
    214 
    +getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
    168 215 
     getBreakDecls = getBreakXXX modBreaks_decls
    169 216
    170 217 
     -- | Get the decls for this breakpoint
    171 
    -getBreakCCS :: InternalBreakpointId -> InternalModBreaks -> (String, String)
    218 
    +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
    172 219 
     getBreakCCS = getBreakXXX modBreaks_ccs
    173 220
    174 221 
     -- | Internal utility to access a ModBreaks field at a particular breakpoint index
    175 
    -getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> InternalBreakpointId -> InternalModBreaks -> a
    176 
    -getBreakXXX view (InternalBreakpointId tick_mod tick_id _ _) imbs =
    177 
    -  assert_modules_match tick_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $ do
    178 
    -    view (imodBreaks_modBreaks imbs) ! tick_id
    222 
    +--
    223 
    +-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the
    224 
    +-- *occurrence* module) doesn't necessarily match the module where the
    225 
    +-- tick breakpoint was defined with the relevant 'ModBreaks'.
    226 
    +--
    227 
    +-- When the tick module is the same as the internal module, we use the stored
    228 
    +-- 'ModBreaks'. When the tick module is different, we need to look up the
    229 
    +-- 'ModBreaks' in the HUG for that other module.
    230 
    +--
    231 
    +-- To avoid cyclic dependencies, we instead receive a function that looks up
    232 
    +-- the 'ModBreaks' given a 'Module'
    233 
    +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
    234 
    +getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
    235 
    +  assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
    236 
    +    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
    237 
    +    case cgb_tick_id cgb of
    238 
    +      BreakpointId{bi_tick_mod, bi_tick_index}
    239 
    +        | bi_tick_mod == ibi_mod
    240 
    +        -> do
    241 
    +          let these_mbs = imodBreaks_modBreaks imbs
    242 
    +          return $ view these_mbs ! bi_tick_index
    243 
    +        | otherwise
    244 
    +        -> do
    245 
    +          other_mbs <- lookupModule bi_tick_mod
    246 
    +          return $ view other_mbs ! bi_tick_index
    179 247
    180 248 
     --------------------------------------------------------------------------------
    181 249 
     -- Instances
    ... ... @@ -190,7 +258,8 @@ seqInternalModBreaks InternalModBreaks{..} =
    190 258 
         seqCgBreakInfo CgBreakInfo{..} =
    191 259 
             rnf cgb_tyvars `seq`
    192 260 
             rnf cgb_vars `seq`
    193 
    -        rnf cgb_resty
    261 
    +        rnf cgb_resty `seq`
    262 
    +        rnf cgb_tick_id
    194 263
    195 264 
     instance Outputable InternalBreakpointId where
    196 265 
       ppr InternalBreakpointId{..} =
    ... ... @@ -203,4 +272,5 @@ instance NFData InternalBreakpointId where
    203 272 
     instance Outputable CgBreakInfo where
    204 273 
        ppr info = text "CgBreakInfo" <+>
    205 274 
                   parens (ppr (cgb_vars info) <+>
    206 
    -                      ppr (cgb_resty info))
    275 
    +                      ppr (cgb_resty info) <+>
    276 
    +                      ppr (cgb_tick_id info))

  • compiler/GHC/ByteCode/Instr.hs
    ... ... @@ -454,9 +454,8 @@ instance Outputable BCInstr where
    454 454 
        ppr ENTER                 = text "ENTER"
    455 455 
        ppr (RETURN pk)           = text "RETURN  " <+> ppr pk
    456 456 
        ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"
    457 
    -   ppr (BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox))
    457 
    +   ppr (BRK_FUN (InternalBreakpointId info_mod infox))
    458 458 
                                  = text "BRK_FUN" <+> text "<breakarray>"
    459 
    -                               <+> ppr tick_mod <+> ppr tickx
    460 459 
                                    <+> ppr info_mod <+> ppr infox
    461 460 
                                    <+> text "<cc>"
    462 461 
        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
    98 98 
       BCONPtrFFIInfo (FFIInfo {..}) -> do
    99 99 
         RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet
    100 100 
         pure $ fromIntegral p
    101 
    -  BCONPtrCostCentre BreakpointId{..}
    101 
    +  BCONPtrCostCentre InternalBreakpointId{..}
    102 102 
         | interpreterProfiled interp -> do
    103 
    -        case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of
    103 
    +        case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of
    104 104 
               RemotePtr p -> pure $ fromIntegral p
    105 105 
         | otherwise ->
    106 106 
             case toRemotePtr nullPtr of

  • compiler/GHC/ByteCode/Types.hs
    ... ... @@ -285,7 +285,7 @@ data BCONPtr
    285 285 
       -- | A libffi ffi_cif function prototype.
    286 286 
       | BCONPtrFFIInfo !FFIInfo
    287 287 
       -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'
    288 
    -  | BCONPtrCostCentre !BreakpointId
    288 
    +  | BCONPtrCostCentre !InternalBreakpointId
    289 289
    290 290 
     instance NFData BCONPtr where
    291 291 
       rnf x = x `seq` ()

  • compiler/GHC/CoreToIface.hs
    ... ... @@ -704,12 +704,13 @@ toIfaceLFInfo nm lfi = case lfi of
    704 704
    705 705 
     -- Dehydrating CgBreakInfo
    706 706
    707 
    -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo
    708 
    -dehydrateCgBreakInfo ty_vars idOffSets tick_ty =
    707 
    +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
    708 
    +dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
    709 709 
               CgBreakInfo
    710 710 
                 { cgb_tyvars = map toIfaceTvBndr ty_vars
    711 711 
                 , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets
    712 712 
                 , cgb_resty = toIfaceType tick_ty
    713 
    +            , cgb_tick_id = bid
    713 714 
                 }
    714 715
    715 716 
     {- Note [Inlining and hs-boot files]

  • compiler/GHC/HsToCore/Breakpoints.hs
    ... ... @@ -12,7 +12,7 @@
    12 12 
     -- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed
    13 13 
     -- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'.
    14 14 
     --
    15 
    --- See Note [Breakpoint identifiers]
    15 
    +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]
    16 16 
     module GHC.HsToCore.Breakpoints
    17 17 
       ( -- * ModBreaks
    18 18 
         mkModBreaks, ModBreaks(..)

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -124,7 +124,9 @@ import GHC.Utils.Exception
    124 124 
     import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
    125 125 
     import GHC.Driver.Downsweep
    126 126 
     import qualified GHC.Runtime.Interpreter as GHCi
    127 
    -import Data.Array.Base (numElements)
    127 
    +import qualified Data.IntMap.Strict as IM
    128 
    +import qualified Data.Map.Strict as M
    129 
    +import Foreign.Ptr (nullPtr)
    128 130
    129 131 
     -- Note [Linkers and loaders]
    130 132 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1666,10 +1668,10 @@ allocateBreakArrays ::
    1666 1668 
       IO (ModuleEnv (ForeignRef BreakArray))
    1667 1669 
     allocateBreakArrays interp =
    1668 1670 
       foldlM
    1669 
    -    ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    1671 
    +    ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do
    1670 1672 
             -- If no BreakArray is assigned to this module yet, create one
    1671 1673 
             if not $ elemModuleEnv modBreaks_module be0 then do
    1672 
    -          let count = numElements modBreaks_locs
    1674 
    +          let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo
    1673 1675 
               breakArray <- GHCi.newBreakArray interp count
    1674 1676 
               evaluate $ extendModuleEnv be0 modBreaks_module breakArray
    1675 1677 
             else
    ... ... @@ -1679,29 +1681,51 @@ allocateBreakArrays interp =
    1679 1681 
     -- | Given a list of 'InternalModBreaks' collected from a list
    1680 1682 
     -- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
    1681 1683 
     -- enabled.
    1684 
    +--
    1685 
    +-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal
    1686 
    +-- breakpoint index), not by tick index
    1682 1687 
     allocateCCS ::
    1683 1688 
       Interp ->
    1684 
    -  ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
    1689 
    +  ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) ->
    1685 1690 
       [InternalModBreaks] ->
    1686 
    -  IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
    1691 
    +  IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)))
    1687 1692 
     allocateCCS interp ce mbss
    1688 
    -  | interpreterProfiled interp =
    1689 
    -      foldlM
    1690 
    -        ( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    1691 
    -            ccs <-
    1693 
    +  | interpreterProfiled interp = do
    1694 
    +      -- 1. Create a mapping from source BreakpointId to CostCentre ptr
    1695 
    +      ccss <- M.unions <$> mapM
    1696 
    +        ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do
    1697 
    +            ccs <- {- one ccs ptr per tick index -}
    1692 1698 
                   mkCostCentres
    1693 1699 
                     interp
    1694 1700 
                     (moduleNameString $ moduleName modBreaks_module)
    1695 1701 
                     (elems modBreaks_ccs)
    1696 
    -            if not $ elemModuleEnv modBreaks_module ce0 then do
    1697 
    -              evaluate $
    1698 
    -                extendModuleEnv ce0 modBreaks_module $
    1699 
    -                  listArray
    1700 
    -                    (0, length ccs - 1)
    1701 
    -                    ccs
    1702 
    +            return $ M.fromList $
    1703 
    +              zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
    1704 
    +        )
    1705 
    +        mbss
    1706 
    +      -- 2. Create an array with one element for every InternalBreakpointId,
    1707 
    +      --    where every element has the CCS for the corresponding BreakpointId
    1708 
    +      foldlM
    1709 
    +        (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do
    1710 
    +            if not $ elemModuleEnv modBreaks_module ce then do
    1711 
    +              let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo
    1712 
    +              let ccs = IM.map
    1713 
    +                    (\info ->
    1714 
    +                      fromMaybe (toRemotePtr nullPtr)
    1715 
    +                        (M.lookup (cgb_tick_id info) ccss)
    1716 
    +                    )
    1717 
    +                    imodBreaks_breakInfo
    1718 
    +              assertPpr (count == length ccs)
    1719 
    +                (text "expected CgBreakInfo map to have one entry per valid ix") $
    1720 
    +                evaluate $
    1721 
    +                  extendModuleEnv ce0 modBreaks_module $
    1722 
    +                    listArray
    1723 
    +                      (0, count)
    1724 
    +                      (IM.elems ccs)
    1702 1725 
                 else
    1703 1726 
                   return ce0
    1704 1727 
             )
    1705 1728 
             ce
    1706 1729 
             mbss
    1730 
    +
    1707 1731 
       | otherwise = pure ce

  • compiler/GHC/Runtime/Debugger/Breakpoints.hs
    ... ... @@ -31,6 +31,9 @@ import GHC.Unit.Module.ModSummary
    31 31 
     import GHC.Utils.Outputable
    32 32 
     import GHC.Utils.Panic
    33 33 
     import qualified GHC.Data.Strict as Strict
    34 
    +import qualified Data.IntMap.Strict as IntMap
    35 
    +import qualified GHC.Unit.Home.Graph as HUG
    36 
    +import qualified GHC.Unit.Home.PackageTable as HPT
    34 37
    35 38 
     --------------------------------------------------------------------------------
    36 39 
     -- Finding Module breakpoints
    ... ... @@ -213,6 +216,47 @@ getModBreak m = do
    213 216 
        mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m
    214 217 
        pure $ imodBreaks_modBreaks <$> modInfoModBreaks mod_info
    215 218
    219 
    +--------------------------------------------------------------------------------
    220 
    +-- Mapping source-level BreakpointIds to IBI occurrences
    221 
    +-- (See Note [Breakpoint identifiers])
    222 
    +--------------------------------------------------------------------------------
    223 
    +
    224 
    +-- | A source-level breakpoint may have been inlined into many occurrences, now
    225 
    +-- referred by 'InternalBreakpointId'. When a breakpoint is set on a certain
    226 
    +-- source breakpoint, it means all *ocurrences* of that breakpoint across
    227 
    +-- modules should be stopped at -- hence we keep a trie from BreakpointId to
    228 
    +-- the list of internal break ids using it.
    229 
    +-- See also Note [Breakpoint identifiers]
    230 
    +type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId])
    231 
    +
    232 
    +-- | Lookup all InternalBreakpointIds matching the given BreakpointId
    233 
    +-- Nothing if BreakpointId not in map
    234 
    +lookupBreakpointOccurrences :: BreakpointOccurrences -> BreakpointId -> Maybe [InternalBreakpointId]
    235 
    +lookupBreakpointOccurrences bmp (BreakpointId md tick) =
    236 
    +  lookupModuleEnv bmp md >>= IntMap.lookup tick
    237 
    +
    238 
    +-- | Construct a mapping from Source 'BreakpointId's to 'InternalBreakpointId's from the given list of 'ModInfo's
    239 
    +mkBreakpointOccurrences :: forall m. GhcMonad m => m BreakpointOccurrences
    240 
    +mkBreakpointOccurrences = do
    241 
    +  hug <- hsc_HUG <$> getSession
    242 
    +  liftIO $ foldr go (pure emptyModuleEnv) hug
    243 
    +  where
    244 
    +    go :: HUG.HomeUnitEnv -> IO BreakpointOccurrences -> IO BreakpointOccurrences
    245 
    +    go hue mbmp = do
    246 
    +      bmp <- mbmp
    247 
    +      ibrkss <- HPT.concatHpt (\hmi -> maybeToList (getModBreaks hmi))
    248 
    +                             (HUG.homeUnitEnv_hpt hue)
    249 
    +      return $ foldr addBreakToMap bmp ibrkss
    250 
    +
    251 
    +    addBreakToMap :: InternalModBreaks -> BreakpointOccurrences -> BreakpointOccurrences
    252 
    +    addBreakToMap ibrks bmp0 = do
    253 
    +      let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
    254 
    +      IntMap.foldrWithKey (\info_ix cgi bmp -> do
    255 
    +          let ibi = InternalBreakpointId imod info_ix
    256 
    +          let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
    257 
    +          extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
    258 
    +        ) bmp0 (imodBreaks_breakInfo ibrks)
    259 
    +
    216 260 
     --------------------------------------------------------------------------------
    217 261 
     -- Getting current breakpoint information
    218 262 
     --------------------------------------------------------------------------------
    ... ... @@ -235,9 +279,15 @@ getCurrentBreakSpan = do
    235 279 
     getCurrentBreakModule :: GhcMonad m => m (Maybe Module)
    236 280 
     getCurrentBreakModule = do
    237 281 
       resumes <- getResumeContext
    238 
    -  return $ case resumes of
    239 
    -    [] -> Nothing
    282 
    +  hug <- hsc_HUG <$> getSession
    283 
    +  liftIO $ case resumes of
    284 
    +    [] -> pure Nothing
    240 285 
         (r:_) -> case resumeHistoryIx r of
    241 
    -      0  -> ibi_tick_mod <$> resumeBreakpointId r
    242 
    -      ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1)
    286 
    +      0  -> case resumeBreakpointId r of
    287 
    +        Nothing -> pure Nothing
    288 
    +        Just ibi -> do
    289 
    +          brks <- readIModBreaks hug ibi
    290 
    +          return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
    291 
    +      ix ->
    292 
    +          Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
    243 293

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -18,7 +18,7 @@ module GHC.Runtime.Eval (
    18 18 
             abandon, abandonAll,
    19 19 
             getResumeContext,
    20 20 
             getHistorySpan,
    21 
    -        getModBreaks, readModBreaks,
    21 
    +        getModBreaks, readIModBreaks, readIModModBreaks,
    22 22 
             getHistoryModule,
    23 23 
             setupBreakpoint,
    24 24 
             back, forward,
    ... ... @@ -147,14 +147,17 @@ getResumeContext = withSession (return . ic_resume . hsc_IC)
    147 147 
     mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History
    148 148 
     mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi
    149 149
    150 
    -getHistoryModule :: History -> Module
    151 
    -getHistoryModule = ibi_tick_mod . historyBreakpointId
    150 
    +getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
    151 
    +getHistoryModule hug hist = do
    152 
    +  let ibi = historyBreakpointId hist
    153 
    +  brks <- readIModBreaks hug ibi
    154 
    +  return $ bi_tick_mod $ getBreakSourceId ibi brks
    152 155
    153 156 
     getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
    154 157 
     getHistorySpan hug hist = do
    155 158 
       let ibi = historyBreakpointId hist
    156 
    -  brks <- readModBreaks hug (ibi_tick_mod ibi)
    157 
    -  return $ getBreakLoc ibi brks
    159 
    +  brks <- readIModBreaks hug ibi
    160 
    +  getBreakLoc (readIModModBreaks hug) ibi brks
    158 161
    159 162 
     {- | Finds the enclosing top level function name -}
    160 163 
     -- 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
    162 165 
     -- for each tick.
    163 166 
     findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String]
    164 167 
     findEnclosingDecls hug ibi = do
    165 
    -  brks <- readModBreaks hug (ibi_tick_mod ibi)
    166 
    -  return $ getBreakDecls ibi brks
    168 
    +  brks <- readIModBreaks hug ibi
    169 
    +  getBreakDecls (readIModModBreaks hug) ibi brks
    167 170
    168 171 
     -- | Update fixity environment in the current interactive context.
    169 172 
     updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
    ... ... @@ -350,15 +353,14 @@ handleRunStatus step expr bindings final_ids status history0 = do
    350 353 
         EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
    351 354 
           let ibi = evalBreakpointToId eval_break
    352 355 
           let hug = hsc_HUG hsc_env
    353 
    -      tick_brks  <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
    354 
    -      let
    355 
    -        span = getBreakLoc ibi tick_brks
    356 
    -        decl = intercalate "." $ getBreakDecls ibi tick_brks
    356 
    +      info_brks  <- liftIO $ readIModBreaks hug ibi
    357 
    +      span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks
    358 
    +      decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks
    357 359
    358 360 
           -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
    359 361 
           bactive <- liftIO $ do
    360 
    -        breakArray <- getBreakArray interp (toBreakpointId ibi) tick_brks
    361 
    -        breakpointStatus interp breakArray (ibi_tick_index ibi)
    362 
    +        breakArray <- getBreakArray interp ibi info_brks
    363 
    +        breakpointStatus interp breakArray (ibi_info_index ibi)
    362 364
    363 365 
           apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
    364 366 
           resume_ctxt_fhv   <- liftIO $ mkFinalizedHValue interp resume_ctxt
    ... ... @@ -446,7 +448,7 @@ resumeExec step mbCnt
    446 448 
                     -- When the user specified a break ignore count, set it
    447 449 
                     -- in the interpreter
    448 450 
                     case (mb_brkpt, mbCnt) of
    449 
    -                  (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt
    451 
    +                  (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt
    450 452 
                       _ -> return ()
    451 453
    452 454 
                     let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
    ... ... @@ -462,17 +464,18 @@ resumeExec step mbCnt
    462 464 
                              | otherwise -> pure prevHistoryLst
    463 465 
                     handleRunStatus step expr bindings final_ids status =<< hist'
    464 466
    465 
    -setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m ()   -- #19157
    466 
    -setupBreakpoint interp bi cnt = do
    467 
    +setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m ()   -- #19157
    468 
    +setupBreakpoint interp ibi cnt = do
    467 469 
       hug <- hsc_HUG <$> getSession
    468 
    -  modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
    469 
    -  breakArray <- liftIO $ getBreakArray interp bi modBreaks
    470 
    -  liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
    470 
    +  liftIO $ do
    471 
    +    modBreaks <- readIModBreaks hug ibi
    472 
    +    breakArray <- getBreakArray interp ibi modBreaks
    473 
    +    GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt
    471 474
    472 
    -getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
    473 
    -getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
    475 
    +getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
    476 
    +getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do
    474 477 
       breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
    475 
    -  case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of
    478 
    +  case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of
    476 479 
         Just ba -> return ba
    477 480 
         Nothing -> do
    478 481 
           modifyLoaderState interp $ \ld_st -> do
    ... ... @@ -483,13 +486,12 @@ getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
    483 486 
             ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
    484 487
    485 488 
             let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
    486 
    -        let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod
    489 
    +        let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod
    487 490
    488 491 
             return
    489 492 
               ( ld_st'
    490 493 
               , ba
    491 494 
               )
    492 
    -
    493 495 
     back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
    494 496 
     back n = moveHist (+n)
    495 497
    ... ... @@ -517,8 +519,9 @@ moveHist fn = do
    517 519 
                 span <- case mb_info of
    518 520 
                           Nothing  -> return $ mkGeneralSrcSpan (fsLit "<unknown>")
    519 521 
                           Just ibi -> liftIO $ do
    520 
    -                        brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi)
    521 
    -                        return $ getBreakLoc ibi brks
    522 
    +                        let hug = hsc_HUG hsc_env
    523 
    +                        brks <- readIModBreaks hug ibi
    524 
    +                        getBreakLoc (readIModModBreaks hug) ibi brks
    522 525 
                 (hsc_env1, names) <-
    523 526 
                   liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info
    524 527 
                 let ic = hsc_IC hsc_env1
    ... ... @@ -579,11 +582,10 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
    579 582 
     -- of the breakpoint and the free variables of the expression.
    580 583 
     bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
    581 584 
        let hug = hsc_HUG hsc_env
    582 
    -   info_brks <- readModBreaks hug (ibi_info_mod ibi)
    583 
    -   tick_brks <- readModBreaks hug (ibi_tick_mod ibi)
    584 
    -   let info   = getInternalBreak ibi (info_brks)
    585 
    +   info_brks <- readIModBreaks hug ibi
    586 
    +   let info   = getInternalBreak ibi info_brks
    585 587 
            interp = hscInterp hsc_env
    586 
    -       occs   = getBreakVars ibi tick_brks
    588 
    +   occs <- getBreakVars (readIModModBreaks hug) ibi info_brks
    587 589
    588 590 
       -- Rehydrate to understand the breakpoint info relative to the current environment.
    589 591 
       -- This design is critical to preventing leaks (#22530)

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -27,7 +27,9 @@ module GHC.Runtime.Interpreter
    27 27 
       , getClosure
    28 28 
       , whereFrom
    29 29 
       , getModBreaks
    30 
    -  , readModBreaks
    30 
    +  , readIModBreaks
    31 
    +  , readIModBreaksMaybe
    32 
    +  , readIModModBreaks
    31 33 
       , seqHValue
    32 34 
       , evalBreakpointToId
    33 35
    ... ... @@ -92,7 +94,6 @@ import GHC.Utils.Fingerprint
    92 94
    93 95 
     import GHC.Unit.Module
    94 96 
     import GHC.Unit.Home.ModInfo
    95 
    -import GHC.Unit.Home.Graph (lookupHugByModule)
    96 97 
     import GHC.Unit.Env
    97 98
    98 99 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    ... ... @@ -411,15 +412,10 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
    411 412 
     evalBreakpointToId eval_break =
    412 413 
       let
    413 414 
         mkUnitId u = fsToUnit $ mkFastStringShortByteString u
    414 
    -
    415 415 
         toModule u n = mkModule (mkUnitId u) (mkModuleName n)
    416 
    -    tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
    417 
    -    infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
    418 416 
       in
    419 417 
         InternalBreakpointId
    420 
    -      { ibi_tick_mod   = tickl
    421 
    -      , ibi_tick_index = eb_tick_index eval_break
    422 
    -      , ibi_info_mod   = infol
    418 
    +      { ibi_info_mod   = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
    423 419 
           , ibi_info_index = eb_info_index eval_break
    424 420 
           }
    425 421
    ... ... @@ -440,17 +436,18 @@ handleSeqHValueStatus interp unit_env eval_status =
    440 436 
               -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
    441 437
    442 438 
             Just break -> do
    443 
    -          let bi = evalBreakpointToId break
    439 
    +          let ibi = evalBreakpointToId break
    440 
    +              hug = ue_home_unit_graph unit_env
    444 441
    445 442 
               -- Just case: Stopped at a breakpoint, extract SrcSpan information
    446 443 
               -- from the breakpoint.
    447 
    -          mb_modbreaks <- getModBreaks . expectJust <$>
    448 
    -                          lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
    444 
    +          mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi)
    449 445 
               case mb_modbreaks of
    450 446 
                 -- Nothing case - should not occur! We should have the appropriate
    451 447 
                 -- breakpoint information
    452 448 
                 Nothing -> nothing_case
    453 
    -            Just modbreaks -> put $ brackets . ppr $ getBreakLoc bi modbreaks
    449 
    +            Just modbreaks -> put . brackets . ppr =<<
    450 
    +              getBreakLoc (readIModModBreaks hug) ibi modbreaks
    454 451
    455 452 
           -- resume the seq (:force) processing in the iserv process
    456 453 
           withForeignRef resume_ctxt_fhv $ \hval -> do
    ... ... @@ -745,10 +742,18 @@ getModBreaks hmi
    745 742 
       | otherwise
    746 743 
       = Nothing -- probably object code
    747 744
    748 
    --- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module'
    749 
    --- from the 'HomeUnitGraph'.
    750 
    -readModBreaks :: HomeUnitGraph -> Module -> IO InternalModBreaks
    751 
    -readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug
    745 
    +-- | Read the 'InternalModBreaks' of the given home 'Module' (via
    746 
    +-- 'InternalBreakpointId') from the 'HomeUnitGraph'.
    747 
    +readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks
    748 
    +readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi)
    749 
    +
    750 
    +-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
    751 
    +readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks)
    752 
    +readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug
    753 
    +
    754 
    +-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks'
    755 
    +readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks
    756 
    +readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod
    752 757
    753 758 
     -- -----------------------------------------------------------------------------
    754 759 
     -- Misc utils

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -31,7 +31,6 @@ import GHC.Cmm.Utils
    31 31 
     import GHC.Platform
    32 32 
     import GHC.Platform.Profile
    33 33
    34 
    -import GHC.Runtime.Interpreter
    35 34 
     import GHCi.FFI
    36 35 
     import GHC.Types.Basic
    37 36 
     import GHC.Utils.Outputable
    ... ... @@ -64,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
    64 63 
                                   assertNonVoidIds, assertNonVoidStgArgs )
    65 64 
     import GHC.StgToCmm.Layout
    66 65 
     import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
    66 
    +import GHC.Runtime.Interpreter ( interpreterProfiled )
    67 67 
     import GHC.Data.Bitmap
    68 68 
     import GHC.Data.FlatBag as FlatBag
    69 69 
     import GHC.Data.OrdList
    ... ... @@ -79,7 +79,6 @@ import Control.Monad
    79 79 
     import Data.Char
    80 80
    81 81 
     import GHC.Unit.Module
    82 
    -import qualified GHC.Unit.Home.Graph as HUG
    83 82
    84 83 
     import Data.Coerce (coerce)
    85 84 
     #if MIN_VERSION_rts(1,0,3)
    ... ... @@ -394,65 +393,28 @@ schemeR_wrk fvs nm original_body (args, body)
    394 393 
     -- | Introduce break instructions for ticked expressions.
    395 394 
     -- If no breakpoint information is available, the instruction is omitted.
    396 395 
     schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
    397 
    -schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do
    396 
    +schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
    398 397 
       code <- schemeE d 0 p rhs
    399 
    -  hsc_env <- getHscEnv
    400 
    -  current_mod <- getCurrentModule
    401 398 
       mb_current_mod_breaks <- getCurrentModBreaks
    402 399 
       case mb_current_mod_breaks of
    403 400 
         -- if we're not generating ModBreaks for this module for some reason, we
    404 401 
         -- can't store breakpoint occurrence information.
    405 402 
         Nothing -> pure code
    406 
    -    Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
    407 
    -      Nothing -> pure code
    408 
    -      Just ModBreaks{modBreaks_module = tick_mod} -> do
    409 
    -        platform <- profilePlatform <$> getProfile
    410 
    -        let idOffSets = getVarOffSets platform d p fvs
    411 
    -            ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
    412 
    -            toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
    413 
    -            toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
    414 
    -            breakInfo  = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
    403 
    +    Just current_mod_breaks -> do
    404 
    +      platform <- profilePlatform <$> getProfile
    405 
    +      let idOffSets = getVarOffSets platform d p fvs
    406 
    +          ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
    407 
    +          toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
    408 
    +          toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
    409 
    +          breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
    415 410
    416 
    -        let info_mod = modBreaks_module current_mod_breaks
    417 
    -        infox <- newBreakInfo breakInfo
    411 
    +      let info_mod = modBreaks_module current_mod_breaks
    412 
    +      infox <- newBreakInfo breakInfo
    418 413
    419 
    -        let breakInstr = BRK_FUN (InternalBreakpointId tick_mod tick_no info_mod infox)
    420 
    -        return $ breakInstr `consOL` code
    414 
    +      let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
    415 
    +      return $ breakInstr `consOL` code
    421 416 
     schemeER_wrk d p rhs = schemeE d 0 p rhs
    422 417
    423 
    --- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
    424 
    --- from which the breakpoint originates.
    425 
    --- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs
    426 
    --- to refer to pointers in GHCi's address space.
    427 
    --- They are initialized in 'GHC.HsToCore.Breakpoints.mkModBreaks', called by
    428 
    --- 'GHC.HsToCore.deSugar'.
    429 
    ---
    430 
    --- Breakpoints might be disabled because we're in TH, because
    431 
    --- @-fno-break-points@ was specified, or because a module was reloaded without
    432 
    --- reinitializing 'ModBreaks'.
    433 
    ---
    434 
    --- If the module stored in the breakpoint is the currently processed module, use
    435 
    --- the 'ModBreaks' from the state.
    436 
    --- If that is 'Nothing', consider breakpoints to be disabled and skip the
    437 
    --- instruction.
    438 
    ---
    439 
    --- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph).
    440 
    --- If the module doesn't exist there, or if the 'ModBreaks' value is
    441 
    --- uninitialized, skip the instruction (i.e. return Nothing).
    442 
    -break_info ::
    443 
    -  HscEnv ->
    444 
    -  Module ->
    445 
    -  Module ->
    446 
    -  Maybe ModBreaks ->
    447 
    -  BcM (Maybe ModBreaks)
    448 
    -break_info hsc_env mod current_mod current_mod_breaks
    449 
    -  | mod == current_mod
    450 
    -  = pure current_mod_breaks
    451 
    -  | otherwise
    452 
    -  = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
    453 
    -      Just hp -> pure $ imodBreaks_modBreaks <$> getModBreaks hp
    454 
    -      Nothing -> pure Nothing
    455 
    -
    456 418 
     getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
    457 419 
     getVarOffSets platform depth env = map getOffSet
    458 420 
       where

  • ghc/GHCi/UI.hs
    ... ... @@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
    45 45 
     import GHC.Runtime.Eval.Utils
    46 46
    47 47 
     -- The GHC interface
    48 
    -import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks)
    48 
    +import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
    49 49 
     import GHC.Runtime.Interpreter
    50 50 
     import GHCi.RemoteTypes
    51 51 
     import GHCi.BreakArray( breakOn, breakOff )
    ... ... @@ -68,7 +68,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
    68 68 
                  Resume, SingleStep, Ghc,
    69 69 
                  GetDocsFailure(..), pushLogHookM,
    70 70 
                  getModuleGraph, handleSourceError,
    71 
    -             InternalBreakpointId(..) )
    71 
    +             BreakpointId(..) )
    72 72 
     import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
    73 73 
     import GHC.Hs.ImpExp
    74 74 
     import GHC.Hs
    ... ... @@ -546,6 +546,7 @@ interactiveUI config srcs maybe_exprs = do
    546 546 
                        break_ctr          = 0,
    547 547 
                        breaks             = IntMap.empty,
    548 548 
                        tickarrays         = emptyModuleEnv,
    549 
    +                   internalBreaks     = emptyModuleEnv,
    549 550 
                        ghci_commands      = availableCommands config,
    550 551 
                        ghci_macros        = [],
    551 552 
                        last_command       = Nothing,
    ... ... @@ -1616,13 +1617,15 @@ toBreakIdAndLocation :: GhciMonad m
    1616 1617 
     toBreakIdAndLocation Nothing = return Nothing
    1617 1618 
     toBreakIdAndLocation (Just inf) = do
    1618 1619 
       st <- getGHCiState
    1620 
    +  hug <- hsc_HUG <$> GHC.getSession
    1621 
    +  brks <- liftIO $ readIModBreaks hug inf
    1622 
    +  let bi = getBreakSourceId inf brks
    1619 1623 
       return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
    1620 
    -                                  breakModule loc == ibi_tick_mod inf,
    1621 
    -                                  breakTick loc == ibi_tick_index inf ]
    1624 
    +                                  breakId loc == bi ]
    1622 1625
    1623 1626 
     printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
    1624 1627 
     printStoppedAtBreakInfo res names = do
    1625 
    -  printForUser $ pprStopped res
    1628 
    +  printForUser =<< pprStopped res
    1626 1629 
       --  printTypeOfNames session names
    1627 1630 
       let namesSorted = sortBy compareNames names
    1628 1631 
       tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
    ... ... @@ -3804,22 +3807,32 @@ showBkptTable = do
    3804 3807 
     showContext :: GHC.GhcMonad m => m ()
    3805 3808 
     showContext = do
    3806 3809 
        resumes <- GHC.getResumeContext
    3807 
    -   printForUser $ vcat (map pp_resume (reverse resumes))
    3810 
    +   docs <- mapM pp_resume (reverse resumes)
    3811 
    +   printForUser $ vcat docs
    3808 3812 
       where
    3809 
    -   pp_resume res =
    3810 
    -        text "--> " <> text (GHC.resumeStmt res)
    3811 
    -        $$ nest 2 (pprStopped res)
    3812 
    -
    3813 
    -pprStopped :: GHC.Resume -> SDoc
    3814 
    -pprStopped res =
    3815 
    -  text "Stopped in"
    3816 
    -    <+> ((case mb_mod_name of
    3817 
    -           Nothing -> empty
    3818 
    -           Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')
    3819 
    -         <> text (GHC.resumeDecl res))
    3820 
    -    <> char ',' <+> ppr (GHC.resumeSpan res)
    3821 
    - where
    3822 
    -  mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res
    3813 
    +   pp_resume res = do
    3814 
    +    stopped <- pprStopped res
    3815 
    +    return $
    3816 
    +      text "--> " <> text (GHC.resumeStmt res)
    3817 
    +      $$ nest 2 stopped
    3818 
    +
    3819 
    +pprStopped :: GHC.GhcMonad m => GHC.Resume -> m SDoc
    3820 
    +pprStopped res = do
    3821 
    +  let mibi = GHC.resumeBreakpointId res
    3822 
    +  mb_mod_name <- case mibi of
    3823 
    +    Nothing -> pure Nothing
    3824 
    +    Just ibi -> do
    3825 
    +      hug <- hsc_HUG <$> GHC.getSession
    3826 
    +      brks <- liftIO $ readIModBreaks hug ibi
    3827 
    +      return $ Just $ moduleName $
    3828 
    +        bi_tick_mod $ getBreakSourceId ibi brks
    3829 
    +  return $
    3830 
    +    text "Stopped in"
    3831 
    +      <+> ((case mb_mod_name of
    3832 
    +             Nothing -> empty
    3833 
    +             Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')
    3834 
    +           <> text (GHC.resumeDecl res))
    3835 
    +      <> char ',' <+> ppr (GHC.resumeSpan res)
    3823 3836
    3824 3837 
     showUnits :: GHC.GhcMonad m => m ()
    3825 3838 
     showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do
    ... ... @@ -4373,12 +4386,8 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do
    4373 4386 
         result <- ignoreSwitch (words argLine)
    4374 4387 
         case result of
    4375 4388 
           Left sdoc -> printForUser sdoc
    4376 
    -      Right (loc, count)   -> do
    4377 
    -        let bi = GHC.BreakpointId
    4378 
    -                  { bi_tick_mod   = breakModule loc
    4379 
    -                  , bi_tick_index = breakTick loc
    4380 
    -                  }
    4381 
    -        setupBreakpoint bi count
    4389 
    +      Right (loc, count) -> do
    4390 
    +        setupBreakpoint (breakId loc) count
    4382 4391
    4383 4392 
     ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
    4384 4393 
     ignoreSwitch [break, count] = do
    ... ... @@ -4395,10 +4404,13 @@ getIgnoreCount str =
    4395 4404 
         where
    4396 4405 
           sdocIgnore = text "Ignore count" <+> quotes (text str)
    4397 4406
    4398 
    -setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m()
    4399 
    -setupBreakpoint loc count = do
    4407 
    +setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m ()
    4408 
    +setupBreakpoint bi count = do
    4400 4409 
         hsc_env <- GHC.getSession
    4401 
    -    GHC.setupBreakpoint (hscInterp hsc_env) loc count
    4410 
    +    -- Trigger all internal breaks that match this source break id
    4411 
    +    internal_break_ids <- getInternalBreaksOf bi
    4412 
    +    forM_ internal_break_ids $ \ibi -> do
    4413 
    +      GHC.setupBreakpoint (hscInterp hsc_env) ibi count
    4402 4414
    4403 4415 
     backCmd :: GhciMonad m => String -> m ()
    4404 4416 
     backCmd arg
    ... ... @@ -4489,20 +4501,20 @@ findBreakAndSet md lookupTickTree = do
    4489 4501 
           some -> mapM_ breakAt some
    4490 4502 
      where
    4491 4503 
        breakAt (tick, pan) = do
    4492 
    -         setBreakFlag md tick True
    4493 
    -         (alreadySet, nm) <-
    4494 
    -               recordBreak $ BreakLocation
    4495 
    -                       { breakModule = md
    4496 
    -                       , breakLoc = RealSrcSpan pan Strict.Nothing
    4497 
    -                       , breakTick = tick
    4498 
    -                       , onBreakCmd = ""
    4499 
    -                       , breakEnabled = True
    4500 
    -                       }
    4501 
    -         printForUser $
    4502 
    -            text "Breakpoint " <> ppr nm <>
    4503 
    -            if alreadySet
    4504 
    -               then text " was already set at " <> ppr pan
    4505 
    -               else text " activated at " <> ppr pan
    4504 
    +      let bi = BreakpointId md tick
    4505 
    +      setBreakFlag bi True
    4506 
    +      (alreadySet, nm) <-
    4507 
    +            recordBreak $ BreakLocation
    4508 
    +                    { breakLoc = RealSrcSpan pan Strict.Nothing
    4509 
    +                    , breakId = bi
    4510 
    +                    , onBreakCmd = ""
    4511 
    +                    , breakEnabled = True
    4512 
    +                    }
    4513 
    +      printForUser $
    4514 
    +         text "Breakpoint " <> ppr nm <>
    4515 
    +         if alreadySet
    4516 
    +            then text " was already set at " <> ppr pan
    4517 
    +            else text " activated at " <> ppr pan
    4506 4518
    4507 4519 
     -- For now, use ANSI bold on terminals that we know support it.
    4508 4520 
     -- Otherwise, we add a line of carets under the active expression instead.
    ... ... @@ -4749,14 +4761,32 @@ turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation
    4749 4761 
     turnBreakOnOff onOff loc
    4750 4762 
       | onOff == breakEnabled loc = return loc
    4751 4763 
       | otherwise = do
    4752 
    -      setBreakFlag (breakModule loc) (breakTick loc)  onOff
    4764 
    +      setBreakFlag (breakId loc) onOff
    4753 4765 
           return loc { breakEnabled = onOff }
    4754 4766
    4755 
    -setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()
    4756 
    -setBreakFlag  md ix enaDisa = do
    4767 
    +setBreakFlag :: GhciMonad m => GHC.BreakpointId -> Bool -> m ()
    4768 
    +setBreakFlag (BreakpointId md ix) enaDisa = do
    4757 4769 
       let enaDisaToCount True = breakOn
    4758 4770 
           enaDisaToCount False = breakOff
    4759 
    -  setupBreakpoint (GHC.BreakpointId md ix) $ enaDisaToCount enaDisa
    4771 
    +  setupBreakpoint (BreakpointId md ix) $ enaDisaToCount enaDisa
    4772 
    +
    4773 
    +-- --------------------------------------------------------------------------
    4774 
    +-- Find matching Internal Breakpoints
    4775 
    +
    4776 
    +-- | Find all the internal breakpoints that use the given source-level breakpoint id
    4777 
    +getInternalBreaksOf :: GhciMonad m => BreakpointId -> m [InternalBreakpointId]
    4778 
    +getInternalBreaksOf bi = do
    4779 
    +    st <- getGHCiState
    4780 
    +    let ibrks = internalBreaks st
    4781 
    +    case lookupBreakpointOccurrences ibrks bi of
    4782 
    +      Just bs -> return bs
    4783 
    +      Nothing -> do
    4784 
    +        -- Refresh the internal breakpoints map
    4785 
    +        bs <- mkBreakpointOccurrences
    4786 
    +        setGHCiState st{internalBreaks = bs}
    4787 
    +        return $
    4788 
    +          fromMaybe [] {- still not found after refresh -} $
    4789 
    +            lookupBreakpointOccurrences bs bi
    4760 4790
    4761 4791 
     -- ---------------------------------------------------------------------------
    4762 4792 
     -- User code exception handling

  • ghc/GHCi/UI/Monad.hs
    ... ... @@ -100,6 +100,14 @@ data GHCiState = GHCiState
    100 100 
                 -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
    101 101 
                 -- so that we don't rebuild it each time the user sets
    102 102 
                 -- a breakpoint.
    103 
    +
    104 
    +        internalBreaks :: BreakpointOccurrences,
    105 
    +            -- ^ Keep a mapping from the source-level 'BreakpointId' to the
    106 
    +            -- occurrences of that breakpoint across modules.
    107 
    +            -- When we want to stop at a source 'BreakpointId', we essentially
    108 
    +            -- trigger a breakpoint for all 'InternalBreakpointId's matching
    109 
    +            -- the same source-id.
    110 
    +
    103 111 
             ghci_commands  :: [Command],
    104 112 
                 -- ^ available ghci commands
    105 113 
             ghci_macros    :: [Command],
    ... ... @@ -238,16 +246,15 @@ data LocalConfigBehaviour
    238 246
    239 247 
     data BreakLocation
    240 248 
        = BreakLocation
    241 
    -   { breakModule :: !GHC.Module
    242 
    -   , breakLoc    :: !SrcSpan
    243 
    -   , breakTick   :: {-# UNPACK #-} !Int
    249 
    +   { breakLoc    :: !SrcSpan
    250 
    +   , breakId     :: !GHC.BreakpointId
    251 
    +     -- ^ The 'BreakpointId' uniquely identifies a source-level breakpoint
    244 252 
        , breakEnabled:: !Bool
    245 253 
        , onBreakCmd  :: String
    246 254 
        }
    247 255
    248 256 
     instance Eq BreakLocation where
    249 
    -  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
    250 
    -                 breakTick loc1   == breakTick loc2
    257 
    +  loc1 == loc2 = breakId loc1 == breakId loc2
    251 258
    252 259 
     prettyLocations :: IntMap.IntMap BreakLocation -> SDoc
    253 260 
     prettyLocations  locs =
    ... ... @@ -256,7 +263,7 @@ prettyLocations locs =
    256 263 
           False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs
    257 264
    258 265 
     instance Outputable BreakLocation where
    259 
    -   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>
    266 
    +   ppr loc = (ppr $ GHC.bi_tick_mod $ breakId loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>
    260 267 
                     if null (onBreakCmd loc)
    261 268 
                        then empty
    262 269 
                        else doubleQuotes (text (onBreakCmd loc))

  • libraries/ghci/GHCi/Debugger.hs
    ... ... @@ -65,10 +65,7 @@ foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
    65 65 
     --------------------------------------------------------------------------------
    66 66
    67 67 
     type BreakpointCallback
    68 
    -     = Addr#   -- pointer to the breakpoint tick module name
    69 
    -    -> Addr#   -- pointer to the breakpoint tick module unit id
    70 
    -    -> Int#    -- breakpoint tick index
    71 
    -    -> Addr#   -- pointer to the breakpoint info module name
    68 
    +     = Addr#   -- pointer to the breakpoint info module name
    72 69 
         -> Addr#   -- pointer to the breakpoint info module unit id
    73 70 
         -> Int#    -- breakpoint info index
    74 71 
         -> Bool    -- exception?

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -418,10 +418,7 @@ data EvalStatus_ a b
    418 418 
     instance Binary a => Binary (EvalStatus_ a b)
    419 419
    420 420 
     data EvalBreakpoint = EvalBreakpoint
    421 
    -  { eb_tick_mod      :: String -- ^ Breakpoint tick module
    422 
    -  , eb_tick_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
    423 
    -  , eb_tick_index    :: Int    -- ^ Breakpoint tick index
    424 
    -  , eb_info_mod      :: String -- ^ Breakpoint info module
    421 
    +  { eb_info_mod      :: String -- ^ Breakpoint info module
    425 422 
       , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
    426 423 
       , eb_info_index    :: Int    -- ^ Breakpoint info index
    427 424 
       }

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -345,7 +345,7 @@ withBreakAction opts breakMVar statusMVar mtid act
    345 345 
             -- as soon as it is hit, or in resetBreakAction below.
    346 346
    347 347 
        onBreak :: BreakpointCallback
    348 
    -   onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
    348 
    +   onBreak info_mod# info_mod_uid# infox# is_exception apStack = do
    349 349 
          tid <- myThreadId
    350 350 
          let resume = ResumeContext
    351 351 
                { resumeBreakMVar = breakMVar
    ... ... @@ -358,11 +358,9 @@ withBreakAction opts breakMVar statusMVar mtid act
    358 358 
            if is_exception
    359 359 
            then pure Nothing
    360 360 
            else do
    361 
    -         tick_mod <- peekCString (Ptr tick_mod#)
    362 
    -         tick_mod_uid <- BS.packCString (Ptr tick_mod_uid#)
    363 361 
              info_mod <- peekCString (Ptr info_mod#)
    364 362 
              info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
    365 
    -         pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
    363 
    +         pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
    366 364 
          putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
    367 365 
          takeMVar breakMVar
    368 366
    ... ... @@ -409,8 +407,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
    409 407 
     noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
    410 408
    411 409 
     noBreakAction :: BreakpointCallback
    412 
    -noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
    413 
    -noBreakAction _ _ _ _ _ _ True  _ = return () -- exception: just continue
    410 
    +noBreakAction _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
    411 
    +noBreakAction _ _ _ True  _ = return () -- exception: just continue
    414 412
    415 413 
     -- Malloc and copy the bytes.  We don't have any way to monitor the
    416 414 
     -- lifetime of this memory, so it just leaks.

  • rts/Disassembler.c
    ... ... @@ -84,16 +84,23 @@ disInstr ( StgBCO *bco, int pc )
    84 84
    85 85
    86 86 
        switch (instr & 0xff) {
    87 
    -      case bci_BRK_FUN:
    88 
    -         debugBelch ("BRK_FUN  " );  printPtr( ptrs[instrs[pc]] );
    89 
    -         debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] );
    90 
    -         CostCentre* cc = (CostCentre*)literals[instrs[pc+5]];
    87 
    +      case bci_BRK_FUN: {
    88 
    +         W_ p1, info_mod, info_unit_id, info_wix, np;
    89 
    +         p1           = BCO_GET_LARGE_ARG;
    90 
    +         info_mod     = BCO_GET_LARGE_ARG;
    91 
    +         info_unit_id = BCO_GET_LARGE_ARG;
    92 
    +         info_wix     = BCO_NEXT;
    93 
    +         np           = BCO_GET_LARGE_ARG;
    94 
    +         debugBelch ("BRK_FUN " );  printPtr( ptrs[p1] );
    95 
    +         debugBelch("%" FMT_Word, literals[info_mod] );
    96 
    +         debugBelch("%" FMT_Word, literals[info_unit_id] );
    97 
    +         debugBelch("%" FMT_Word, info_wix );
    98 
    +         CostCentre* cc = (CostCentre*)literals[np];
    91 99 
              if (cc) {
    92 100 
                debugBelch(" %s", cc->label);
    93 101 
              }
    94 102 
              debugBelch("\n");
    95 
    -         pc += 6;
    96 
    -         break;
    103 
    +         break; }
    97 104 
           case bci_BRK_ALTS:
    98 105 
              debugBelch ("BRK_ALTS %d\n", BCO_NEXT);
    99 106 
              break;

  • rts/Exception.cmm
    ... ... @@ -535,23 +535,17 @@ retry_pop_stack:
    535 535 
                 // be per-thread.
    536 536 
                 CInt[rts_stop_on_exception] = 0;
    537 537 
                 ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
    538 
    -            Sp = Sp - WDS(17);
    539 
    -            Sp(16) = exception;
    540 
    -            Sp(15) = stg_raise_ret_info;
    541 
    -            Sp(14) = exception;
    542 
    -            Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
    543 
    -            Sp(12) = stg_ap_ppv_info;
    544 
    -            Sp(11) = 0;
    545 
    -            Sp(10) = stg_ap_n_info;
    546 
    -            Sp(9)  = 0;
    547 
    -            Sp(8)  = stg_ap_n_info;
    548 
    -            Sp(7)  = 0;
    549 
    -            Sp(6)  = stg_ap_n_info;
    550 
    -            Sp(5)  = 0;
    551 
    -            Sp(4)  = stg_ap_n_info;
    552 
    -            Sp(3)  = 0;
    553 
    -            Sp(2)  = stg_ap_n_info;
    554 
    -            Sp(1)  = 0;
    538 
    +            Sp = Sp - WDS(11);
    539 
    +            Sp(10) = exception;
    540 
    +            Sp(9) = stg_raise_ret_info;
    541 
    +            Sp(8) = exception;
    542 
    +            Sp(7) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
    543 
    +            Sp(6) = stg_ap_ppv_info;
    544 
    +            Sp(5) = 0;
    545 
    +            Sp(4) = stg_ap_n_info;
    546 
    +            Sp(3) = 0;
    547 
    +            Sp(2) = stg_ap_n_info;
    548 
    +            Sp(1) = 0;
    555 549 
                 R1 = ioAction;
    556 550 
                 jump RET_LBL(stg_ap_n) [R1];
    557 551 
             }

  • rts/Interpreter.c
    ... ... @@ -685,8 +685,6 @@ interpretBCO (Capability* cap)
    685 685 
          */
    686 686 
         if (cap->r.rCurrentTSO->flags & TSO_STOP_AFTER_RETURN) {
    687 687
    688 
    -      StgBCO* bco;
    689 
    -      StgWord16* bco_instrs;
    690 688 
           StgHalfWord type;
    691 689
    692 690 
           /* Store the entry Sp; traverse the stack modifying Sp (using Sp macros);
    ... ... @@ -706,28 +704,33 @@ interpretBCO (Capability* cap)
    706 704 
           ASSERT(type == RET_BCO || type == STOP_FRAME);
    707 705 
           if (type == RET_BCO) {
    708 706
    709 
    -        bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO
    707 
    +        StgBCO* bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO
    710 708 
             ASSERT(get_itbl((StgClosure*)bco)->type == BCO);
    711 
    -        bco_instrs = (StgWord16*)(bco->instrs->payload);
    709 
    +
    710 
    +        StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
    711 
    +        StgWord16 bci = instrs[0];
    712 712
    713 713 
             /* A breakpoint instruction (BRK_FUN or BRK_ALTS) is always the first
    714 714 
              * instruction in a BCO */
    715 
    -        if ((bco_instrs[0] & 0xFF) == bci_BRK_FUN) {
    716 
    -            int brk_array, tick_index;
    717 
    -            StgArrBytes *breakPoints;
    718 
    -            StgPtr* ptrs;
    715 
    +        if ((bci & 0xFF) == bci_BRK_FUN) {
    716 
    +            // Define rest of variables used by BCO_* Macros
    717 
    +            int bciPtr = 0;
    718 
    +
    719 
    +            W_ arg1_brk_array, arg4_info_index;
    720 
    +            arg1_brk_array      = BCO_GET_LARGE_ARG;
    721 
    +            /* info_mod_name = */ BCO_GET_LARGE_ARG;
    722 
    +            /* info_mod_id   = */ BCO_GET_LARGE_ARG;
    723 
    +            arg4_info_index     = BCO_NEXT;
    719 724
    720 
    -            ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
    721 
    -            brk_array  = bco_instrs[1];
    722 
    -            tick_index = bco_instrs[6];
    725 
    +            StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
    726 
    +            StgArrBytes* breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
    723 727
    724 
    -            breakPoints = (StgArrBytes *) BCO_PTR(brk_array);
    725 728 
                 // ACTIVATE the breakpoint by tick index
    726 
    -            ((StgInt*)breakPoints->payload)[tick_index] = 0;
    729 
    +            ((StgInt*)breakPoints->payload)[arg4_info_index] = 0;
    727 730 
             }
    728 
    -        else if ((bco_instrs[0] & 0xFF) == bci_BRK_ALTS) {
    731 
    +        else if ((bci & 0xFF) == bci_BRK_ALTS) {
    729 732 
                 // ACTIVATE BRK_ALTS by setting its only argument to ON
    730 
    -            bco_instrs[1] = 1;
    733 
    +            instrs[1] = 1;
    731 734 
             }
    732 735 
             // else: if there is no BRK instruction perhaps we should keep
    733 736 
             // traversing; that said, the continuation should always have a BRK
    ... ... @@ -1520,9 +1523,9 @@ run_BCO:
    1520 1523 
             /* check for a breakpoint on the beginning of a let binding */
    1521 1524 
             case bci_BRK_FUN:
    1522 1525 
             {
    1523 
    -            int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
    1526 
    +            W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
    1524 1527 
     #if defined(PROFILING)
    1525 
    -            int arg8_cc;
    1528 
    +            W_ arg5_cc;
    1526 1529 
     #endif
    1527 1530 
                 StgArrBytes *breakPoints;
    1528 1531 
                 int returning_from_break, stop_next_breakpoint;
    ... ... @@ -1537,14 +1540,11 @@ run_BCO:
    1537 1540 
                 int size_words;
    1538 1541
    1539 1542 
                 arg1_brk_array      = BCO_GET_LARGE_ARG;
    1540 
    -            arg2_tick_mod       = BCO_GET_LARGE_ARG;
    1541 
    -            arg3_info_mod       = BCO_GET_LARGE_ARG;
    1542 
    -            arg4_tick_mod_id    = BCO_GET_LARGE_ARG;
    1543 
    -            arg5_info_mod_id    = BCO_GET_LARGE_ARG;
    1544 
    -            arg6_tick_index     = BCO_NEXT;
    1545 
    -            arg7_info_index     = BCO_NEXT;
    1543 
    +            arg2_info_mod_name  = BCO_GET_LARGE_ARG;
    1544 
    +            arg3_info_mod_id    = BCO_GET_LARGE_ARG;
    1545 
    +            arg4_info_index     = BCO_NEXT;
    1546 1546 
     #if defined(PROFILING)
    1547 
    -            arg8_cc             = BCO_GET_LARGE_ARG;
    1547 
    +            arg5_cc             = BCO_GET_LARGE_ARG;
    1548 1548 
     #else
    1549 1549 
                 BCO_GET_LARGE_ARG;
    1550 1550 
     #endif
    ... ... @@ -1564,7 +1564,7 @@ run_BCO:
    1564 1564
    1565 1565 
     #if defined(PROFILING)
    1566 1566 
                 cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
    1567 
    -                                          (CostCentre*)BCO_LIT(arg8_cc));
    1567 
    +                                          (CostCentre*)BCO_LIT(arg5_cc));
    1568 1568 
     #endif
    1569 1569
    1570 1570 
                 // if we are returning from a break then skip this section
    ... ... @@ -1575,11 +1575,11 @@ run_BCO:
    1575 1575
    1576 1576 
                    // stop the current thread if either `stop_next_breakpoint` is
    1577 1577 
                    // true OR if the ignore count for this particular breakpoint is zero
    1578 
    -               StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
    1578 
    +               StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_info_index];
    1579 1579 
                    if (stop_next_breakpoint == false && ignore_count > 0)
    1580 1580 
                    {
    1581 1581 
                       // decrement and write back ignore count
    1582 
    -                  ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
    1582 
    +                  ((StgInt*)breakPoints->payload)[arg4_info_index] = --ignore_count;
    1583 1583 
                    }
    1584 1584 
                    else if (stop_next_breakpoint == true || ignore_count == 0)
    1585 1585 
                    {
    ... ... @@ -1613,10 +1613,7 @@ run_BCO:
    1613 1613 
                       // Arrange the stack to call the breakpoint IO action, and
    1614 1614 
                       // continue execution of this BCO when the IO action returns.
    1615 1615 
                       //
    1616 
    -                  // ioAction :: Addr#       -- the breakpoint tick module
    1617 
    -                  //          -> Addr#       -- the breakpoint tick module unit id
    1618 
    -                  //          -> Int#        -- the breakpoint tick index
    1619 
    -                  //          -> Addr#       -- the breakpoint info module
    1616 
    +                  // ioAction :: Addr#       -- the breakpoint info module
    1620 1617 
                       //          -> Addr#       -- the breakpoint info module unit id
    1621 1618 
                       //          -> Int#        -- the breakpoint info index
    1622 1619 
                       //          -> Bool        -- exception?
    ... ... @@ -1626,23 +1623,17 @@ run_BCO:
    1626 1623 
                       ioAction = (StgClosure *) deRefStablePtr (
    1627 1624 
                           rts_breakpoint_io_action);
    1628 1625
    1629 
    -                  Sp_subW(19);
    1630 
    -                  SpW(18) = (W_)obj;
    1631 
    -                  SpW(17) = (W_)&stg_apply_interp_info;
    1632 
    -                  SpW(16) = (W_)new_aps;
    1633 
    -                  SpW(15) = (W_)False_closure;         // True <=> an exception
    1634 
    -                  SpW(14) = (W_)&stg_ap_ppv_info;
    1635 
    -                  SpW(13)  = (W_)arg7_info_index;
    1636 
    -                  SpW(12)  = (W_)&stg_ap_n_info;
    1637 
    -                  SpW(11)  = (W_)BCO_LIT(arg5_info_mod_id);
    1638 
    -                  SpW(10)  = (W_)&stg_ap_n_info;
    1639 
    -                  SpW(9)  = (W_)BCO_LIT(arg3_info_mod);
    1640 
    -                  SpW(8)  = (W_)&stg_ap_n_info;
    1641 
    -                  SpW(7)  = (W_)arg6_tick_index;
    1626 
    +                  Sp_subW(13);
    1627 
    +                  SpW(12) = (W_)obj;
    1628 
    +                  SpW(11) = (W_)&stg_apply_interp_info;
    1629 
    +                  SpW(10) = (W_)new_aps;
    1630 
    +                  SpW(9) = (W_)False_closure;         // True <=> an exception
    1631 
    +                  SpW(8) = (W_)&stg_ap_ppv_info;
    1632 
    +                  SpW(7)  = (W_)arg4_info_index;
    1642 1633 
                       SpW(6)  = (W_)&stg_ap_n_info;
    1643 
    -                  SpW(5)  = (W_)BCO_LIT(arg4_tick_mod_id);
    1634 
    +                  SpW(5)  = (W_)BCO_LIT(arg3_info_mod_id);
    1644 1635 
                       SpW(4)  = (W_)&stg_ap_n_info;
    1645 
    -                  SpW(3)  = (W_)BCO_LIT(arg2_tick_mod);
    1636 
    +                  SpW(3)  = (W_)BCO_LIT(arg2_info_mod_name);
    1646 1637 
                       SpW(2)  = (W_)&stg_ap_n_info;
    1647 1638 
                       SpW(1)  = (W_)ioAction;
    1648 1639 
                       SpW(0)  = (W_)&stg_enter_info;

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help