Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
-
31e01836
by fendor at 2025-04-17T14:22:27+02:00
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
| ... | ... | @@ -732,13 +732,16 @@ assembleI platform i = case i of |
| 732 | 732 | CCALL off m_addr i -> do np <- addr m_addr
|
| 733 | 733 | emit_ bci_CCALL [wOp off, Op np, SmallOp i]
|
| 734 | 734 | PRIMCALL -> emit_ bci_PRIMCALL []
|
| 735 | - BRK_FUN arr tick_mod tickx info_mod infox cc ->
|
|
| 735 | + BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
|
|
| 736 | 736 | do p1 <- ptr (BCOPtrBreakArray arr)
|
| 737 | 737 | tick_addr <- addr tick_mod
|
| 738 | + tick_unitid_addr <- addr tick_mod_id
|
|
| 738 | 739 | info_addr <- addr info_mod
|
| 740 | + info_unitid_addr <- addr info_mod_id
|
|
| 739 | 741 | np <- addr cc
|
| 740 | 742 | emit_ bci_BRK_FUN [ Op p1
|
| 741 | 743 | , Op tick_addr, Op info_addr
|
| 744 | + , Op tick_unitid_addr, Op info_unitid_addr
|
|
| 742 | 745 | , SmallOp tickx, SmallOp infox
|
| 743 | 746 | , Op np
|
| 744 | 747 | ]
|
| ... | ... | @@ -37,6 +37,7 @@ import GHC.Stg.Syntax |
| 37 | 37 | import GHCi.BreakArray (BreakArray)
|
| 38 | 38 | import Language.Haskell.Syntax.Module.Name (ModuleName)
|
| 39 | 39 | import GHC.Types.Unique
|
| 40 | +import GHC.Unit.Types (UnitId)
|
|
| 40 | 41 | |
| 41 | 42 | -- ----------------------------------------------------------------------------
|
| 42 | 43 | -- Bytecode instructions
|
| ... | ... | @@ -233,8 +234,10 @@ data BCInstr |
| 233 | 234 | -- Breakpoints
|
| 234 | 235 | | BRK_FUN (ForeignRef BreakArray)
|
| 235 | 236 | (RemotePtr ModuleName) -- breakpoint tick module
|
| 237 | + (RemotePtr UnitId) -- breakpoint tick module unit id
|
|
| 236 | 238 | !Word16 -- breakpoint tick index
|
| 237 | 239 | (RemotePtr ModuleName) -- breakpoint info module
|
| 240 | + (RemotePtr UnitId) -- breakpoint info module unit id
|
|
| 238 | 241 | !Word16 -- breakpoint info index
|
| 239 | 242 | (RemotePtr CostCentre)
|
| 240 | 243 | |
| ... | ... | @@ -403,10 +406,10 @@ instance Outputable BCInstr where |
| 403 | 406 | ppr ENTER = text "ENTER"
|
| 404 | 407 | ppr (RETURN pk) = text "RETURN " <+> ppr pk
|
| 405 | 408 | ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
|
| 406 | - ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
|
|
| 409 | + ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
|
|
| 407 | 410 | = text "BRK_FUN" <+> text "<breakarray>"
|
| 408 | - <+> text "<tick_module>" <+> ppr tickx
|
|
| 409 | - <+> text "<info_module>" <+> ppr infox
|
|
| 411 | + <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
|
|
| 412 | + <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
|
|
| 410 | 413 | <+> text "<cc>"
|
| 411 | 414 | #if MIN_VERSION_rts(1,0,3)
|
| 412 | 415 | ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
|
| ... | ... | @@ -50,6 +50,7 @@ import GHC.Stack.CCS |
| 50 | 50 | import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
|
| 51 | 51 | import GHC.Iface.Syntax
|
| 52 | 52 | import Language.Haskell.Syntax.Module.Name (ModuleName)
|
| 53 | +import GHC.Unit.Types (UnitId)
|
|
| 53 | 54 | |
| 54 | 55 | -- -----------------------------------------------------------------------------
|
| 55 | 56 | -- Compiled Byte Code
|
| ... | ... | @@ -263,6 +264,9 @@ data ModBreaks |
| 263 | 264 | , modBreaks_breakInfo :: IntMap CgBreakInfo
|
| 264 | 265 | -- ^ info about each breakpoint from the bytecode generator
|
| 265 | 266 | , modBreaks_module :: RemotePtr ModuleName
|
| 267 | + -- ^ info about the module in which we are setting the breakpoint
|
|
| 268 | + , modBreaks_module_unitid :: RemotePtr UnitId
|
|
| 269 | + -- ^ The 'UnitId' of the 'ModuleName'
|
|
| 266 | 270 | }
|
| 267 | 271 | |
| 268 | 272 | seqModBreaks :: ModBreaks -> ()
|
| ... | ... | @@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} = |
| 273 | 277 | rnf modBreaks_decls `seq`
|
| 274 | 278 | rnf modBreaks_ccs `seq`
|
| 275 | 279 | rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
|
| 276 | - rnf modBreaks_module
|
|
| 280 | + rnf modBreaks_module `seq`
|
|
| 281 | + rnf modBreaks_module_unitid
|
|
| 277 | 282 | |
| 278 | 283 | -- | Construct an empty ModBreaks
|
| 279 | 284 | emptyModBreaks :: ModBreaks
|
| ... | ... | @@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks |
| 286 | 291 | , modBreaks_ccs = array (0,-1) []
|
| 287 | 292 | , modBreaks_breakInfo = IntMap.empty
|
| 288 | 293 | , modBreaks_module = toRemotePtr nullPtr
|
| 294 | + , modBreaks_module_unitid = toRemotePtr nullPtr
|
|
| 289 | 295 | }
|
| 290 | 296 | |
| 291 | 297 | {-
|
| ... | ... | @@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries |
| 34 | 34 | |
| 35 | 35 | breakArray <- GHCi.newBreakArray interp count
|
| 36 | 36 | ccs <- mkCCSArray interp mod count entries
|
| 37 | - mod_ptr <- GHCi.newModuleName interp (moduleName mod)
|
|
| 37 | + (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
|
|
| 38 | 38 | let
|
| 39 | 39 | locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
|
| 40 | 40 | varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
|
| ... | ... | @@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries |
| 46 | 46 | , modBreaks_decls = declsTicks
|
| 47 | 47 | , modBreaks_ccs = ccs
|
| 48 | 48 | , modBreaks_module = mod_ptr
|
| 49 | + , modBreaks_module_unitid = mod_id_ptr
|
|
| 49 | 50 | }
|
| 50 | 51 | |
| 51 | 52 | mkCCSArray
|
| ... | ... | @@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do |
| 345 | 345 | |
| 346 | 346 | -- Just case: we stopped at a breakpoint
|
| 347 | 347 | EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
|
| 348 | - ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
|
|
| 348 | + let ibi = evalBreakpointToId eval_break
|
|
| 349 | 349 | tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
|
| 350 | 350 | let
|
| 351 | 351 | span = modBreaks_locs tick_brks ! ibi_tick_index ibi
|
| ... | ... | @@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter |
| 21 | 21 | , mkCostCentres
|
| 22 | 22 | , costCentreStackInfo
|
| 23 | 23 | , newBreakArray
|
| 24 | - , newModuleName
|
|
| 24 | + , newModule
|
|
| 25 | 25 | , storeBreakpoint
|
| 26 | 26 | , breakpointStatus
|
| 27 | 27 | , getBreakpointVar
|
| ... | ... | @@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) |
| 93 | 93 | import GHC.Utils.Fingerprint
|
| 94 | 94 | |
| 95 | 95 | import GHC.Unit.Module
|
| 96 | -import GHC.Unit.Module.ModIface
|
|
| 97 | 96 | import GHC.Unit.Home.ModInfo
|
| 98 | -import GHC.Unit.Home.PackageTable
|
|
| 99 | 97 | import GHC.Unit.Env
|
| 100 | 98 | |
| 101 | 99 | #if defined(HAVE_INTERNAL_INTERPRETER)
|
| ... | ... | @@ -119,6 +117,7 @@ import qualified GHC.InfoProv as InfoProv |
| 119 | 117 | |
| 120 | 118 | import GHC.Builtin.Names
|
| 121 | 119 | import GHC.Types.Name
|
| 120 | +import qualified GHC.Unit.Home.Graph as HUG
|
|
| 122 | 121 | |
| 123 | 122 | -- Standard libraries
|
| 124 | 123 | import GHC.Exts
|
| ... | ... | @@ -377,9 +376,13 @@ newBreakArray interp size = do |
| 377 | 376 | breakArray <- interpCmd interp (NewBreakArray size)
|
| 378 | 377 | mkFinalizedHValue interp breakArray
|
| 379 | 378 | |
| 380 | -newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
|
|
| 381 | -newModuleName interp mod_name =
|
|
| 382 | - castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
|
|
| 379 | +newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
|
|
| 380 | +newModule interp mod = do
|
|
| 381 | + let
|
|
| 382 | + mod_name = moduleNameString $ moduleName mod
|
|
| 383 | + mod_id = unitIdString $ toUnitId $ moduleUnit mod
|
|
| 384 | + (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
|
|
| 385 | + pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
|
|
| 383 | 386 | |
| 384 | 387 | storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
|
| 385 | 388 | storeBreakpoint interp ref ix cnt = do -- #19157
|
| ... | ... | @@ -415,19 +418,21 @@ seqHValue interp unit_env ref = |
| 415 | 418 | status <- interpCmd interp (Seq hval)
|
| 416 | 419 | handleSeqHValueStatus interp unit_env status
|
| 417 | 420 | |
| 418 | -evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
|
|
| 419 | -evalBreakpointToId hpt eval_break =
|
|
| 420 | - let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
|
|
| 421 | - in do
|
|
| 422 | - tickl <- load_mod (eb_tick_mod eval_break)
|
|
| 423 | - infol <- load_mod (eb_info_mod eval_break)
|
|
| 424 | - return
|
|
| 425 | - InternalBreakpointId
|
|
| 426 | - { ibi_tick_mod = tickl
|
|
| 427 | - , ibi_tick_index = eb_tick_index eval_break
|
|
| 428 | - , ibi_info_mod = infol
|
|
| 429 | - , ibi_info_index = eb_info_index eval_break
|
|
| 430 | - }
|
|
| 421 | +evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
|
|
| 422 | +evalBreakpointToId eval_break =
|
|
| 423 | + let
|
|
| 424 | + mkUnitId u = RealUnit (Definite $ stringToUnitId u)
|
|
| 425 | + |
|
| 426 | + toModule u n = mkModule (mkUnitId u) (mkModuleName n)
|
|
| 427 | + tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
|
|
| 428 | + infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
|
|
| 429 | + in
|
|
| 430 | + InternalBreakpointId
|
|
| 431 | + { ibi_tick_mod = tickl
|
|
| 432 | + , ibi_tick_index = eb_tick_index eval_break
|
|
| 433 | + , ibi_info_mod = infol
|
|
| 434 | + , ibi_info_index = eb_info_index eval_break
|
|
| 435 | + }
|
|
| 431 | 436 | |
| 432 | 437 | -- | Process the result of a Seq or ResumeSeq message. #2950
|
| 433 | 438 | handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
|
| ... | ... | @@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status = |
| 447 | 452 | mkGeneralSrcSpan (fsLit "<unknown>")
|
| 448 | 453 | |
| 449 | 454 | Just break -> do
|
| 450 | - bi <- evalBreakpointToId (ue_hpt unit_env) break
|
|
| 455 | + let bi = evalBreakpointToId break
|
|
| 451 | 456 | |
| 452 | 457 | -- Just case: Stopped at a breakpoint, extract SrcSpan information
|
| 453 | 458 | -- from the breakpoint.
|
| 454 | 459 | breaks_tick <- getModBreaks . expectJust <$>
|
| 455 | - lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
|
|
| 460 | + HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
|
|
| 456 | 461 | put $ brackets . ppr $
|
| 457 | 462 | (modBreaks_locs breaks_tick) ! ibi_tick_index bi
|
| 458 | 463 |
| ... | ... | @@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do |
| 416 | 416 | Nothing -> pure code
|
| 417 | 417 | Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
|
| 418 | 418 | Nothing -> pure code
|
| 419 | - Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
|
|
| 419 | + Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
|
|
| 420 | 420 | platform <- profilePlatform <$> getProfile
|
| 421 | 421 | let idOffSets = getVarOffSets platform d p fvs
|
| 422 | 422 | ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
|
| ... | ... | @@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do |
| 425 | 425 | breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
|
| 426 | 426 | |
| 427 | 427 | let info_mod_ptr = modBreaks_module current_mod_breaks
|
| 428 | + info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
|
|
| 428 | 429 | infox <- newBreakInfo breakInfo
|
| 429 | 430 | |
| 430 | 431 | let cc | Just interp <- hsc_interp hsc_env
|
| ... | ... | @@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do |
| 437 | 438 | in if fromIntegral r == x
|
| 438 | 439 | then r
|
| 439 | 440 | else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
|
| 440 | - breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
|
|
| 441 | + breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
|
|
| 441 | 442 | return $ breakInstr `consOL` code
|
| 442 | 443 | schemeER_wrk d p rhs = schemeE d 0 p rhs
|
| 443 | 444 |
| ... | ... | @@ -23,6 +23,7 @@ module GHCi.Message |
| 23 | 23 | , getMessage, putMessage, getTHMessage, putTHMessage
|
| 24 | 24 | , Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
|
| 25 | 25 | , BreakModule
|
| 26 | + , BreakUnitId
|
|
| 26 | 27 | , LoadedDLL
|
| 27 | 28 | ) where
|
| 28 | 29 | |
| ... | ... | @@ -245,8 +246,9 @@ data Message a where |
| 245 | 246 | -- | Allocate a string for a breakpoint module name.
|
| 246 | 247 | -- This uses an empty dummy type because @ModuleName@ isn't available here.
|
| 247 | 248 | NewBreakModule
|
| 248 | - :: String
|
|
| 249 | - -> Message (RemotePtr BreakModule)
|
|
| 249 | + :: String -- ^ @ModuleName@
|
|
| 250 | + -> String -- ^ @UnitId@ for the given @ModuleName@
|
|
| 251 | + -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
|
|
| 250 | 252 | |
| 251 | 253 | |
| 252 | 254 | deriving instance Show (Message a)
|
| ... | ... | @@ -410,10 +412,12 @@ data EvalStatus_ a b |
| 410 | 412 | instance Binary a => Binary (EvalStatus_ a b)
|
| 411 | 413 | |
| 412 | 414 | data EvalBreakpoint = EvalBreakpoint
|
| 413 | - { eb_tick_mod :: String -- ^ Breakpoint tick module
|
|
| 414 | - , eb_tick_index :: Int -- ^ Breakpoint tick index
|
|
| 415 | - , eb_info_mod :: String -- ^ Breakpoint info module
|
|
| 416 | - , eb_info_index :: Int -- ^ Breakpoint info index
|
|
| 415 | + { eb_tick_mod :: String -- ^ Breakpoint tick module
|
|
| 416 | + , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
|
|
| 417 | + , eb_tick_index :: Int -- ^ Breakpoint tick index
|
|
| 418 | + , eb_info_mod :: String -- ^ Breakpoint info module
|
|
| 419 | + , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
|
|
| 420 | + , eb_info_index :: Int -- ^ Breakpoint info index
|
|
| 417 | 421 | }
|
| 418 | 422 | deriving (Generic, Show)
|
| 419 | 423 | |
| ... | ... | @@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a) |
| 430 | 434 | -- that type isn't available here.
|
| 431 | 435 | data BreakModule
|
| 432 | 436 | |
| 437 | +-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
|
|
| 438 | +-- that type isn't available here.
|
|
| 439 | +data BreakUnitId
|
|
| 440 | + |
|
| 433 | 441 | -- | A dummy type that tags pointers returned by 'LoadDLL'.
|
| 434 | 442 | data LoadedDLL
|
| 435 | 443 | |
| ... | ... | @@ -580,7 +588,7 @@ getMessage = do |
| 580 | 588 | 36 -> Msg <$> (Seq <$> get)
|
| 581 | 589 | 37 -> Msg <$> return RtsRevertCAFs
|
| 582 | 590 | 38 -> Msg <$> (ResumeSeq <$> get)
|
| 583 | - 39 -> Msg <$> (NewBreakModule <$> get)
|
|
| 591 | + 39 -> Msg <$> (NewBreakModule <$> get <*> get)
|
|
| 584 | 592 | 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
|
| 585 | 593 | 41 -> Msg <$> (WhereFrom <$> get)
|
| 586 | 594 | _ -> error $ "Unknown Message code " ++ (show b)
|
| ... | ... | @@ -627,7 +635,7 @@ putMessage m = case m of |
| 627 | 635 | Seq a -> putWord8 36 >> put a
|
| 628 | 636 | RtsRevertCAFs -> putWord8 37
|
| 629 | 637 | ResumeSeq a -> putWord8 38 >> put a
|
| 630 | - NewBreakModule name -> putWord8 39 >> put name
|
|
| 638 | + NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
|
|
| 631 | 639 | LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
|
| 632 | 640 | WhereFrom a -> putWord8 41 >> put a
|
| 633 | 641 |
| ... | ... | @@ -95,7 +95,10 @@ run m = case m of |
| 95 | 95 | MkCostCentres mod ccs -> mkCostCentres mod ccs
|
| 96 | 96 | CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
|
| 97 | 97 | NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
|
| 98 | - NewBreakModule name -> newModuleName name
|
|
| 98 | + NewBreakModule name unitid -> do
|
|
| 99 | + namePtr <- newModuleName name
|
|
| 100 | + uidPtr <- newUnitId unitid
|
|
| 101 | + pure (namePtr, uidPtr)
|
|
| 99 | 102 | SetupBreakpoint ref ix cnt -> do
|
| 100 | 103 | arr <- localRef ref;
|
| 101 | 104 | _ <- setupBreakpoint arr ix cnt
|
| ... | ... | @@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act |
| 335 | 338 | -- as soon as it is hit, or in resetBreakAction below.
|
| 336 | 339 | |
| 337 | 340 | onBreak :: BreakpointCallback
|
| 338 | - onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
|
|
| 341 | + onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
|
|
| 339 | 342 | tid <- myThreadId
|
| 340 | 343 | let resume = ResumeContext
|
| 341 | 344 | { resumeBreakMVar = breakMVar
|
| ... | ... | @@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act |
| 349 | 352 | then pure Nothing
|
| 350 | 353 | else do
|
| 351 | 354 | tick_mod <- peekCString (Ptr tick_mod#)
|
| 355 | + tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
|
|
| 352 | 356 | info_mod <- peekCString (Ptr info_mod#)
|
| 353 | - pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
|
|
| 357 | + info_mod_uid <- peekCString (Ptr info_mod_uid#)
|
|
| 358 | + pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
|
|
| 354 | 359 | putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
|
| 355 | 360 | takeMVar breakMVar
|
| 356 | 361 | |
| ... | ... | @@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0 |
| 400 | 405 | |
| 401 | 406 | type BreakpointCallback
|
| 402 | 407 | = Addr# -- pointer to the breakpoint tick module name
|
| 408 | + -> Addr# -- pointer to the breakpoint tick module unit id
|
|
| 403 | 409 | -> Int# -- breakpoint tick index
|
| 404 | 410 | -> Addr# -- pointer to the breakpoint info module name
|
| 411 | + -> Addr# -- pointer to the breakpoint info module unit id
|
|
| 405 | 412 | -> Int# -- breakpoint info index
|
| 406 | 413 | -> Bool -- exception?
|
| 407 | 414 | -> HValue -- the AP_STACK, or exception
|
| ... | ... | @@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback |
| 414 | 421 | noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
|
| 415 | 422 | |
| 416 | 423 | noBreakAction :: BreakpointCallback
|
| 417 | -noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
|
|
| 418 | -noBreakAction _ _ _ _ True _ = return () -- exception: just continue
|
|
| 424 | +noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
|
|
| 425 | +noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
|
|
| 419 | 426 | |
| 420 | 427 | -- Malloc and copy the bytes. We don't have any way to monitor the
|
| 421 | 428 | -- lifetime of this memory, so it just leaks.
|
| ... | ... | @@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule) |
| 453 | 460 | newModuleName name =
|
| 454 | 461 | castRemotePtr . toRemotePtr <$> newCString name
|
| 455 | 462 | |
| 463 | +newUnitId :: String -> IO (RemotePtr BreakUnitId)
|
|
| 464 | +newUnitId name =
|
|
| 465 | + castRemotePtr . toRemotePtr <$> newCString name
|
|
| 466 | + |
|
| 456 | 467 | getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
|
| 457 | 468 | getIdValFromApStack apStack (I# stackDepth) = do
|
| 458 | 469 | case getApStackVal# apStack stackDepth of
|
| ... | ... | @@ -535,12 +535,16 @@ 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(13);
|
|
| 539 | - Sp(12) = exception;
|
|
| 540 | - Sp(11) = stg_raise_ret_info;
|
|
| 541 | - Sp(10) = exception;
|
|
| 542 | - Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
|
|
| 543 | - Sp(8) = stg_ap_ppv_info;
|
|
| 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;
|
|
| 544 | 548 | Sp(7) = 0;
|
| 545 | 549 | Sp(6) = stg_ap_n_info;
|
| 546 | 550 | Sp(5) = 0;
|
| ... | ... | @@ -1245,9 +1245,9 @@ run_BCO: |
| 1245 | 1245 | /* check for a breakpoint on the beginning of a let binding */
|
| 1246 | 1246 | case bci_BRK_FUN:
|
| 1247 | 1247 | {
|
| 1248 | - int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
|
|
| 1248 | + int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
|
|
| 1249 | 1249 | #if defined(PROFILING)
|
| 1250 | - int arg6_cc;
|
|
| 1250 | + int arg8_cc;
|
|
| 1251 | 1251 | #endif
|
| 1252 | 1252 | StgArrBytes *breakPoints;
|
| 1253 | 1253 | int returning_from_break;
|
| ... | ... | @@ -1264,10 +1264,12 @@ run_BCO: |
| 1264 | 1264 | arg1_brk_array = BCO_GET_LARGE_ARG;
|
| 1265 | 1265 | arg2_tick_mod = BCO_GET_LARGE_ARG;
|
| 1266 | 1266 | arg3_info_mod = BCO_GET_LARGE_ARG;
|
| 1267 | - arg4_tick_index = BCO_NEXT;
|
|
| 1268 | - arg5_info_index = BCO_NEXT;
|
|
| 1267 | + arg4_tick_mod_id = BCO_GET_LARGE_ARG;
|
|
| 1268 | + arg5_info_mod_id = BCO_GET_LARGE_ARG;
|
|
| 1269 | + arg6_tick_index = BCO_NEXT;
|
|
| 1270 | + arg7_info_index = BCO_NEXT;
|
|
| 1269 | 1271 | #if defined(PROFILING)
|
| 1270 | - arg6_cc = BCO_GET_LARGE_ARG;
|
|
| 1272 | + arg8_cc = BCO_GET_LARGE_ARG;
|
|
| 1271 | 1273 | #else
|
| 1272 | 1274 | BCO_GET_LARGE_ARG;
|
| 1273 | 1275 | #endif
|
| ... | ... | @@ -1280,7 +1282,7 @@ run_BCO: |
| 1280 | 1282 | |
| 1281 | 1283 | #if defined(PROFILING)
|
| 1282 | 1284 | cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
|
| 1283 | - (CostCentre*)BCO_LIT(arg6_cc));
|
|
| 1285 | + (CostCentre*)BCO_LIT(arg8_cc));
|
|
| 1284 | 1286 | #endif
|
| 1285 | 1287 | |
| 1286 | 1288 | // if we are returning from a break then skip this section
|
| ... | ... | @@ -1292,11 +1294,11 @@ run_BCO: |
| 1292 | 1294 | // stop the current thread if either the
|
| 1293 | 1295 | // "rts_stop_next_breakpoint" flag is true OR if the
|
| 1294 | 1296 | // ignore count for this particular breakpoint is zero
|
| 1295 | - StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
|
|
| 1297 | + StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
|
|
| 1296 | 1298 | if (rts_stop_next_breakpoint == false && ignore_count > 0)
|
| 1297 | 1299 | {
|
| 1298 | 1300 | // decrement and write back ignore count
|
| 1299 | - ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
|
|
| 1301 | + ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
|
|
| 1300 | 1302 | }
|
| 1301 | 1303 | else if (rts_stop_next_breakpoint == true || ignore_count == 0)
|
| 1302 | 1304 | {
|
| ... | ... | @@ -1330,8 +1332,10 @@ run_BCO: |
| 1330 | 1332 | // continue execution of this BCO when the IO action returns.
|
| 1331 | 1333 | //
|
| 1332 | 1334 | // ioAction :: Addr# -- the breakpoint tick module
|
| 1335 | + // -> Addr# -- the breakpoint tick module unit id
|
|
| 1333 | 1336 | // -> Int# -- the breakpoint tick index
|
| 1334 | 1337 | // -> Addr# -- the breakpoint info module
|
| 1338 | + // -> Addr# -- the breakpoint info module unit id
|
|
| 1335 | 1339 | // -> Int# -- the breakpoint info index
|
| 1336 | 1340 | // -> Bool -- exception?
|
| 1337 | 1341 | // -> HValue -- the AP_STACK, or exception
|
| ... | ... | @@ -1340,17 +1344,21 @@ run_BCO: |
| 1340 | 1344 | ioAction = (StgClosure *) deRefStablePtr (
|
| 1341 | 1345 | rts_breakpoint_io_action);
|
| 1342 | 1346 | |
| 1343 | - Sp_subW(15);
|
|
| 1344 | - SpW(14) = (W_)obj;
|
|
| 1345 | - SpW(13) = (W_)&stg_apply_interp_info;
|
|
| 1346 | - SpW(12) = (W_)new_aps;
|
|
| 1347 | - SpW(11) = (W_)False_closure; // True <=> an exception
|
|
| 1348 | - SpW(10) = (W_)&stg_ap_ppv_info;
|
|
| 1349 | - SpW(9) = (W_)arg5_info_index;
|
|
| 1347 | + Sp_subW(19);
|
|
| 1348 | + SpW(18) = (W_)obj;
|
|
| 1349 | + SpW(17) = (W_)&stg_apply_interp_info;
|
|
| 1350 | + SpW(16) = (W_)new_aps;
|
|
| 1351 | + SpW(15) = (W_)False_closure; // True <=> an exception
|
|
| 1352 | + SpW(14) = (W_)&stg_ap_ppv_info;
|
|
| 1353 | + SpW(13) = (W_)arg7_info_index;
|
|
| 1354 | + SpW(12) = (W_)&stg_ap_n_info;
|
|
| 1355 | + SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
|
|
| 1356 | + SpW(10) = (W_)&stg_ap_n_info;
|
|
| 1357 | + SpW(9) = (W_)BCO_LIT(arg3_info_mod);
|
|
| 1350 | 1358 | SpW(8) = (W_)&stg_ap_n_info;
|
| 1351 | - SpW(7) = (W_)BCO_LIT(arg3_info_mod);
|
|
| 1359 | + SpW(7) = (W_)arg6_tick_index;
|
|
| 1352 | 1360 | SpW(6) = (W_)&stg_ap_n_info;
|
| 1353 | - SpW(5) = (W_)arg4_tick_index;
|
|
| 1361 | + SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
|
|
| 1354 | 1362 | SpW(4) = (W_)&stg_ap_n_info;
|
| 1355 | 1363 | SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
|
| 1356 | 1364 | SpW(2) = (W_)&stg_ap_n_info;
|