Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
-
91cb9703
by fendor at 2025-04-17T14:38:42+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;
|