Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC Commits: 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - b56d108c by Rodrigo Mesquita at 2025-07-16T10:32:32+01:00 build: Relax ghc/ghc-boot Cabal bound to 3.16 Fixes #26202 - - - - - bd2949c6 by Rodrigo Mesquita at 2025-07-16T10:32:47+01:00 cabal-reinstall: Use haddock-api +in-tree-ghc Fixes #26202 - - - - - d19e3e4a by Rodrigo Mesquita at 2025-07-16T10:32:50+01:00 cabal-reinstall: Pass --strict to Happy This is necessary to make the generated Parser build successfully This mimics Hadrian, which always passes --strict to happy. Fixes #26202 - - - - - 4da0a66b by Rodrigo Mesquita at 2025-07-17T09:44:05+01:00 debugger: Uniquely identify breakpoints by internal id Since b85b11994e0130ff2401dd4bbdf52330e0bcf776 (support inlining breakpoints), a breakpoint has been identified at runtime by *two* pairs of <module,index>. - The first, aka a 'BreakpointId', uniquely identifies a breakpoint in the source of a module by using the Tick index. A Tick index can index into ModBreaks.modBreaks_xxx to fetch source-level information about where that tick originated. - When a user specifies e.g. a line breakpoint using :break, we'll reverse engineer what a Tick index for that line - We update the `BreakArray` of that module (got from the LoaderState) at that tick index to `breakOn`. - A BCO we can stop at is headed by a BRK_FUN instruction. This instruction stores in an operand the `tick index` it is associated to. We look it up in the associated `BreakArray` (also an operand) and check wheter it was set to `breakOn`. - The second, aka the `ibi_info_mod` + `ibi_info_ix` of the `InternalBreakpointId`, uniquely index into the `imodBreaks_breakInfo` -- the information we gathered during code generation about the existing breakpoint *ocurrences*. - Note that with optimisation there may be many occurrences of the same source-tick-breakpoint across different modules. The `ibi_info_ix` is unique per occurrence, but the `bi_tick_ix` may be shared. See Note [Breakpoint identifiers] about this. - Note that besides the tick ids, info ids are also stored in `BRK_FUN` so the break handler can refer to the associated `CgBreakInfo`. In light of that, the driving changes come from the desire to have the info_id uniquely identify the breakpoint at runtime, and the source tick id being derived from it: - An InternalBreakpointId should uniquely identify a breakpoint just from the code-generation identifiers of `ibi_info_ix` and `ibi_info_mod`. So we drop `ibi_tick_mod` and `ibi_tick_ix`. - A BRK_FUN instruction need only record the "internal breakpoint id", not the tick-level id. So we drop the tick mod and tick index operands. - A BreakArray should be indexed by InternalBreakpointId rather than BreakpointId That means we need to do some more work when setting a breakpoint. Specifically, we need to figure out the internal ids (occurrences of a breakpoint) from the source-level BreakpointId we want to set the breakpoint at (recall :break refers to breaks at the source level). Besides this change being an improvement to the handling of breakpoints (it's clearer to have a single unique identifier than two competing ones), it unlocks the possibility of generating "internal" breakpoints during Cg (needed for #26042). It should also be easier to introduce multi-threaded-aware `BreakArrays` following this change (needed for #26064). Se also the new Note [ModBreaks vs InternalModBreaks] - - - - - d1439072 by Rodrigo Mesquita at 2025-07-17T09:44:06+01:00 cleanup: Move dehydrateCgBreakInfo to Stg2Bc This no longer has anything to do with Core. - - - - - 9e37cf61 by Ben Gamari at 2025-07-17T09:44:06+01:00 rts/Interpreter: Factor out ctoi tuple info tables into data Instead of a massive case let's put this into data which we can reuse elsewhere. - - - - - eab05af0 by Rodrigo Mesquita at 2025-07-17T09:44:06+01:00 rts/Disassembler: Fix spacing of BRK_FUN - - - - - 2692e656 by Rodrigo Mesquita at 2025-07-18T18:28:49+01:00 Makes sure run_BCO has variables directly on top of the stack Instead we kept ctoi_ret frames when entering run_BCO, and the ByteCode generator accounted for the frame header and then slided it off. Now, when run_BCO is called for a case continuation, the return value and free variables are directly on top. - - - - - 02e468b0 by Rodrigo Mesquita at 2025-07-18T18:29:12+01:00 Working on making BRK_FUNs for case cont. BCO [skip ci] - - - - - 28 changed files: - cabal.project-reinstall - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/Setup.hs - compiler/ghc.cabal.in - docs/users_guide/eventlog-formats.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/ghc-boot/Setup.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Exception.cmm - rts/Interpreter.c - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== cabal.project-reinstall ===================================== @@ -59,6 +59,7 @@ constraints: ghc +internal-interpreter +dynamic-system-linke, ghc-bin +internal-interpreter +threaded, ghci +internal-interpreter, haddock +in-ghc-tree, + haddock-api +in-ghc-tree, any.array installed, any.base installed, any.deepseq installed, @@ -69,6 +70,9 @@ constraints: ghc +internal-interpreter +dynamic-system-linke, any.template-haskell installed +package * + happy-options: --strict + benchmarks: False tests: False allow-boot-library-installs: True ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -841,24 +841,18 @@ assembleI platform i = case i of W8 -> emit_ bci_OP_INDEX_ADDR_08 [] _ -> unsupported_width - BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox) -> do + BRK_FUN ibi@(InternalBreakpointId info_mod infox) byteOff -> do + p1 <- ptr $ BCOPtrBreakArray info_mod let -- cast that checks that round-tripping through Word16 doesn't change the value toW16 x = let r = fromIntegral x :: Word16 in if fromIntegral r == x then r else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x) - p1 <- ptr $ BCOPtrBreakArray tick_mod - tick_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName tick_mod - info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod - tick_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ tick_mod - info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId $ info_mod - np <- lit1 $ BCONPtrCostCentre (BreakpointId tick_mod tickx) - emit_ bci_BRK_FUN [ Op p1 - , Op tick_addr, Op info_addr - , Op tick_unitid_addr, Op info_unitid_addr - , SmallOp (toW16 tickx), SmallOp (toW16 infox) - , Op np - ] + info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod + info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod + np <- lit1 $ BCONPtrCostCentre ibi + emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr + , SmallOp (toW16 infox), SmallOp (toW16 byteOff), Op np ] BRK_ALTS active -> emit_ bci_BRK_ALTS [SmallOp (if active then 1 else 0)] ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -7,23 +8,24 @@ -- 'InternalModBreaks', and is uniquely identified at runtime by an -- 'InternalBreakpointId'. -- --- See Note [Breakpoint identifiers] +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] module GHC.ByteCode.Breakpoints ( -- * Internal Mod Breaks InternalModBreaks(..), CgBreakInfo(..) - , mkInternalModBreaks + , mkInternalModBreaks, imodBreaks_module -- ** Internal breakpoint identifier , InternalBreakpointId(..), BreakInfoIndex + , InternalBreakLoc(..) -- * Operations - , toBreakpointId -- ** Internal-level operations - , getInternalBreak, addInternalBreak + , getInternalBreak -- ** Source-level information operations , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS + , getBreakSourceId, getBreakSourceMod -- * Utils , seqInternalModBreaks @@ -47,6 +49,31 @@ import GHC.Utils.Panic import Data.Array {- +Note [ModBreaks vs InternalModBreaks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'ModBreaks' and 'BreakpointId's must not to be confused with +'InternalModBreaks' and 'InternalBreakId's. + +'ModBreaks' is constructed once during HsToCore from the information attached +to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks' +can be queried using 'BreakpointId's, which uniquely identifies a breakpoint +within the list of breakpoint information for a given module's 'ModBreaks'. + +'InternalModBreaks' are constructed during bytecode generation and are indexed +by a 'InternalBreakpointId'. They contain all the information relevant to a +breakpoint for code generation that can be accessed during runtime execution +(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's +are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN' +instruction receives 'InternalBreakpointId' as an argument. + +We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used +to get source-level information about a breakpoint via the corresponding 'ModBreaks'. + +Notably, 'InternalModBreaks' can contain entries for so-called internal +breakpoints, which do not necessarily have a source-level location attached to +it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to +introduce breakpoints during code generation for features such as stepping-out. + Note [Breakpoint identifiers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before optimization a breakpoint is identified uniquely with a tick module @@ -64,6 +91,10 @@ So every breakpoint occurrence gets assigned a module-unique *info index* and we store it alongside the occurrence module (*info module*) in the 'InternalBreakpointId' datatype. This is the index that we use at runtime to identify a breakpoint. + +When the internal breakpoint has a matching tick-level breakpoint we can fetch +the related tick-level information by first looking up a mapping +@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@. -} -------------------------------------------------------------------------------- @@ -78,19 +109,11 @@ type BreakInfoIndex = Int -- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation. -- See Note [Breakpoint identifiers] data InternalBreakpointId = InternalBreakpointId - { ibi_tick_mod :: !Module -- ^ Breakpoint tick module - , ibi_tick_index :: !Int -- ^ Breakpoint tick index - , ibi_info_mod :: !Module -- ^ Breakpoint tick module + { ibi_info_mod :: !Module -- ^ Breakpoint tick module , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint tick index } deriving (Eq, Ord) -toBreakpointId :: InternalBreakpointId -> BreakpointId -toBreakpointId ibi = BreakpointId - { bi_tick_mod = ibi_tick_mod ibi - , bi_tick_index = ibi_tick_index ibi - } - -------------------------------------------------------------------------------- -- * Internal Mod Breaks -------------------------------------------------------------------------------- @@ -107,18 +130,34 @@ data InternalModBreaks = InternalModBreaks -- 'InternalBreakpointId'. , imodBreaks_modBreaks :: !ModBreaks - -- ^ Store the original ModBreaks for this module, unchanged. - -- Allows us to query about source-level breakpoint information using - -- an internal breakpoint id. + -- ^ Store the ModBreaks for this module + -- + -- Recall Note [Breakpoint identifiers]: for some module A, an + -- *occurrence* of a breakpoint in A may have been inlined from some + -- breakpoint *defined* in module B. + -- + -- This 'ModBreaks' contains information regarding all the breakpoints + -- defined in the module this 'InternalModBreaks' corresponds to. It + -- /does not/ necessarily have information regarding all the breakpoint + -- occurrences registered in 'imodBreaks_breakInfo'. Some of those + -- occurrences may refer breakpoints inlined from other modules. } --- | Construct an 'InternalModBreaks' +-- | Construct an 'InternalModBreaks'. +-- +-- INVARIANT: The given 'ModBreaks' correspond to the same module as this +-- 'InternalModBreaks' module (the first argument) and its breakpoint infos +-- (the @IntMap CgBreakInfo@ argument) mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks mkInternalModBreaks mod im mbs = assertPpr (mod == modBreaks_module mbs) (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $ InternalModBreaks im mbs +-- | Get the module to which these 'InternalModBreaks' correspond +imodBreaks_module :: InternalModBreaks -> Module +imodBreaks_module = modBreaks_module . imodBreaks_modBreaks + -- | Information about a breakpoint that we know at code-generation time -- In order to be used, this needs to be hydrated relative to the current HscEnv by -- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for @@ -128,20 +167,32 @@ data CgBreakInfo { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] , cgb_resty :: !IfaceType + , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId) + -- ^ This field records the original breakpoint tick identifier for this + -- internal breakpoint info. It is used to convert a breakpoint + -- *occurrence* index ('InternalBreakpointId') into a *definition* index + -- ('BreakpointId'). + -- + -- The modules of breakpoint occurrence and breakpoint definition are not + -- necessarily the same: See Note [Breakpoint identifiers]. + -- + -- If there is no original tick identifier (that is, the breakpoint was + -- created during code generation), instead refer directly to the SrcSpan + -- we want to use for it. See Note [Internal Breakpoint Locations] } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval +-- | Breakpoints created during code generation don't have a source-level tick +-- location. Instead, we come up with one ourselves. +-- See Note [Internal Breakpoint Locations] +newtype InternalBreakLoc = InternalBreakLoc SrcSpan + deriving newtype (Eq, Show, NFData, Outputable) + -- | Get an internal breakpoint info by 'InternalBreakpointId' getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo -getInternalBreak (InternalBreakpointId _ _ info_mod info_ix) imbs = - assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $ - imodBreaks_breakInfo imbs IM.! info_ix - --- | Add a CgBreakInfo to an 'InternalModBreaks' at 'InternalBreakpointId' -addInternalBreak :: InternalBreakpointId -> CgBreakInfo -> InternalModBreaks -> InternalModBreaks -addInternalBreak (InternalBreakpointId _ _ info_mod info_ix) info imbs = - assert_modules_match info_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $ - imbs{imodBreaks_breakInfo = IM.insert info_ix info (imodBreaks_breakInfo imbs)} +getInternalBreak (InternalBreakpointId mod ix) imbs = + assert_modules_match mod (imodBreaks_module imbs) $ + imodBreaks_breakInfo imbs IM.! ix -- | Assert that the module in the 'InternalBreakpointId' and in -- 'InternalModBreaks' match. @@ -155,27 +206,70 @@ assert_modules_match ibi_mod imbs_mod = -- Tick-level Breakpoint information -------------------------------------------------------------------------------- +-- | Get the source module and tick index for this breakpoint +-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId') +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId +getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in cgb_tick_id cgb + +-- | Get the source module for this breakpoint (where the breakpoint is defined) +getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module +getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in case cgb_tick_id cgb of + Left InternalBreakLoc{} -> imodBreaks_module imbs + Right BreakpointId{bi_tick_mod} -> bi_tick_mod + -- | Get the source span for this breakpoint -getBreakLoc :: InternalBreakpointId -> InternalModBreaks -> SrcSpan -getBreakLoc = getBreakXXX modBreaks_locs +getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan +getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x) -- | Get the vars for this breakpoint -getBreakVars :: InternalBreakpointId -> InternalModBreaks -> [OccName] -getBreakVars = getBreakXXX modBreaks_vars +getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName] +getBreakVars = getBreakXXX modBreaks_vars (const []) -- | Get the decls for this breakpoint -getBreakDecls :: InternalBreakpointId -> InternalModBreaks -> [String] -getBreakDecls = getBreakXXX modBreaks_decls +getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] +getBreakDecls = getBreakXXX modBreaks_decls (const []) -- | Get the decls for this breakpoint -getBreakCCS :: InternalBreakpointId -> InternalModBreaks -> (String, String) -getBreakCCS = getBreakXXX modBreaks_ccs +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String)) +getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing) -- | Internal utility to access a ModBreaks field at a particular breakpoint index -getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> InternalBreakpointId -> InternalModBreaks -> a -getBreakXXX view (InternalBreakpointId tick_mod tick_id _ _) imbs = - assert_modules_match tick_mod (modBreaks_module $ imodBreaks_modBreaks imbs) $ do - view (imodBreaks_modBreaks imbs) ! tick_id +-- +-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the +-- *occurrence* module) doesn't necessarily match the module where the +-- tick breakpoint was defined with the relevant 'ModBreaks'. +-- +-- When the tick module is the same as the internal module, we use the stored +-- 'ModBreaks'. When the tick module is different, we need to look up the +-- 'ModBreaks' in the HUG for that other module. +-- +-- When there is no tick module (the breakpoint was generated at codegen), use +-- the function on internal mod breaks. +-- +-- To avoid cyclic dependencies, we instead receive a function that looks up +-- the 'ModBreaks' given a 'Module' +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a +getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ do + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + case cgb_tick_id cgb of + Right BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == ibi_mod + -> do + let these_mbs = imodBreaks_modBreaks imbs + return $ view these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- lookupModule bi_tick_mod + return $ view other_mbs ! bi_tick_index + Left l -> + return $ viewInternal l -------------------------------------------------------------------------------- -- Instances @@ -190,7 +284,8 @@ seqInternalModBreaks InternalModBreaks{..} = seqCgBreakInfo CgBreakInfo{..} = rnf cgb_tyvars `seq` rnf cgb_vars `seq` - rnf cgb_resty + rnf cgb_resty `seq` + rnf cgb_tick_id instance Outputable InternalBreakpointId where ppr InternalBreakpointId{..} = @@ -203,4 +298,5 @@ instance NFData InternalBreakpointId where instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> parens (ppr (cgb_vars info) <+> - ppr (cgb_resty info)) + ppr (cgb_resty info) <+> + ppr (cgb_tick_id info)) ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -258,7 +258,7 @@ data BCInstr -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN !InternalBreakpointId + | BRK_FUN !InternalBreakpointId !ByteOff -- An internal breakpoint for triggering a break on any case alternative -- See Note [Debugger: BRK_ALTS] @@ -454,10 +454,10 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN (InternalBreakpointId tick_mod tickx info_mod infox)) + ppr (BRK_FUN (InternalBreakpointId info_mod infox) bo) = text "BRK_FUN" <+> text "<breakarray>" - <+> ppr tick_mod <+> ppr tickx <+> ppr info_mod <+> ppr infox + <+> ppr bo <+> text "<cc>" ppr (BRK_ALTS active) = text "BRK_ALTS" <+> ppr active #if MIN_VERSION_rts(1,0,3) ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -98,9 +98,9 @@ lookupLiteral interp pkgs_loaded le lb ptr = case ptr of BCONPtrFFIInfo (FFIInfo {..}) -> do RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet pure $ fromIntegral p - BCONPtrCostCentre BreakpointId{..} + BCONPtrCostCentre InternalBreakpointId{..} | interpreterProfiled interp -> do - case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of + case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of RemotePtr p -> pure $ fromIntegral p | otherwise -> case toRemotePtr nullPtr of ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -285,7 +285,7 @@ data BCONPtr -- | A libffi ffi_cif function prototype. | BCONPtrFFIInfo !FFIInfo -- | A 'CostCentre' remote pointer array's respective 'BreakpointId' - | BCONPtrCostCentre !BreakpointId + | BCONPtrCostCentre !InternalBreakpointId instance NFData BCONPtr where rnf x = x `seq` () ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -44,16 +44,12 @@ module GHC.CoreToIface -- * Other stuff , toIfaceLFInfo , toIfaceBooleanFormula - -- * CgBreakInfo - , dehydrateCgBreakInfo ) where import GHC.Prelude import GHC.StgToCmm.Types -import GHC.ByteCode.Types - import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -702,15 +698,6 @@ toIfaceLFInfo nm lfi = case lfi of LFLetNoEscape -> panic "toIfaceLFInfo: LFLetNoEscape" --- Dehydrating CgBreakInfo - -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo -dehydrateCgBreakInfo ty_vars idOffSets tick_ty = - CgBreakInfo - { cgb_tyvars = map toIfaceTvBndr ty_vars - , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets - , cgb_resty = toIfaceType tick_ty - } {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -12,7 +12,7 @@ -- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed -- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'. -- --- See Note [Breakpoint identifiers] +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] module GHC.HsToCore.Breakpoints ( -- * ModBreaks mkModBreaks, ModBreaks(..) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -58,6 +58,7 @@ import GHCi.RemoteTypes import GHC.Iface.Load import GHCi.Message (ConInfoTable(..), LoadedDLL) +import GHC.ByteCode.Breakpoints import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types @@ -124,7 +125,9 @@ import GHC.Utils.Exception import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) import GHC.Driver.Downsweep import qualified GHC.Runtime.Interpreter as GHCi -import Data.Array.Base (numElements) +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import Foreign.Ptr (nullPtr) -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1666,10 +1669,10 @@ allocateBreakArrays :: IO (ModuleEnv (ForeignRef BreakArray)) allocateBreakArrays interp = foldlM - ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do + ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do -- If no BreakArray is assigned to this module yet, create one if not $ elemModuleEnv modBreaks_module be0 then do - let count = numElements modBreaks_locs + let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo) breakArray <- GHCi.newBreakArray interp count evaluate $ extendModuleEnv be0 modBreaks_module breakArray else @@ -1679,29 +1682,53 @@ allocateBreakArrays interp = -- | Given a list of 'InternalModBreaks' collected from a list -- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is -- enabled. +-- +-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal +-- breakpoint index), not by tick index allocateCCS :: Interp -> - ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) -> + ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) -> [InternalModBreaks] -> - IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) + IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre))) allocateCCS interp ce mbss - | interpreterProfiled interp = - foldlM - ( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do - ccs <- + | interpreterProfiled interp = do + -- 1. Create a mapping from source BreakpointId to CostCentre ptr + ccss <- M.unions <$> mapM + ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do + ccs <- {- one ccs ptr per tick index -} mkCostCentres interp (moduleNameString $ moduleName modBreaks_module) (elems modBreaks_ccs) - if not $ elemModuleEnv modBreaks_module ce0 then do - evaluate $ - extendModuleEnv ce0 modBreaks_module $ - listArray - (0, length ccs - 1) - ccs + return $ M.fromList $ + zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] + ) + mbss + -- 2. Create an array with one element for every InternalBreakpointId, + -- where every element has the CCS for the corresponding BreakpointId + foldlM + (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do + if not $ elemModuleEnv modBreaks_module ce then do + let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo) + let ccs = IM.map + (\info -> + case cgb_tick_id info of + Right bi -> fromMaybe (toRemotePtr nullPtr) + (M.lookup bi ccss) + Left InternalBreakLoc{} -> toRemotePtr nullPtr + ) + imodBreaks_breakInfo + assertPpr (count == length ccs) + (text "expected CgBreakInfo map to have one entry per valid ix") $ + evaluate $ + extendModuleEnv ce0 modBreaks_module $ + listArray + (0, count) + (IM.elems ccs) else return ce0 ) ce mbss + | otherwise = pure ce ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -31,6 +31,9 @@ import GHC.Unit.Module.ModSummary import GHC.Utils.Outputable import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict +import qualified Data.IntMap.Strict as IntMap +import qualified GHC.Unit.Home.Graph as HUG +import qualified GHC.Unit.Home.PackageTable as HPT -------------------------------------------------------------------------------- -- Finding Module breakpoints @@ -213,6 +216,50 @@ getModBreak m = do mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m pure $ imodBreaks_modBreaks <$> modInfoModBreaks mod_info +-------------------------------------------------------------------------------- +-- Mapping source-level BreakpointIds to IBI occurrences +-- (See Note [Breakpoint identifiers]) +-------------------------------------------------------------------------------- + +-- | A source-level breakpoint may have been inlined into many occurrences, now +-- referred by 'InternalBreakpointId'. When a breakpoint is set on a certain +-- source breakpoint, it means all *ocurrences* of that breakpoint across +-- modules should be stopped at -- hence we keep a trie from BreakpointId to +-- the list of internal break ids using it. +-- See also Note [Breakpoint identifiers] +type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId]) + +-- | Lookup all InternalBreakpointIds matching the given BreakpointId +-- Nothing if BreakpointId not in map +lookupBreakpointOccurrences :: BreakpointOccurrences -> BreakpointId -> Maybe [InternalBreakpointId] +lookupBreakpointOccurrences bmp (BreakpointId md tick) = + lookupModuleEnv bmp md >>= IntMap.lookup tick + +-- | Construct a mapping from Source 'BreakpointId's to 'InternalBreakpointId's from the given list of 'ModInfo's +mkBreakpointOccurrences :: forall m. GhcMonad m => m BreakpointOccurrences +mkBreakpointOccurrences = do + hug <- hsc_HUG <$> getSession + liftIO $ foldr go (pure emptyModuleEnv) hug + where + go :: HUG.HomeUnitEnv -> IO BreakpointOccurrences -> IO BreakpointOccurrences + go hue mbmp = do + bmp <- mbmp + ibrkss <- HPT.concatHpt (\hmi -> maybeToList (getModBreaks hmi)) + (HUG.homeUnitEnv_hpt hue) + return $ foldr addBreakToMap bmp ibrkss + + addBreakToMap :: InternalModBreaks -> BreakpointOccurrences -> BreakpointOccurrences + addBreakToMap ibrks bmp0 = do + let imod = modBreaks_module $ imodBreaks_modBreaks ibrks + IntMap.foldrWithKey (\info_ix cgi bmp -> do + let ibi = InternalBreakpointId imod info_ix + case cgb_tick_id cgi of + Right (BreakpointId tick_mod tick_ix) + -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + Left _ + -> bmp + ) bmp0 (imodBreaks_breakInfo ibrks) + -------------------------------------------------------------------------------- -- Getting current breakpoint information -------------------------------------------------------------------------------- @@ -235,9 +282,15 @@ getCurrentBreakSpan = do getCurrentBreakModule :: GhcMonad m => m (Maybe Module) getCurrentBreakModule = do resumes <- getResumeContext - return $ case resumes of - [] -> Nothing + hug <- hsc_HUG <$> getSession + liftIO $ case resumes of + [] -> pure Nothing (r:_) -> case resumeHistoryIx r of - 0 -> ibi_tick_mod <$> resumeBreakpointId r - ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1) + 0 -> case resumeBreakpointId r of + Nothing -> pure Nothing + Just ibi -> do + brks <- readIModBreaks hug ibi + return $ Just $ getBreakSourceMod ibi brks + ix -> + Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -18,7 +18,7 @@ module GHC.Runtime.Eval ( abandon, abandonAll, getResumeContext, getHistorySpan, - getModBreaks, readModBreaks, + getModBreaks, readIModBreaks, readIModModBreaks, getHistoryModule, setupBreakpoint, back, forward, @@ -147,14 +147,17 @@ getResumeContext = withSession (return . ic_resume . hsc_IC) mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi -getHistoryModule :: History -> Module -getHistoryModule = ibi_tick_mod . historyBreakpointId +getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module +getHistoryModule hug hist = do + let ibi = historyBreakpointId hist + brks <- readIModBreaks hug ibi + return $ getBreakSourceMod ibi brks getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan getHistorySpan hug hist = do let ibi = historyBreakpointId hist - brks <- readModBreaks hug (ibi_tick_mod ibi) - return $ getBreakLoc ibi brks + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed @@ -162,8 +165,8 @@ getHistorySpan hug hist = do -- for each tick. findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] findEnclosingDecls hug ibi = do - brks <- readModBreaks hug (ibi_tick_mod ibi) - return $ getBreakDecls ibi brks + brks <- readIModBreaks hug ibi + getBreakDecls (readIModModBreaks hug) ibi brks -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m () @@ -350,15 +353,14 @@ handleRunStatus step expr bindings final_ids status history0 = do EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break let hug = hsc_HUG hsc_env - tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi) - let - span = getBreakLoc ibi tick_brks - decl = intercalate "." $ getBreakDecls ibi tick_brks + info_brks <- liftIO $ readIModBreaks hug ibi + span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks + decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)? bactive <- liftIO $ do - breakArray <- getBreakArray interp (toBreakpointId ibi) tick_brks - breakpointStatus interp breakArray (ibi_tick_index ibi) + breakArray <- getBreakArray interp ibi info_brks + breakpointStatus interp breakArray (ibi_info_index ibi) apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt @@ -446,7 +448,7 @@ resumeExec step mbCnt -- When the user specified a break ignore count, set it -- in the interpreter case (mb_brkpt, mbCnt) of - (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt + (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt _ -> return () let eval_opts = initEvalOpts dflags (enableGhcStepMode step) @@ -462,17 +464,18 @@ resumeExec step mbCnt | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #19157 -setupBreakpoint interp bi cnt = do +setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp ibi cnt = do hug <- hsc_HUG <$> getSession - modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi) - breakArray <- liftIO $ getBreakArray interp bi modBreaks - liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt + liftIO $ do + modBreaks <- readIModBreaks hug ibi + breakArray <- getBreakArray interp ibi modBreaks + GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt -getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) -getBreakArray interp BreakpointId{bi_tick_mod} imbs = do +getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) +getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp - case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of + case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of Just ba -> return ba Nothing -> do modifyLoaderState interp $ \ld_st -> do @@ -483,13 +486,12 @@ getBreakArray interp BreakpointId{bi_tick_mod} imbs = do ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs] let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} } - let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod + let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod return ( ld_st' , ba ) - back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) @@ -517,8 +519,9 @@ moveHist fn = do span <- case mb_info of Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") Just ibi -> liftIO $ do - brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi) - return $ getBreakLoc ibi brks + let hug = hsc_HUG hsc_env + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks (hsc_env1, names) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info let ic = hsc_IC hsc_env1 @@ -579,11 +582,10 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do let hug = hsc_HUG hsc_env - info_brks <- readModBreaks hug (ibi_info_mod ibi) - tick_brks <- readModBreaks hug (ibi_tick_mod ibi) - let info = getInternalBreak ibi (info_brks) + info_brks <- readIModBreaks hug ibi + let info = getInternalBreak ibi info_brks interp = hscInterp hsc_env - occs = getBreakVars ibi tick_brks + occs <- getBreakVars (readIModModBreaks hug) ibi info_brks -- Rehydrate to understand the breakpoint info relative to the current environment. -- This design is critical to preventing leaks (#22530) ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -27,7 +27,9 @@ module GHC.Runtime.Interpreter , getClosure , whereFrom , getModBreaks - , readModBreaks + , readIModBreaks + , readIModBreaksMaybe + , readIModModBreaks , seqHValue , evalBreakpointToId @@ -92,7 +94,6 @@ import GHC.Utils.Fingerprint import GHC.Unit.Module import GHC.Unit.Home.ModInfo -import GHC.Unit.Home.Graph (lookupHugByModule) import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) @@ -411,15 +412,10 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId evalBreakpointToId eval_break = let mkUnitId u = fsToUnit $ mkFastStringShortByteString u - toModule u n = mkModule (mkUnitId u) (mkModuleName n) - tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break) - infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) in InternalBreakpointId - { ibi_tick_mod = tickl - , ibi_tick_index = eb_tick_index eval_break - , ibi_info_mod = infol + { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) , ibi_info_index = eb_info_index eval_break } @@ -440,17 +436,18 @@ handleSeqHValueStatus interp unit_env eval_status = -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq Just break -> do - let bi = evalBreakpointToId break + let ibi = evalBreakpointToId break + hug = ue_home_unit_graph unit_env -- Just case: Stopped at a breakpoint, extract SrcSpan information -- from the breakpoint. - mb_modbreaks <- getModBreaks . expectJust <$> - lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env) + mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi) case mb_modbreaks of -- Nothing case - should not occur! We should have the appropriate -- breakpoint information Nothing -> nothing_case - Just modbreaks -> put $ brackets . ppr $ getBreakLoc bi modbreaks + Just modbreaks -> put . brackets . ppr =<< + getBreakLoc (readIModModBreaks hug) ibi modbreaks -- resume the seq (:force) processing in the iserv process withForeignRef resume_ctxt_fhv $ \hval -> do @@ -745,10 +742,18 @@ getModBreaks hmi | otherwise = Nothing -- probably object code --- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module' --- from the 'HomeUnitGraph'. -readModBreaks :: HomeUnitGraph -> Module -> IO InternalModBreaks -readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug +-- | Read the 'InternalModBreaks' of the given home 'Module' (via +-- 'InternalBreakpointId') from the 'HomeUnitGraph'. +readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks +readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi) + +-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. +readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks) +readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug + +-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks' +readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks +readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod -- ----------------------------------------------------------------------------- -- Misc utils ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -31,7 +31,6 @@ import GHC.Cmm.Utils import GHC.Platform import GHC.Platform.Profile -import GHC.Runtime.Interpreter import GHCi.FFI import GHC.Types.Basic import GHC.Utils.Outputable @@ -64,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, assertNonVoidIds, assertNonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) +import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks ) import GHC.Data.Bitmap import GHC.Data.FlatBag as FlatBag import GHC.Data.OrdList @@ -79,7 +79,6 @@ import Control.Monad import Data.Char import GHC.Unit.Module -import qualified GHC.Unit.Home.Graph as HUG import Data.Coerce (coerce) #if MIN_VERSION_rts(1,0,3) @@ -100,6 +99,7 @@ import GHC.CoreToIface import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State (StateT(..)) +import Data.Array ((!)) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -394,65 +394,32 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do - code <- schemeE d 0 p rhs - hsc_env <- getHscEnv - current_mod <- getCurrentModule - mb_current_mod_breaks <- getCurrentModBreaks - case mb_current_mod_breaks of - -- if we're not generating ModBreaks for this module for some reason, we - -- can't store breakpoint occurrence information. - Nothing -> pure code - Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case - Nothing -> pure code - Just ModBreaks{modBreaks_module = tick_mod} -> do - platform <- profilePlatform <$> getProfile - let idOffSets = getVarOffSets platform d p fvs - ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) - toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) - breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty - - let info_mod = modBreaks_module current_mod_breaks - infox <- newBreakInfo breakInfo +schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do + platform <- profilePlatform <$> getProfile + + code <- case rhs of + -- When we find a tick surrounding a case expression we introduce a new BRK_FUN + -- instruction at the start of the case *continuation*, in addition to the + -- usual BRK_FUN surrounding the StgCase) + -- See Note [TODO] + StgCase scrut bndr _ alts + -> doCase d 0 p (Just bp) scrut bndr alts + _ -> schemeE d 0 p rhs + + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id) + + mibi <- newBreakInfo breakInfo + + return $ case mibi of + Nothing -> code + Just ibi -> BRK_FUN ibi 0 `consOL` code - let breakInstr = BRK_FUN (InternalBreakpointId tick_mod tick_no info_mod infox) - return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs --- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module --- from which the breakpoint originates. --- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs --- to refer to pointers in GHCi's address space. --- They are initialized in 'GHC.HsToCore.Breakpoints.mkModBreaks', called by --- 'GHC.HsToCore.deSugar'. --- --- Breakpoints might be disabled because we're in TH, because --- @-fno-break-points@ was specified, or because a module was reloaded without --- reinitializing 'ModBreaks'. --- --- If the module stored in the breakpoint is the currently processed module, use --- the 'ModBreaks' from the state. --- If that is 'Nothing', consider breakpoints to be disabled and skip the --- instruction. --- --- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph). --- If the module doesn't exist there, or if the 'ModBreaks' value is --- uninitialized, skip the instruction (i.e. return Nothing). -break_info :: - HscEnv -> - Module -> - Module -> - Maybe ModBreaks -> - BcM (Maybe ModBreaks) -break_info hsc_env mod current_mod current_mod_breaks - | mod == current_mod - = pure current_mod_breaks - | otherwise - = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case - Just hp -> pure $ imodBreaks_modBreaks <$> getModBreaks hp - Nothing -> pure Nothing - getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] getVarOffSets platform depth env = map getOffSet where @@ -652,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut schemeE d s p (StgCase scrut bndr _ alts) - = doCase d s p scrut bndr alts + = doCase d s p Nothing scrut bndr alts {- @@ -1144,11 +1111,15 @@ doCase :: StackDepth -> Sequel -> BCEnv + -> Maybe StgTickish + -- ^ The breakpoint surrounding the full case expression, if any (only + -- source-level cases get breakpoint ticks, and those are the only we care + -- about). See Note [TODO] -> CgStgExpr -> Id -> [CgStgAlt] -> BcM BCInstrList -doCase d s p scrut bndr alts +doCase d s p m_bid scrut bndr alts = do profile <- getProfile hsc_env <- getHscEnv @@ -1209,12 +1180,12 @@ doCase d s p scrut bndr alts -- depth of stack after the return value has been pushed d_bndr = - d + ret_frame_size_b + bndr_size + d + bndr_size -- depth of stack after the extra info table for an unlifted return -- has been pushed, if any. This is the stack depth at the -- continuation. - d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b + d_alts = d + bndr_size + unlifted_itbl_size_b -- Env in which to compile the alts, not including -- any vars bound by the alts themselves @@ -1365,11 +1336,28 @@ doCase d s p scrut bndr alts let alt_final1 | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 | otherwise = alt_final0 - alt_final - | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) - -- See Note [Debugger: BRK_ALTS] - = BRK_ALTS False `consOL` alt_final1 - | otherwise = alt_final1 + + alt_final <- case m_bid of + Just (Breakpoint tick_ty tick_id fvs) + | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) + -- Construct an internal breakpoint to put at the start of this case + -- continuation BCO. + -- See Note [TODO] + -> do + internal_tick_loc <- makeCaseInternalBreakLoc tick_id + + -- same fvs available in the case expression are available in the case continuation + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc) + + mibi <- newBreakInfo breakInfo + return $ case mibi of + Nothing -> alt_final1 + Just ibi -> {- BRK_FUN ibi (d_alts - d) `consOL` -} alt_final1 + _ -> pure alt_final1 add_bco_name <- shouldAddBcoName let @@ -1389,6 +1377,24 @@ doCase d s p scrut bndr alts _ -> panic "schemeE(StgCase).push_alts" in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) +makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc +makeCaseInternalBreakLoc bid = do + hug <- hsc_HUG <$> getHscEnv + curr_mod <- getCurrentModule + mb_mod_brks <- getCurrentModBreaks + + -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc + InternalBreakLoc <$> case bid of + BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == curr_mod + , Just these_mbs <- mb_mod_brks + -> do + return $ modBreaks_locs these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod + return $ modBreaks_locs other_mbs ! bi_tick_index + {- Note [Debugger: BRK_ALTS] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1756,6 +1762,10 @@ tupleBCO platform args_info args = with using a fake name here. We will need to change this if we want to save some memory by sharing the BCO between places that have the same tuple shape + + ROMES:TODO: This seems like it would have a pretty good impact. + Looking at examples like UnboxedTuple.hs shows many occurrences of the + same tuple_BCO -} invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") @@ -2705,14 +2715,19 @@ getLabelsBc n = BcM $ \_ st -> let ctr = nextlabel st in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) -newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \_ st -> - let ix = breakInfoIdx st - st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (ix, st') +newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId) +newBreakInfo info = BcM $ \env st -> do + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. + case modBreaks env of + Nothing -> pure (Nothing, st) + Just modBreaks -> do + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st') getCurrentModule :: BcM Module getCurrentModule = BcM $ \env st -> return (bcm_module env, st) @@ -2722,3 +2737,14 @@ getCurrentModBreaks = BcM $ \env st -> return (modBreaks env, st) tickFS :: FastString tickFS = fsLit "ticked" + +-- Dehydrating CgBreakInfo + +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo +dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid = + CgBreakInfo + { cgb_tyvars = map toIfaceTvBndr ty_vars + , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets + , cgb_resty = toIfaceType tick_ty + , cgb_tick_id = bid + } ===================================== compiler/Setup.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Main where import Distribution.Simple @@ -12,6 +13,8 @@ import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Simple.Setup import Distribution.Simple.PackageIndex +import qualified Distribution.Simple.LocalBuildInfo as LBI + import System.IO import System.Process @@ -59,8 +62,9 @@ primopIncls = ghcAutogen :: Verbosity -> LocalBuildInfo -> IO () ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap,installedPkgs} = do + let i = LBI.interpretSymbolicPathLBI lbi -- Get compiler/ root directory from the cabal file - let Just compilerRoot = takeDirectory <$> pkgDescrFile + let Just compilerRoot = takeDirectory . i <$> pkgDescrFile -- Require the necessary programs (gcc ,withPrograms) <- requireProgram normal gccProgram withPrograms @@ -80,15 +84,19 @@ ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameM -- Call genprimopcode to generate *.hs-incl forM_ primopIncls $ \(file,command) -> do contents <- readProcess "genprimopcode" [command] primopsStr - rewriteFileEx verbosity (buildDir lbi </> file) contents + rewriteFileEx verbosity (i (buildDir lbi) </> file) contents -- Write GHC.Platform.Constants - let platformConstantsPath = autogenPackageModulesDir lbi </> "GHC/Platform/Constants.hs" + let platformConstantsPath = i (autogenPackageModulesDir lbi) </> "GHC/Platform/Constants.hs" targetOS = case lookup "target os" settings of Nothing -> error "no target os in settings" Just os -> os createDirectoryIfMissingVerbose verbosity True (takeDirectory platformConstantsPath) +#if MIN_VERSION_Cabal(3,14,0) + withTempFile "Constants_tmp.hs" $ \tmp h -> do +#else withTempFile (takeDirectory platformConstantsPath) "Constants_tmp.hs" $ \tmp h -> do +#endif hClose h callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS] renameFile tmp platformConstantsPath @@ -103,7 +111,7 @@ ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameM _ -> error "Couldn't find unique ghc-internal library when building ghc" -- Write GHC.Settings.Config - configHsPath = autogenPackageModulesDir lbi </> "GHC/Settings/Config.hs" + configHsPath = i (autogenPackageModulesDir lbi) </> "GHC/Settings/Config.hs" configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath) rewriteFileEx verbosity configHsPath configHs ===================================== compiler/ghc.cabal.in ===================================== @@ -50,7 +50,7 @@ extra-source-files: custom-setup - setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.16, directory, process, filepath, containers Flag internal-interpreter Description: Build with internal interpreter support. ===================================== docs/users_guide/eventlog-formats.rst ===================================== @@ -779,9 +779,9 @@ the total time spent profiling. Cost-centre break-down ^^^^^^^^^^^^^^^^^^^^^^ -A variable-length packet encoding a heap profile sample broken down by, - * cost-centre (:rts-flag:`-hc`) - +A variable-length packet encoding a heap profile sample. +This event is only emitted when the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`. +Otherwise, a :event-type:`HEAP_PROF_SAMPLE_STRING` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_COST_CENTRE @@ -796,11 +796,19 @@ A variable-length packet encoding a heap profile sample broken down by, String break-down ^^^^^^^^^^^^^^^^^ -A variable-length event encoding a heap sample broken down by, +A variable-length event encoding a heap sample. +The content of the sample label varies depending on the heap profile type: + + * :rts-flag:`-hT` The sample label contains a closure type, e.g., ``"ghc-bignum:GHC.Num.Integer.IS"``. + * :rts-flag:`-hm` The sample label contains a module name, e.g., ``"GHC.Num.Integer"``. + * :rts-flag:`-hd` The sample label contains a closure description, e.g., ``"IS"``. + * :rts-flag:`-hy` The sample label contains a type description, e.g., ``"Integer"``. + * :rts-flag:`-he` The sample label contains a stringified era, e.g., ``"1"``. + * :rts-flag:`-hr` The sample label contains a retainer set description, e.g., ``"(184)$stoIntegralSized1"``. + * :rts-flag:`-hi` The sample label contains a stringified pointer, e.g., ``"0x1008b7588"``, + which can be matched to an info table description emitted by the :event-type:`IPE` event. - * type description (:rts-flag:`-hy`) - * closure description (:rts-flag:`-hd`) - * module (:rts-flag:`-hm`) +If the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`, a :event-type:`HEAP_PROF_SAMPLE_COST_CENTRE` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_STRING @@ -808,7 +816,7 @@ A variable-length event encoding a heap sample broken down by, :length: variable :field Word8: profile ID :field Word64: heap residency in bytes - :field String: type or closure description, or module name + :field String: sample label .. _time-profiler-events: ===================================== ghc/GHCi/UI.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv) import GHC.Runtime.Eval.Utils -- The GHC interface -import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks) +import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod) import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHCi.BreakArray( breakOn, breakOff ) @@ -68,7 +68,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, GetDocsFailure(..), pushLogHookM, getModuleGraph, handleSourceError, - InternalBreakpointId(..) ) + BreakpointId(..) ) import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp import GHC.Hs @@ -546,6 +546,7 @@ interactiveUI config srcs maybe_exprs = do break_ctr = 0, breaks = IntMap.empty, tickarrays = emptyModuleEnv, + internalBreaks = emptyModuleEnv, ghci_commands = availableCommands config, ghci_macros = [], last_command = Nothing, @@ -1616,13 +1617,15 @@ toBreakIdAndLocation :: GhciMonad m toBreakIdAndLocation Nothing = return Nothing toBreakIdAndLocation (Just inf) = do st <- getGHCiState + hug <- hsc_HUG <$> GHC.getSession + brks <- liftIO $ readIModBreaks hug inf + let bi = getBreakSourceId inf brks return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st), - breakModule loc == ibi_tick_mod inf, - breakTick loc == ibi_tick_index inf ] + Right (breakId loc) == bi ] printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m () printStoppedAtBreakInfo res names = do - printForUser $ pprStopped res + printForUser =<< pprStopped res -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted @@ -3804,22 +3807,32 @@ showBkptTable = do showContext :: GHC.GhcMonad m => m () showContext = do resumes <- GHC.getResumeContext - printForUser $ vcat (map pp_resume (reverse resumes)) + docs <- mapM pp_resume (reverse resumes) + printForUser $ vcat docs where - pp_resume res = - text "--> " <> text (GHC.resumeStmt res) - $$ nest 2 (pprStopped res) - -pprStopped :: GHC.Resume -> SDoc -pprStopped res = - text "Stopped in" - <+> ((case mb_mod_name of - Nothing -> empty - Just mod_name -> ftext (moduleNameFS mod_name) <> char '.') - <> text (GHC.resumeDecl res)) - <> char ',' <+> ppr (GHC.resumeSpan res) - where - mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res + pp_resume res = do + stopped <- pprStopped res + return $ + text "--> " <> text (GHC.resumeStmt res) + $$ nest 2 stopped + +pprStopped :: GHC.GhcMonad m => GHC.Resume -> m SDoc +pprStopped res = do + let mibi = GHC.resumeBreakpointId res + mb_mod_name <- case mibi of + Nothing -> pure Nothing + Just ibi -> do + hug <- hsc_HUG <$> GHC.getSession + brks <- liftIO $ readIModBreaks hug ibi + return $ Just $ moduleName $ + getBreakSourceMod ibi brks + return $ + text "Stopped in" + <+> ((case mb_mod_name of + Nothing -> empty + Just mod_name -> ftext (moduleNameFS mod_name) <> char '.') + <> text (GHC.resumeDecl res)) + <> char ',' <+> ppr (GHC.resumeSpan res) showUnits :: GHC.GhcMonad m => m () showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do @@ -4373,12 +4386,8 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do result <- ignoreSwitch (words argLine) case result of Left sdoc -> printForUser sdoc - Right (loc, count) -> do - let bi = GHC.BreakpointId - { bi_tick_mod = breakModule loc - , bi_tick_index = breakTick loc - } - setupBreakpoint bi count + Right (loc, count) -> do + setupBreakpoint (breakId loc) count ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int)) ignoreSwitch [break, count] = do @@ -4395,10 +4404,13 @@ getIgnoreCount str = where sdocIgnore = text "Ignore count" <+> quotes (text str) -setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m() -setupBreakpoint loc count = do +setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m () +setupBreakpoint bi count = do hsc_env <- GHC.getSession - GHC.setupBreakpoint (hscInterp hsc_env) loc count + -- Trigger all internal breaks that match this source break id + internal_break_ids <- getInternalBreaksOf bi + forM_ internal_break_ids $ \ibi -> do + GHC.setupBreakpoint (hscInterp hsc_env) ibi count backCmd :: GhciMonad m => String -> m () backCmd arg @@ -4489,20 +4501,20 @@ findBreakAndSet md lookupTickTree = do some -> mapM_ breakAt some where breakAt (tick, pan) = do - setBreakFlag md tick True - (alreadySet, nm) <- - recordBreak $ BreakLocation - { breakModule = md - , breakLoc = RealSrcSpan pan Strict.Nothing - , breakTick = tick - , onBreakCmd = "" - , breakEnabled = True - } - printForUser $ - text "Breakpoint " <> ppr nm <> - if alreadySet - then text " was already set at " <> ppr pan - else text " activated at " <> ppr pan + let bi = BreakpointId md tick + setBreakFlag bi True + (alreadySet, nm) <- + recordBreak $ BreakLocation + { breakLoc = RealSrcSpan pan Strict.Nothing + , breakId = bi + , onBreakCmd = "" + , breakEnabled = True + } + printForUser $ + text "Breakpoint " <> ppr nm <> + if alreadySet + then text " was already set at " <> ppr pan + else text " activated at " <> ppr pan -- For now, use ANSI bold on terminals that we know support it. -- Otherwise, we add a line of carets under the active expression instead. @@ -4749,14 +4761,32 @@ turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation turnBreakOnOff onOff loc | onOff == breakEnabled loc = return loc | otherwise = do - setBreakFlag (breakModule loc) (breakTick loc) onOff + setBreakFlag (breakId loc) onOff return loc { breakEnabled = onOff } -setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m () -setBreakFlag md ix enaDisa = do +setBreakFlag :: GhciMonad m => GHC.BreakpointId -> Bool -> m () +setBreakFlag (BreakpointId md ix) enaDisa = do let enaDisaToCount True = breakOn enaDisaToCount False = breakOff - setupBreakpoint (GHC.BreakpointId md ix) $ enaDisaToCount enaDisa + setupBreakpoint (BreakpointId md ix) $ enaDisaToCount enaDisa + +-- -------------------------------------------------------------------------- +-- Find matching Internal Breakpoints + +-- | Find all the internal breakpoints that use the given source-level breakpoint id +getInternalBreaksOf :: GhciMonad m => BreakpointId -> m [InternalBreakpointId] +getInternalBreaksOf bi = do + st <- getGHCiState + let ibrks = internalBreaks st + case lookupBreakpointOccurrences ibrks bi of + Just bs -> return bs + Nothing -> do + -- Refresh the internal breakpoints map + bs <- mkBreakpointOccurrences + setGHCiState st{internalBreaks = bs} + return $ + fromMaybe [] {- still not found after refresh -} $ + lookupBreakpointOccurrences bs bi -- --------------------------------------------------------------------------- -- User code exception handling ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -100,6 +100,14 @@ data GHCiState = GHCiState -- ^ 'tickarrays' caches the 'TickArray' for loaded modules, -- so that we don't rebuild it each time the user sets -- a breakpoint. + + internalBreaks :: BreakpointOccurrences, + -- ^ Keep a mapping from the source-level 'BreakpointId' to the + -- occurrences of that breakpoint across modules. + -- When we want to stop at a source 'BreakpointId', we essentially + -- trigger a breakpoint for all 'InternalBreakpointId's matching + -- the same source-id. + ghci_commands :: [Command], -- ^ available ghci commands ghci_macros :: [Command], @@ -238,16 +246,15 @@ data LocalConfigBehaviour data BreakLocation = BreakLocation - { breakModule :: !GHC.Module - , breakLoc :: !SrcSpan - , breakTick :: {-# UNPACK #-} !Int + { breakLoc :: !SrcSpan + , breakId :: !GHC.BreakpointId + -- ^ The 'BreakpointId' uniquely identifies a source-level breakpoint , breakEnabled:: !Bool , onBreakCmd :: String } instance Eq BreakLocation where - loc1 == loc2 = breakModule loc1 == breakModule loc2 && - breakTick loc1 == breakTick loc2 + loc1 == loc2 = breakId loc1 == breakId loc2 prettyLocations :: IntMap.IntMap BreakLocation -> SDoc prettyLocations locs = @@ -256,7 +263,7 @@ prettyLocations locs = False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs instance Outputable BreakLocation where - ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+> + ppr loc = (ppr $ GHC.bi_tick_mod $ breakId loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+> if null (onBreakCmd loc) then empty else doubleQuotes (text (onBreakCmd loc)) ===================================== libraries/ghc-boot/Setup.hs ===================================== @@ -10,6 +10,7 @@ import Distribution.Verbosity import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Simple.Setup +import qualified Distribution.Simple.LocalBuildInfo as LBI import System.IO import System.Directory @@ -32,12 +33,13 @@ main = defaultMainWithHooks ghcHooks ghcAutogen :: Verbosity -> LocalBuildInfo -> IO () ghcAutogen verbosity lbi@LocalBuildInfo{..} = do -- Get compiler/ root directory from the cabal file - let Just compilerRoot = takeDirectory <$> pkgDescrFile + let Just compilerRoot = takeDirectory . i <$> pkgDescrFile - let platformHostFile = "GHC/Platform/Host.hs" - platformHostPath = autogenPackageModulesDir lbi </> platformHostFile + i = LBI.interpretSymbolicPathLBI lbi + platformHostFile = "GHC/Platform/Host.hs" + platformHostPath = i (autogenPackageModulesDir lbi) </> platformHostFile ghcVersionFile = "GHC/Version.hs" - ghcVersionPath = autogenPackageModulesDir lbi </> ghcVersionFile + ghcVersionPath = i (autogenPackageModulesDir lbi) </> ghcVersionFile -- Get compiler settings settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -28,7 +28,7 @@ build-type: Custom extra-source-files: changelog.md custom-setup - setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, filepath + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.16, directory, filepath source-repository head type: git ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1047,7 +1047,7 @@ class Functor f where -- * sequence computations and combine their results ('<*>' and 'liftA2'). -- -- A minimal complete definition must include implementations of 'pure' --- and of either '<*>' or 'liftA2'. If it defines both, then they must behave +-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ ===================================== libraries/ghci/GHCi/Debugger.hs ===================================== @@ -65,10 +65,7 @@ foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt -------------------------------------------------------------------------------- type BreakpointCallback - = Addr# -- pointer to the breakpoint tick module name - -> Addr# -- pointer to the breakpoint tick module unit id - -> Int# -- breakpoint tick index - -> Addr# -- pointer to the breakpoint info module name + = Addr# -- pointer to the breakpoint info module name -> Addr# -- pointer to the breakpoint info module unit id -> Int# -- breakpoint info index -> Bool -- exception? ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -418,10 +418,7 @@ data EvalStatus_ a b instance Binary a => Binary (EvalStatus_ a b) data EvalBreakpoint = EvalBreakpoint - { eb_tick_mod :: String -- ^ Breakpoint tick module - , eb_tick_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id - , eb_tick_index :: Int -- ^ Breakpoint tick index - , eb_info_mod :: String -- ^ Breakpoint info module + { eb_info_mod :: String -- ^ Breakpoint info module , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id , eb_info_index :: Int -- ^ Breakpoint info index } ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -345,7 +345,7 @@ withBreakAction opts breakMVar statusMVar mtid act -- as soon as it is hit, or in resetBreakAction below. onBreak :: BreakpointCallback - onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do + onBreak info_mod# info_mod_uid# infox# is_exception apStack = do tid <- myThreadId let resume = ResumeContext { resumeBreakMVar = breakMVar @@ -358,11 +358,9 @@ withBreakAction opts breakMVar statusMVar mtid act if is_exception then pure Nothing else do - tick_mod <- peekCString (Ptr tick_mod#) - tick_mod_uid <- BS.packCString (Ptr tick_mod_uid#) info_mod <- peekCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) - pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#))) + pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs takeMVar breakMVar @@ -409,8 +407,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction noBreakAction :: BreakpointCallback -noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint" -noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue +noBreakAction _ _ _ False _ = putStrLn "*** Ignoring breakpoint" +noBreakAction _ _ _ True _ = return () -- exception: just continue -- Malloc and copy the bytes. We don't have any way to monitor the -- lifetime of this memory, so it just leaks. ===================================== rts/Disassembler.c ===================================== @@ -84,16 +84,25 @@ disInstr ( StgBCO *bco, int pc ) switch (instr & 0xff) { - case bci_BRK_FUN: - debugBelch ("BRK_FUN " ); printPtr( ptrs[instrs[pc]] ); - debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); - CostCentre* cc = (CostCentre*)literals[instrs[pc+5]]; + case bci_BRK_FUN: { + W_ p1, info_mod, info_unit_id, info_wix, byte_off, np; + p1 = BCO_GET_LARGE_ARG; + info_mod = BCO_GET_LARGE_ARG; + info_unit_id = BCO_GET_LARGE_ARG; + info_wix = BCO_NEXT; + byte_off = BCO_NEXT; + np = BCO_GET_LARGE_ARG; + debugBelch ("BRK_FUN " ); printPtr( ptrs[p1] ); + debugBelch(" %" FMT_Word, literals[info_mod] ); + debugBelch(" %" FMT_Word, literals[info_unit_id] ); + debugBelch(" %" FMT_Word, info_wix ); + debugBelch(" %" FMT_Word, byte_off ); + CostCentre* cc = (CostCentre*)literals[np]; if (cc) { debugBelch(" %s", cc->label); } debugBelch("\n"); - pc += 6; - break; + break; } case bci_BRK_ALTS: debugBelch ("BRK_ALTS %d\n", BCO_NEXT); break; ===================================== rts/Exception.cmm ===================================== @@ -535,23 +535,17 @@ retry_pop_stack: // be per-thread. CInt[rts_stop_on_exception] = 0; ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr"); - Sp = Sp - WDS(17); - Sp(16) = exception; - Sp(15) = stg_raise_ret_info; - Sp(14) = exception; - Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception - Sp(12) = stg_ap_ppv_info; - Sp(11) = 0; - Sp(10) = stg_ap_n_info; - Sp(9) = 0; - Sp(8) = stg_ap_n_info; - Sp(7) = 0; - Sp(6) = stg_ap_n_info; - Sp(5) = 0; - Sp(4) = stg_ap_n_info; - Sp(3) = 0; - Sp(2) = stg_ap_n_info; - Sp(1) = 0; + Sp = Sp - WDS(11); + Sp(10) = exception; + Sp(9) = stg_raise_ret_info; + Sp(8) = exception; + Sp(7) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception + Sp(6) = stg_ap_ppv_info; + Sp(5) = 0; + Sp(4) = stg_ap_n_info; + Sp(3) = 0; + Sp(2) = stg_ap_n_info; + Sp(1) = 0; R1 = ioAction; jump RET_LBL(stg_ap_n) [R1]; } ===================================== rts/Interpreter.c ===================================== @@ -207,6 +207,19 @@ See also Note [Width of parameters] for some more motivation. // Perhaps confusingly this still reads a full word, merely the offset is in bytes. #define ReadSpB(n) (*((StgWord*) SafeSpBP(n))) +/* + * SLIDE "n" words "by" words + * a_1 ... a_n, b_1 ... b_by, k + * => + * a_1 ... a_n, k + */ +#define SpSlide(n, by) \ + while(n-- > 0) { \ + SpW(n+by) = ReadSpW(n); \ + } \ + Sp_addW(by); \ + + /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ BCOs can be nested, resulting in nested BCO stack frames where the inner most @@ -284,6 +297,19 @@ allocate_NONUPD (Capability *cap, int n_words) return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } +STATIC_INLINE int +is_ctoi_nontuple_frame(const StgClosure* frame) { + const StgInfoTable* info = frame->header.info; + return ( + (W_)info == (W_)&stg_ctoi_R1p_info || + (W_)info == (W_)&stg_ctoi_R1n_info || + (W_)info == (W_)&stg_ctoi_F1_info || + (W_)info == (W_)&stg_ctoi_D1_info || + (W_)info == (W_)&stg_ctoi_L1_info || + (W_)info == (W_)&stg_ctoi_V_info + ); +} + int rts_stop_on_exception = 0; /* --------------------------------------------------------------------------- @@ -473,6 +499,72 @@ void interp_shutdown( void ){ #endif +const StgPtr ctoi_tuple_infos[] = { + (StgPtr) &stg_ctoi_t0_info, + (StgPtr) &stg_ctoi_t1_info, + (StgPtr) &stg_ctoi_t2_info, + (StgPtr) &stg_ctoi_t3_info, + (StgPtr) &stg_ctoi_t4_info, + (StgPtr) &stg_ctoi_t5_info, + (StgPtr) &stg_ctoi_t6_info, + (StgPtr) &stg_ctoi_t7_info, + (StgPtr) &stg_ctoi_t8_info, + (StgPtr) &stg_ctoi_t9_info, + (StgPtr) &stg_ctoi_t10_info, + (StgPtr) &stg_ctoi_t11_info, + (StgPtr) &stg_ctoi_t12_info, + (StgPtr) &stg_ctoi_t13_info, + (StgPtr) &stg_ctoi_t14_info, + (StgPtr) &stg_ctoi_t15_info, + (StgPtr) &stg_ctoi_t16_info, + (StgPtr) &stg_ctoi_t17_info, + (StgPtr) &stg_ctoi_t18_info, + (StgPtr) &stg_ctoi_t19_info, + (StgPtr) &stg_ctoi_t20_info, + (StgPtr) &stg_ctoi_t21_info, + (StgPtr) &stg_ctoi_t22_info, + (StgPtr) &stg_ctoi_t23_info, + (StgPtr) &stg_ctoi_t24_info, + (StgPtr) &stg_ctoi_t25_info, + (StgPtr) &stg_ctoi_t26_info, + (StgPtr) &stg_ctoi_t27_info, + (StgPtr) &stg_ctoi_t28_info, + (StgPtr) &stg_ctoi_t29_info, + (StgPtr) &stg_ctoi_t30_info, + (StgPtr) &stg_ctoi_t31_info, + (StgPtr) &stg_ctoi_t32_info, + (StgPtr) &stg_ctoi_t33_info, + (StgPtr) &stg_ctoi_t34_info, + (StgPtr) &stg_ctoi_t35_info, + (StgPtr) &stg_ctoi_t36_info, + (StgPtr) &stg_ctoi_t37_info, + (StgPtr) &stg_ctoi_t38_info, + (StgPtr) &stg_ctoi_t39_info, + (StgPtr) &stg_ctoi_t40_info, + (StgPtr) &stg_ctoi_t41_info, + (StgPtr) &stg_ctoi_t42_info, + (StgPtr) &stg_ctoi_t43_info, + (StgPtr) &stg_ctoi_t44_info, + (StgPtr) &stg_ctoi_t45_info, + (StgPtr) &stg_ctoi_t46_info, + (StgPtr) &stg_ctoi_t47_info, + (StgPtr) &stg_ctoi_t48_info, + (StgPtr) &stg_ctoi_t49_info, + (StgPtr) &stg_ctoi_t50_info, + (StgPtr) &stg_ctoi_t51_info, + (StgPtr) &stg_ctoi_t52_info, + (StgPtr) &stg_ctoi_t53_info, + (StgPtr) &stg_ctoi_t54_info, + (StgPtr) &stg_ctoi_t55_info, + (StgPtr) &stg_ctoi_t56_info, + (StgPtr) &stg_ctoi_t57_info, + (StgPtr) &stg_ctoi_t58_info, + (StgPtr) &stg_ctoi_t59_info, + (StgPtr) &stg_ctoi_t60_info, + (StgPtr) &stg_ctoi_t61_info, + (StgPtr) &stg_ctoi_t62_info, +}; + #if defined(PROFILING) // @@ -619,8 +711,6 @@ interpretBCO (Capability* cap) */ if (cap->r.rCurrentTSO->flags & TSO_STOP_AFTER_RETURN) { - StgBCO* bco; - StgWord16* bco_instrs; StgHalfWord type; /* Store the entry Sp; traverse the stack modifying Sp (using Sp macros); @@ -640,28 +730,34 @@ interpretBCO (Capability* cap) ASSERT(type == RET_BCO || type == STOP_FRAME); if (type == RET_BCO) { - bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO + StgBCO* bco = (StgBCO*)(SpW(1)); // BCO is first arg of a RET_BCO ASSERT(get_itbl((StgClosure*)bco)->type == BCO); - bco_instrs = (StgWord16*)(bco->instrs->payload); + + StgWord16* instrs = (StgWord16*)(bco->instrs->payload); + StgWord16 bci = instrs[0]; /* A breakpoint instruction (BRK_FUN or BRK_ALTS) is always the first * instruction in a BCO */ - if ((bco_instrs[0] & 0xFF) == bci_BRK_FUN) { - int brk_array, tick_index; - StgArrBytes *breakPoints; - StgPtr* ptrs; + if ((bci & 0xFF) == bci_BRK_FUN) { + // Define rest of variables used by BCO_* Macros + int bciPtr = 0; - ptrs = (StgPtr*)(&bco->ptrs->payload[0]); - brk_array = bco_instrs[1]; - tick_index = bco_instrs[6]; + W_ arg1_brk_array, arg4_info_index; + arg1_brk_array = BCO_GET_LARGE_ARG; + /* info_mod_name = */ BCO_GET_LARGE_ARG; + /* info_mod_id = */ BCO_GET_LARGE_ARG; + arg4_info_index = BCO_NEXT; + /* byte_off = BCO_NEXT; */ + + StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + StgArrBytes* breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); - breakPoints = (StgArrBytes *) BCO_PTR(brk_array); // ACTIVATE the breakpoint by tick index - ((StgInt*)breakPoints->payload)[tick_index] = 0; + ((StgInt*)breakPoints->payload)[arg4_info_index] = 0; } - else if ((bco_instrs[0] & 0xFF) == bci_BRK_ALTS) { + else if ((bci & 0xFF) == bci_BRK_ALTS) { // ACTIVATE BRK_ALTS by setting its only argument to ON - bco_instrs[1] = 1; + instrs[1] = 1; } // else: if there is no BRK instruction perhaps we should keep // traversing; that said, the continuation should always have a BRK @@ -776,7 +872,6 @@ eval_obj: debugBelch("\n\n"); ); -// IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); IF_DEBUG(sanity,checkStackFrame(Sp)); switch ( get_itbl(obj)->type ) { @@ -1018,11 +1113,36 @@ do_return_pointer: // Returning to an interpreted continuation: put the object on // the stack, and start executing the BCO. INTERP_TICK(it_retto_BCO); - Sp_subW(1); - SpW(0) = (W_)tagged_obj; - obj = (StgClosure*)ReadSpW(2); + obj = (StgClosure*)ReadSpW(1); ASSERT(get_itbl(obj)->type == BCO); - goto run_BCO_return_pointer; + + // Heap check + if (doYouWantToGC(cap)) { + Sp_subW(2); + SpW(1) = (W_)tagged_obj; + SpW(0) = (W_)&stg_ret_p_info; + RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); + } + else { + + // Stack checks aren't necessary at return points, the stack use + // is aggregated into the enclosing function entry point. + + // Make sure to drop the RET_BCO frame header, + // but not its arguments (which are expected at the top when running the BCO). + // NOTE: Always a return_pointer (ie not a tuple ctoi frame!) + + // Make sure stack is headed by a ctoi nontuple frame then drop it. + // The arguments to the BCO continuation stay on top of the stack + ASSERT(is_ctoi_nontuple_frame(Sp)); + Sp_addW(2); + + // Plus the return value on top of the args + Sp_subW(1); + SpW(0) = (W_)tagged_obj; + } + + goto run_BCO; default: do_return_unrecognised: @@ -1091,8 +1211,9 @@ do_return_nonpointer: // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); + StgClosure* next_frame = (StgClosure*)(SafeSpWP(offset)); - switch (get_itbl((StgClosure*)(SafeSpWP(offset)))->type) { + switch (get_itbl(next_frame)->type) { case RET_BCO: // Returning to an interpreted continuation: pop the return frame @@ -1100,8 +1221,72 @@ do_return_nonpointer: // executing the BCO. INTERP_TICK(it_retto_BCO); obj = (StgClosure*)ReadSpW(offset+1); + ASSERT(get_itbl(obj)->type == BCO); - goto run_BCO_return_nonpointer; + + // Heap check + if (doYouWantToGC(cap)) { + RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); + } + else { + // Stack checks aren't necessary at return points, the stack use + // is aggregated into the enclosing function entry point. + +#if defined(PROFILING) + /* + Restore the current cost centre stack if a tuple is being returned. + + When a "simple" unlifted value is returned, the cccs is restored with + an stg_restore_cccs frame on the stack, for example: + + ... + stg_ctoi_D1 + <CCCS> + stg_restore_cccs + + But stg_restore_cccs cannot deal with tuples, which may have more + things on the stack. Therefore we store the CCCS inside the + stg_ctoi_t frame. + + If we have a tuple being returned, the stack looks like this: + + ... + <CCCS> <- to restore, Sp offset <next frame + 4 words> + tuple_BCO + tuple_info + cont_BCO + stg_ctoi_t <- next frame + tuple_data_1 + ... + tuple_data_n + tuple_info + tuple_BCO + stg_ret_t <- Sp + */ + + if(SpW(0) == (W_)&stg_ret_t_info) { + cap->r.rCCCS = (CostCentreStack*)ReadSpW(stack_frame_sizeW((StgClosure *)Sp) + 4); + } +#endif + /* Drop the RET_BCO header (next_frame), + * but not its arguments (which are expected at the top when running the BCO) + */ + W_ n = offset; + W_ by = is_ctoi_nontuple_frame(next_frame) + ? 2 // info+bco +#if defined(PROFILING) + : 5; // or info+bco+tuple_info+tuple_BCO+CCS +#else + : 4; // or info+bco+tuple_info+tuple_BCO +#endif + SpSlide(n, by); + + if (SpW(0) != (W_)&stg_ret_t_info) { + Sp_addW(1); + } + + goto run_BCO; + } default: { @@ -1268,8 +1453,8 @@ do_apply: // Ok, we now have a bco (obj), and its arguments are all on the // stack. We can start executing the byte codes. // - // The stack is in one of two states. First, if this BCO is a - // function: + // The stack is in one of two states. First, if this BCO is a + // function // // | .... | // +---------------+ @@ -1286,10 +1471,6 @@ do_apply: // +---------------+ // | fv1 | // +---------------+ - // | BCO | - // +---------------+ - // | stg_ctoi_ret_ | - // +---------------+ // | retval | // +---------------+ // @@ -1307,68 +1488,6 @@ do_apply: // Sadly we have three different kinds of stack/heap/cswitch check // to do: - -run_BCO_return_pointer: - // Heap check - if (doYouWantToGC(cap)) { - Sp_subW(1); SpW(0) = (W_)&stg_ret_p_info; - RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); - } - // Stack checks aren't necessary at return points, the stack use - // is aggregated into the enclosing function entry point. - - goto run_BCO; - -run_BCO_return_nonpointer: - // Heap check - if (doYouWantToGC(cap)) { - RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); - } - // Stack checks aren't necessary at return points, the stack use - // is aggregated into the enclosing function entry point. - -#if defined(PROFILING) - /* - Restore the current cost centre stack if a tuple is being returned. - - When a "simple" unlifted value is returned, the cccs is restored with - an stg_restore_cccs frame on the stack, for example: - - ... - stg_ctoi_D1 - <CCCS> - stg_restore_cccs - - But stg_restore_cccs cannot deal with tuples, which may have more - things on the stack. Therefore we store the CCCS inside the - stg_ctoi_t frame. - - If we have a tuple being returned, the stack looks like this: - - ... - <CCCS> <- to restore, Sp offset <next frame + 4 words> - tuple_BCO - tuple_info - cont_BCO - stg_ctoi_t <- next frame - tuple_data_1 - ... - tuple_data_n - tuple_info - tuple_BCO - stg_ret_t <- Sp - */ - - if(SpW(0) == (W_)&stg_ret_t_info) { - cap->r.rCCCS = (CostCentreStack*)ReadSpW(stack_frame_sizeW((StgClosure *)Sp) + 4); - } -#endif - - if (SpW(0) != (W_)&stg_ret_t_info) { - Sp_addW(1); - } - goto run_BCO; - run_BCO_fun: IF_DEBUG(sanity, Sp_subW(2); @@ -1454,9 +1573,9 @@ run_BCO: /* check for a breakpoint on the beginning of a let binding */ case bci_BRK_FUN: { - int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index; + W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index, arg5_byte_off; #if defined(PROFILING) - int arg8_cc; + W_ arg6_cc; #endif StgArrBytes *breakPoints; int returning_from_break, stop_next_breakpoint; @@ -1471,14 +1590,12 @@ run_BCO: int size_words; arg1_brk_array = BCO_GET_LARGE_ARG; - arg2_tick_mod = BCO_GET_LARGE_ARG; - arg3_info_mod = BCO_GET_LARGE_ARG; - arg4_tick_mod_id = BCO_GET_LARGE_ARG; - arg5_info_mod_id = BCO_GET_LARGE_ARG; - arg6_tick_index = BCO_NEXT; - arg7_info_index = BCO_NEXT; + arg2_info_mod_name = BCO_GET_LARGE_ARG; + arg3_info_mod_id = BCO_GET_LARGE_ARG; + arg4_info_index = BCO_NEXT; + arg5_byte_off = BCO_NEXT; #if defined(PROFILING) - arg8_cc = BCO_GET_LARGE_ARG; + arg6_cc = BCO_GET_LARGE_ARG; #else BCO_GET_LARGE_ARG; #endif @@ -1498,7 +1615,7 @@ run_BCO: #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, - (CostCentre*)BCO_LIT(arg8_cc)); + (CostCentre*)BCO_LIT(arg6_cc)); #endif // if we are returning from a break then skip this section @@ -1509,11 +1626,11 @@ run_BCO: // stop the current thread if either `stop_next_breakpoint` is // true OR if the ignore count for this particular breakpoint is zero - StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; + StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_info_index]; if (stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count - ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; + ((StgInt*)breakPoints->payload)[arg4_info_index] = --ignore_count; } else if (stop_next_breakpoint == true || ignore_count == 0) { @@ -1538,7 +1655,12 @@ run_BCO: // copy the contents of the top stack frame into the AP_STACK for (i = 2; i < size_words; i++) { - new_aps->payload[i] = (StgClosure *)ReadSpW(i-2); + // BAD ASSUMPTION: BITMAP Vars are on top of the stack. + // THEY ARE NOT FOR PUSH_ALTS: + // THE FIRST THING ON THE STACK IS GOING TO BE + // ctoi_*** + //TODO UPDATE DOCUMENTATION EXPLANING ARG5_BYTE_OFF + new_aps->payload[i] = (StgClosure *)ReadSpB(((ptrdiff_t)(i-2) * (ptrdiff_t)sizeof(W_)) + arg5_byte_off); } // No write barrier is needed here as this is a new allocation @@ -1547,10 +1669,7 @@ run_BCO: // Arrange the stack to call the breakpoint IO action, and // continue execution of this BCO when the IO action returns. // - // ioAction :: Addr# -- the breakpoint tick module - // -> Addr# -- the breakpoint tick module unit id - // -> Int# -- the breakpoint tick index - // -> Addr# -- the breakpoint info module + // ioAction :: Addr# -- the breakpoint info module // -> Addr# -- the breakpoint info module unit id // -> Int# -- the breakpoint info index // -> Bool -- exception? @@ -1560,23 +1679,17 @@ run_BCO: ioAction = (StgClosure *) deRefStablePtr ( rts_breakpoint_io_action); - Sp_subW(19); - SpW(18) = (W_)obj; - SpW(17) = (W_)&stg_apply_interp_info; - SpW(16) = (W_)new_aps; - SpW(15) = (W_)False_closure; // True <=> an exception - SpW(14) = (W_)&stg_ap_ppv_info; - SpW(13) = (W_)arg7_info_index; - SpW(12) = (W_)&stg_ap_n_info; - SpW(11) = (W_)BCO_LIT(arg5_info_mod_id); - SpW(10) = (W_)&stg_ap_n_info; - SpW(9) = (W_)BCO_LIT(arg3_info_mod); - SpW(8) = (W_)&stg_ap_n_info; - SpW(7) = (W_)arg6_tick_index; + Sp_subW(13); + SpW(12) = (W_)obj; + SpW(11) = (W_)&stg_apply_interp_info; + SpW(10) = (W_)new_aps; + SpW(9) = (W_)False_closure; // True <=> an exception + SpW(8) = (W_)&stg_ap_ppv_info; + SpW(7) = (W_)arg4_info_index; SpW(6) = (W_)&stg_ap_n_info; - SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id); + SpW(5) = (W_)BCO_LIT(arg3_info_mod_id); SpW(4) = (W_)&stg_ap_n_info; - SpW(3) = (W_)BCO_LIT(arg2_tick_mod); + SpW(3) = (W_)BCO_LIT(arg2_info_mod_name); SpW(2) = (W_)&stg_ap_n_info; SpW(1) = (W_)ioAction; SpW(0) = (W_)&stg_enter_info; @@ -1742,6 +1855,10 @@ run_BCO: Sp_subW(2); SpW(1) = BCO_PTR(o_bco); SpW(0) = (W_)&stg_ctoi_R1p_info; + + // The o_bco expects its arguments (as per the BCO_BITMAP_SIZE) to + // be found on the stack before it. + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1755,6 +1872,8 @@ run_BCO: SpW(-2) = (W_)&stg_ctoi_R1n_info; SpW(-1) = BCO_PTR(o_bco); Sp_subW(2); + + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1768,6 +1887,8 @@ run_BCO: SpW(-2) = (W_)&stg_ctoi_F1_info; SpW(-1) = BCO_PTR(o_bco); Sp_subW(2); + + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1781,6 +1902,8 @@ run_BCO: SpW(-2) = (W_)&stg_ctoi_D1_info; SpW(-1) = BCO_PTR(o_bco); Sp_subW(2); + + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1794,6 +1917,8 @@ run_BCO: SpW(-2) = (W_)&stg_ctoi_L1_info; SpW(-1) = BCO_PTR(o_bco); Sp_subW(2); + + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1807,6 +1932,8 @@ run_BCO: SpW(-2) = (W_)&stg_ctoi_V_info; SpW(-1) = BCO_PTR(o_bco); Sp_subW(2); + + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) Sp_subW(2); SpW(1) = (W_)cap->r.rCCCS; @@ -1820,6 +1947,7 @@ run_BCO: W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG); W_ o_tuple_bco = BCO_GET_LARGE_ARG; + IF_DEBUG(sanity, checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);); #if defined(PROFILING) SpW(-1) = (W_)cap->r.rCCCS; Sp_subW(1); @@ -1828,82 +1956,11 @@ run_BCO: SpW(-1) = BCO_PTR(o_tuple_bco); SpW(-2) = tuple_info; SpW(-3) = BCO_PTR(o_bco); - W_ ctoi_t_offset; int tuple_stack_words = (tuple_info >> 24) & 0xff; - switch(tuple_stack_words) { - case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break; - case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break; - case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break; - case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break; - case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break; - case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break; - case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break; - case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break; - case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break; - case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break; - - case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break; - case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break; - case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break; - case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break; - case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break; - case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break; - case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break; - case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break; - case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break; - case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break; - - case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break; - case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break; - case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break; - case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break; - case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break; - case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break; - case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break; - case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break; - case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break; - case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break; - - case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break; - case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break; - case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break; - case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break; - case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break; - case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break; - case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break; - case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break; - case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break; - case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break; - - case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break; - case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break; - case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break; - case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break; - case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break; - case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break; - case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break; - case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break; - case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break; - case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break; - - case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break; - case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break; - case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break; - case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break; - case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break; - case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break; - case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break; - case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break; - case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break; - case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break; - - case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break; - case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break; - case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break; - - default: barf("unsupported tuple size %d", tuple_stack_words); + if (tuple_stack_words > 62) { + barf("unsupported tuple size %d", tuple_stack_words); } - + W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words]; SpW(-4) = ctoi_t_offset; Sp_subW(4); goto nextInsn; @@ -1996,15 +2053,7 @@ run_BCO: case bci_SLIDE: { W_ n = BCO_GET_LARGE_ARG; W_ by = BCO_GET_LARGE_ARG; - /* - * a_1 ... a_n, b_1 ... b_by, k - * => - * a_1 ... a_n, k - */ - while(n-- > 0) { - SpW(n+by) = ReadSpW(n); - } - Sp_addW(by); + SpSlide(n, by); INTERP_TICK(it_slides); goto nextInsn; } ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -147,7 +147,7 @@ test('T25932', extra_files(['T25932.hs']), ghci_script, ['T25932.script']) # Step out tests test('T26042b', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042b.hs'])], ghci_script, ['T26042b.script']) -test('T26042c', [expect_broken(26042),extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script']) +test('T26042c', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script']) test('T26042d', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d.hs'])], ghci_script, ['T26042d.script']) test('T26042e', extra_files(['T26042e.hs']), ghci_script, ['T26042e.script']) test('T26042f1', extra_files(['T26042f.hs', 'T26042f.script']), ghci_script, ['T26042f.script']) # >> is not inlined, so stepout has nowhere to stop View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef66785749d8714122e529ac148bea7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef66785749d8714122e529ac148bea7... You're receiving this email because of your account on gitlab.haskell.org.