Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC Commits: aa8de259 by Cheng Shao at 2025-06-27T10:42:13+01:00 compiler: make ModBreaks serializable - - - - - 9d5e8eab by Rodrigo Mesquita at 2025-06-27T15:35:39+01:00 Mais... - - - - - 15 changed files: - compiler/GHC.hs - 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/Driver/Main.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -408,6 +408,8 @@ import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst ) import GHC.Core.InstEnv import GHC.Core +import GHC.HsToCore.Breakpoints + import GHC.Data.Maybe import GHC.Types.Id @@ -427,7 +429,6 @@ import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env import GHC.Types.TypeEnv -import GHC.Types.Breakpoint import GHC.Types.PkgQual import GHC.Unit ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -28,7 +28,6 @@ import GHC.Prelude hiding ( any ) import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types -import GHCi.RemoteTypes import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) import GHC.Types.Name @@ -843,12 +842,12 @@ assembleI platform i = case i of W8 -> emit_ bci_OP_INDEX_ADDR_08 [] _ -> unsupported_width - BRK_FUN arr (InternalBreakpointId info_mod infox) cc -> do - p1 <- ptr (BCOPtrBreakArray arr) + BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do + p1 <- ptr $ BCOPtrBreakArray info_mod info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod info_wix <- int infox - np <- addr cc + np <- lit1 $ BCONPtrCostCentre ibi emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr , Op info_wix, Op np ] @@ -892,7 +891,6 @@ assembleI platform i = case i of literal (LitRubbish {}) = word 0 litlabel fs = lit1 (BCONPtrLbl fs) - addr (RemotePtr a) = word (fromIntegral a) words ws = lit (fmap BCONPtrWord ws) word w = words (OnlyOne w) word2 w1 w2 = words (OnlyTwo w1 w2) ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -10,7 +10,7 @@ -- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] module GHC.ByteCode.Breakpoints ( -- * Internal Mod Breaks - InternalModBreaks(imodBreaks_breakInfo), CgBreakInfo(..) + InternalModBreaks(..), CgBreakInfo(..) , mkInternalModBreaks -- ** Operations @@ -114,12 +114,12 @@ data InternalBreakpointId = InternalBreakpointId -- 'InternalModBreaks' are constructed during bytecode generation and stored in -- 'CompiledByteCode' afterwards. data InternalModBreaks = InternalModBreaks - { imodBreaks_breakInfo :: IntMap CgBreakInfo + { imodBreaks_breakInfo :: !(IntMap CgBreakInfo) -- ^ Access code-gen time information about a breakpoint, indexed by -- 'InternalBreakpointId'. - , imodBreaks_module :: !Module - -- ^ Cache the module corresponding to these 'InternalModBreaks' for - -- sanity checks. Don't export it! + , imodBreaks_module :: !Module + -- ^ Also cache the module corresponding to these 'InternalModBreaks', + -- for instance for internal sanity checks. } -- | Construct an 'InternalModBreaks' @@ -161,24 +161,6 @@ assert_modules_match ibi_mod imbs_mod = (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod) --- TODO: See what Cheng has in . --- mkCCSArray --- :: Interp -> Module -> Int -> [Tick] --- -> IO (Array BreakTickIndex (RemotePtr GHC.Stack.CCS.CostCentre)) --- mkCCSArray interp modul count entries --- | interpreterProfiled interp = do --- let module_str = moduleNameString (moduleName modul) --- costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries) --- return (listArray (0,count-1) costcentres) --- | otherwise = return (listArray (0,-1) []) --- where --- mk_one t = (name, src) --- where name = concat $ intersperse "." $ tick_path t --- src = renderWithContext defaultSDocContext $ ppr $ tick_loc t --- , modBreaks_ccs :: !(Array BreakTickIndex (RemotePtr CostCentre)) --- -- ^ Array pointing to cost centre for each breakpoint --- ccs <- mkCCSArray interpProfiled mod count entries - -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -15,7 +15,6 @@ import GHC.Prelude import GHC.ByteCode.Types import GHC.Cmm.Type (Width) -import GHCi.RemoteTypes import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name @@ -32,10 +31,8 @@ import Data.Word import Data.ByteString (ByteString) #endif -import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax -import GHCi.BreakArray (BreakArray) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -261,9 +258,7 @@ data BCInstr -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN (ForeignRef BreakArray) - !InternalBreakpointId - (RemotePtr CostCentre) + | BRK_FUN !InternalBreakpointId -- An internal breakpoint for triggering a break on any case alternative -- See Note [Debugger: BRK_ALTS] @@ -459,7 +454,7 @@ 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 info_mod infox) _) + ppr (BRK_FUN (InternalBreakpointId info_mod infox)) = text "BRK_FUN" <+> text "<breakarray>" <+> ppr info_mod <+> ppr infox <+> text "<cc>" ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -28,9 +28,11 @@ import GHCi.ResolvedBCO import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids +import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Data.FastString +import GHC.Data.Maybe import GHC.Data.SizedSeq import GHC.Linker.Types @@ -47,6 +49,7 @@ import GHC.Types.Unique.DFM import Data.Array.Unboxed import Foreign.Ptr import GHC.Exts +import GHC.HsToCore.Breakpoints (BreakpointId(..)) {- Linking interpretables into something we can run @@ -95,6 +98,14 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of BCONPtrFFIInfo (FFIInfo {..}) -> do RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet pure $ fromIntegral p + BCONPtrCostCentre ibi + | interpreterProfiled interp -> do + (BreakpointId tick_mod tick_no) <- (error "todo") ibi + case expectJust (lookupModuleEnv (ccs_env le) tick_mod) ! tick_no of + RemotePtr p -> pure $ fromIntegral p + | otherwise -> + case toRemotePtr nullPtr of + RemotePtr p -> pure $ fromIntegral p lookupStaticPtr :: Interp -> FastString -> IO (Ptr ()) lookupStaticPtr interp addr_of_label_string = do @@ -175,8 +186,9 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of BCOPtrBCO bco -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco - BCOPtrBreakArray breakarray - -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba) + BCOPtrBreakArray tick_mod -> + withForeignRef (expectJust (lookupModuleEnv (breakarray_env le) tick_mod)) $ + \ba -> pure $ ResolvedBCOPtrBreakArray ba -- | Look up the address of a Haskell symbol in the currently -- loaded units. ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -36,7 +36,6 @@ import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry -import GHCi.BreakArray import GHCi.Message import GHCi.RemoteTypes import GHCi.FFI @@ -48,6 +47,7 @@ import Data.ByteString (ByteString) import qualified GHC.Exts.Heap as Heap import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) import GHC.HsToCore.Breakpoints (ModBreaks) +import GHC.Unit.Module -- ----------------------------------------------------------------------------- -- Compiled Byte Code @@ -63,11 +63,20 @@ data CompiledByteCode = CompiledByteCode -- ^ top-level strings (heap allocated) , bc_breaks :: (Maybe (InternalModBreaks, ModBreaks)) - -- ^ internal breakpoint info (no tick-level 'ModBreaks' if breakpoints are disabled) + -- ^ All (internal and tick-level) breakpoint information (no information + -- if breakpoints are disabled). -- + -- This information is used when loading a bytecode object: we will + -- construct the arrays to be used at runtime to trigger breakpoints then + -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader'). + -- + -- Moreover, when a breakpoint is hit we will find the associated + -- breakpoint information indexed by the internal breakpoint id here (in + -- 'getModBreaks'). + -- TODO: If ModBreaks is serialized and reconstructed as part of ModDetails - -- we don't need to keep it here as it can be fetched from the - -- 'HomeModInfo' directly. + -- we don't need to keep it in bc_breaks as it can be fetched from the + -- 'HomeModInfo' directly, right? , bc_spt_entries :: ![SptEntry] -- ^ Static pointer table entries which should be loaded along with the @@ -258,8 +267,8 @@ data BCOPtr = BCOPtrName !Name | BCOPtrPrimOp !PrimOp | BCOPtrBCO !UnlinkedBCO - | BCOPtrBreakArray (ForeignRef BreakArray) - -- ^ a pointer to a breakpoint's module's BreakArray in GHCi's memory + | BCOPtrBreakArray !Module + -- ^ Converted to the actual 'BreakArray' remote pointer at link-time instance NFData BCOPtr where rnf (BCOPtrBCO bco) = rnf bco @@ -279,6 +288,8 @@ data BCONPtr | BCONPtrFS !FastString -- | A libffi ffi_cif function prototype. | BCONPtrFFIInfo !FFIInfo + -- | A 'CostCentre' remote pointer array's respective 'BreakpointId' + | BCONPtrCostCentre !InternalBreakpointId instance NFData BCONPtr where rnf x = x `seq` () ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -304,6 +304,7 @@ import GHC.Cmm.Config (CmmConfig) import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import GHC.HsToCore.Breakpoints (ModBreaks) {- ********************************************************************** %* * ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Driver.Session import GHC.Rename.Names import GHC.Runtime.Context import GHC.Runtime.Interpreter +import GHC.HsToCore.Breakpoints (ModBreaks) import GHC.Types.Avail import GHC.Types.Name import GHC.Types.Name.Ppr @@ -91,7 +92,7 @@ data ModuleInfo = ModuleInfo { minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, minf_safe :: SafeHaskellMode, - minf_modBreaks :: Maybe ModBreaks + minf_modBreaks :: Maybe (InternalModBreaks, ModBreaks) } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -196,6 +197,6 @@ modInfoIface = minf_iface modInfoSafe :: ModuleInfo -> SafeHaskellMode modInfoSafe = minf_safe -modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks +modInfoModBreaks :: ModuleInfo -> Maybe (InternalModBreaks, ModBreaks) modInfoModBreaks = minf_modBreaks ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -98,6 +98,7 @@ import GHC.Unit.Module.Deps import Data.List (partition) import Data.IORef import GHC.Iface.Make (mkRecompUsageInfo) +import GHC.Runtime.Interpreter (interpreterProfiled) {- ************************************************************************ @@ -164,7 +165,7 @@ deSugar hsc_env ; let modBreaks | Just (_, specs) <- m_tickInfo , breakpointsAllowed dflags - = Just $ mkModBreaks mod specs + = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs | otherwise = Nothing ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- | Information attached to Breakpoints generated from Ticks -- -- The breakpoint information stored in 'ModBreaks' is generated during @@ -13,10 +15,11 @@ -- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] module GHC.HsToCore.Breakpoints ( -- * ModBreaks - mkModBreaks, ModBreaks(modBreaks_locs, modBreaks_vars, modBreaks_decls) + mkModBreaks, ModBreaks(..) -- ** Queries - , getBreakLoc, getBreakVars, getBreakDecls + -- TODO: See where we could use these rather than using the arrays directly. + , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS -- ** Re-exports BreakpointId , BreakpointId(..), BreakTickIndex @@ -33,6 +36,7 @@ import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List (intersperse) -------------------------------------------------------------------------------- -- ModBreaks @@ -51,16 +55,19 @@ import GHC.Utils.Panic -- and 'modBreaks_decls'. data ModBreaks = ModBreaks - { modBreaks_locs :: !(Array BreakTickIndex SrcSpan) + { modBreaks_locs :: !(Array BreakTickIndex SrcSpan) -- ^ An array giving the source span of each breakpoint. - , modBreaks_vars :: !(Array BreakTickIndex [OccName]) + , modBreaks_vars :: !(Array BreakTickIndex [OccName]) -- ^ An array giving the names of the free variables at each breakpoint. - , modBreaks_decls :: !(Array BreakTickIndex [String]) + , modBreaks_decls :: !(Array BreakTickIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. -- See Note [Field modBreaks_decls] + , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + -- ^ Array pointing to cost centre info for each breakpoint; + -- actual 'CostCentre' allocation is done at link-time. , modBreaks_module :: !Module -- ^ The module to which this ModBreaks is associated. - -- We cache this here for internal sanity checks (don't export it!). + -- We also cache this here for internal sanity checks. } -- | Initialize memory for breakpoint data that is shared between the bytecode @@ -70,34 +77,52 @@ data ModBreaks -- generator needs to encode this information for each expression, the data is -- allocated remotely in GHCi's address space and passed to the codegen as -- foreign pointers. -mkModBreaks :: Module -> SizedSeq Tick -> ModBreaks -mkModBreaks modl extendedMixEntries +mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -} + -> Module -> SizedSeq Tick -> ModBreaks +mkModBreaks interpreterProfiled modl extendedMixEntries = let count = fromIntegral $ sizeSS extendedMixEntries entries = ssElts extendedMixEntries locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] + ccs + | interpreterProfiled = + listArray + (0, count - 1) + [ ( concat $ intersperse "." $ tick_path t, + renderWithContext defaultSDocContext $ ppr $ tick_loc t + ) + | t <- entries + ] + | otherwise = listArray (0, -1) [] in ModBreaks { modBreaks_locs = locsTicks , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs , modBreaks_module = modl } -- | Get the source span for this breakpoint getBreakLoc :: BreakpointId -> ModBreaks -> SrcSpan -getBreakLoc (BreakpointId bid_mod ix) mbs = - assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_locs mbs ! ix +getBreakLoc = getBreakXXX modBreaks_locs -- | Get the vars for this breakpoint getBreakVars :: BreakpointId -> ModBreaks -> [OccName] -getBreakVars (BreakpointId bid_mod ix) mbs = - assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_vars mbs ! ix +getBreakVars = getBreakXXX modBreaks_vars -- | Get the decls for this breakpoint getBreakDecls :: BreakpointId -> ModBreaks -> [String] -getBreakDecls (BreakpointId bid_mod ix) mbs = - assert_modules_match bid_mod (modBreaks_module mbs) $ modBreaks_decls mbs ! ix +getBreakDecls = getBreakXXX modBreaks_decls + +-- | Get the decls for this breakpoint +getBreakCCS :: BreakpointId -> ModBreaks -> (String, String) +getBreakCCS = getBreakXXX modBreaks_ccs + +-- | Internal utility to access a ModBreaks field at a particular breakpoint index +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> BreakpointId -> ModBreaks -> a +getBreakXXX view (BreakpointId bid_mod ix) mbs = + assert_modules_match bid_mod (modBreaks_module mbs) $ view mbs ! ix -- | Assert that the module in the 'BreakpointId' and in 'ModBreaks' match. assert_modules_match :: Module -> Module -> a -> a @@ -114,4 +139,3 @@ The breakpoint is in the function called "baz" that is declared in a `let` or `where` clause of a declaration called "bar", which itself is declared in a `let` or `where` clause of the top-level function called "foo". -} - ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -52,6 +52,7 @@ import GHC.Driver.Config.Finder import GHC.Tc.Utils.Monad import GHC.Runtime.Interpreter +import GHCi.BreakArray import GHCi.RemoteTypes import GHC.Iface.Load import GHCi.Message (ConInfoTable(..), LoadedDLL) @@ -60,6 +61,7 @@ import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types +import GHC.Stack.CCS import GHC.SysTools import GHC.Types.Basic @@ -95,6 +97,7 @@ import GHC.Linker.Types -- Standard libraries import Control.Monad +import Data.Array import Data.ByteString (ByteString) import qualified Data.Set as Set import Data.Char (isSpace) @@ -119,6 +122,11 @@ import System.Win32.Info (getSystemDirectory) import GHC.Utils.Exception import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) import GHC.Driver.Downsweep +import GHC.HsToCore.Breakpoints +import qualified Data.IntMap.Strict as IM +import qualified GHC.Runtime.Interpreter as GHCi +import GHC.Data.Maybe (expectJust) +import Foreign.Ptr (nullPtr) @@ -174,6 +182,8 @@ emptyLoaderState = LoaderState { closure_env = emptyNameEnv , itbl_env = emptyNameEnv , addr_env = emptyNameEnv + , breakarray_env = emptyModuleEnv + , ccs_env = emptyModuleEnv } , pkgs_loaded = init_pkgs , bcos_loaded = emptyModuleEnv @@ -691,8 +701,20 @@ loadDecls interp hsc_env span linkable = do let le = linker_env pls le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs) le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs + le2_breakarray_env <- + allocateBreakArrays + interp + (breakarray_env le) + (catMaybes $ map bc_breaks cbcs) + le2_ccs_env <- + allocateCCS + interp + (ccs_env le) + (catMaybes $ map bc_breaks cbcs) let le2 = le { itbl_env = le2_itbl_env - , addr_env = le2_addr_env } + , addr_env = le2_addr_env + , breakarray_env = le2_breakarray_env + , ccs_env = le2_ccs_env } -- Link the necessary packages and linkables new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs @@ -916,7 +938,9 @@ dynLinkBCOs interp pls bcos = do le1 = linker_env pls ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs - let le2 = le1 { itbl_env = ie2, addr_env = ae2 } + be2 <- allocateBreakArrays interp (breakarray_env le1) (catMaybes $ map bc_breaks cbcs) + ce2 <- allocateCCS interp (ccs_env le1) (catMaybes $ map bc_breaks cbcs) + let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 } names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs @@ -1632,3 +1656,71 @@ allocateTopStrings interp topStrings prev_env = do evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs) where mk_entry nm ptr = (nm, (nm, AddrPtr ptr)) + +-- | Given a list of 'InternalModBreaks and 'ModBreaks' collected from a list of +-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints. +allocateBreakArrays :: + Interp -> + ModuleEnv (ForeignRef BreakArray) -> + [(InternalModBreaks, ModBreaks)] -> + IO (ModuleEnv (ForeignRef BreakArray)) +allocateBreakArrays interp = + foldlM + ( \be0 (imbs, _mbs) -> do + let bi = imodBreaks_breakInfo imbs + (hi, _) = IM.findMax bi -- allocate as many slots as internal breakpoints + breakArray <- GHCi.newBreakArray interp hi + evaluate $ extendModuleEnv be0 (imodBreaks_module imbs) breakArray + ) + +-- | Given a list of 'InternalModBreaks' and 'ModBreaks' collected from a list +-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is +-- enabled. +-- +-- Note that the resulting CostCenter is indexed by the 'InternalBreakpointId', +-- not by 'BreakpointId'. At runtime, BRK_FUN instructions are annotated with +-- internal ids -- we'll look them up in the array and push the corresponding +-- cost center. +allocateCCS :: + Interp -> + ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) -> + [(InternalModBreaks, ModBreaks)] -> + IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) +allocateCCS interp ce mbss + | interpreterProfiled interp = do + -- First construct the CCSs for each module, using the 'ModBreaks' + ccs_map <- foldlM + ( \(ccs_map :: ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) (_, mbs) -> do + ccs <- + mkCostCentres + interp + (moduleNameString $ moduleName $ modBreaks_module mbs) + (elems $ modBreaks_ccs mbs) + evaluate $ + extendModuleEnv ccs_map (modBreaks_module mbs) $ + listArray (0, length ccs - 1) ccs + ) emptyModuleEnv mbss + -- Now, construct an array indexed by an 'InternalBreakpointId' index by first + -- finding the matching 'BreakpointId' and then looking it up in the ccs_map + foldlM + ( \ce0 (imbs, _) -> do + let breakModl = imodBreaks_module imbs + breakInfoMap = imodBreaks_breakInfo imbs + (hi, _) = IM.findMax breakInfoMap -- as many slots as internal breaks + ccss = expectJust $ lookupModuleEnv ccs_map breakModl + ccs_im <- foldlM + (\(bids :: IM.IntMap (RemotePtr CostCentre)) cgi -> do + let tickBreakId = bi_tick_index $ cgb_tick_id cgi + pure $ IM.insert tickBreakId (ccss ! tickBreakId) bids + ) mempty breakInfoMap + evaluate $ + extendModuleEnv ce0 breakModl $ + listArray (0, hi-1) $ + map (\i -> case IM.lookup i ccs_im of + Nothing -> toRemotePtr nullPtr + Just ccs -> ccs + ) [0..hi-1] + ) + ce + mbss + | otherwise = pure ce ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -50,10 +50,12 @@ where import GHC.Prelude import GHC.Unit ( UnitId, Module ) -import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) -import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) +import GHC.ByteCode.Types +import GHCi.BreakArray +import GHCi.RemoteTypes import GHCi.Message ( LoadedDLL ) +import GHC.Stack.CCS import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name ( Name ) import GHC.Types.SptEntry @@ -61,6 +63,7 @@ import GHC.Types.SptEntry import GHC.Utils.Outputable import Control.Concurrent.MVar +import Data.Array import Data.Time ( UTCTime ) import GHC.Unit.Module.Env import GHC.Types.Unique.DSet @@ -69,6 +72,7 @@ import GHC.Unit.Module.WholeCoreBindings import Data.Maybe (mapMaybe) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE +import GHC.HsToCore.Breakpoints (BreakTickIndex) {- ********************************************************************** @@ -181,10 +185,17 @@ data LinkerEnv = LinkerEnv , addr_env :: !AddrEnv -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals, -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. + + , breakarray_env :: !(ModuleEnv (ForeignRef BreakArray)) + -- ^ Each 'Module's remote pointer of 'BreakArray'. + + , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) + -- ^ Each 'Module's array of remote pointers of 'CostCentre'. + -- Untouched when not profiling. } filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv -filterLinkerEnv f le = LinkerEnv +filterLinkerEnv f le = le { closure_env = filterNameEnv (f . fst) (closure_env le) , itbl_env = filterNameEnv (f . fst) (itbl_env le) , addr_env = filterNameEnv (f . fst) (addr_env le) ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -16,7 +16,7 @@ import Data.Maybe import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC.ByteCode.Types +import GHC.HsToCore.Breakpoints import GHC.Driver.Env import GHC.Driver.Monad import GHC.Driver.Session.Inspect @@ -196,7 +196,7 @@ type TickArray = Array Int [(BreakTickIndex,RealSrcSpan)] makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) makeModuleLineMap m = do mi <- getModuleInfo m - return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi) + return $ mkTickArray . assocs . modBreaks_locs <$> (fmap snd . modInfoModBreaks =<< mi) where mkTickArray :: [(BreakTickIndex, SrcSpan)] -> TickArray mkTickArray ticks @@ -210,7 +210,7 @@ makeModuleLineMap m = do getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) getModBreak m = do mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m - pure $ modInfoModBreaks mod_info + pure $ snd <$> modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -64,6 +64,7 @@ import GHCi.RemoteTypes import GHC.ByteCode.Types import GHC.Linker.Loader as Loader +import GHC.Linker.Types (LinkerEnv(..)) import GHC.Hs @@ -111,7 +112,6 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing -import GHC.Types.Breakpoint import GHC.Types.Unique.Map import GHC.Types.Avail @@ -127,6 +127,8 @@ import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Utils.Monad import GHC.IfaceToCore +import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints import Control.Monad import Data.Array @@ -137,6 +139,7 @@ import Data.List (find,intercalate) import Data.List.NonEmpty (NonEmpty) import Unsafe.Coerce ( unsafeCoerce ) import qualified GHC.Unit.Home.Graph as HUG +import GHCi.BreakArray (BreakArray) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -153,7 +156,7 @@ getHistoryModule = bi_tick_mod . historyBreakpointId getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan getHistorySpan hug hist = do let bid = historyBreakpointId hist - brks <- readModBreaks hug (bi_tick_mod bid) + (_, brks) <- readModBreaks hug (bi_tick_mod bid) return $ modBreaks_locs brks ! bi_tick_index bid {- | Finds the enclosing top level function name -} @@ -162,7 +165,7 @@ getHistorySpan hug hist = do -- for each tick. findEnclosingDecls :: HUG.HomeUnitGraph -> BreakpointId -> IO [String] findEnclosingDecls hug bid = do - brks <- readModBreaks hug (bi_tick_mod bid) + (_, brks) <- readModBreaks hug (bi_tick_mod bid) return $ modBreaks_decls brks ! bi_tick_index bid -- | Update fixity environment in the current interactive context. @@ -349,15 +352,17 @@ handleRunStatus step expr bindings final_ids status history0 = do -- - or one of the stepping options in @EvalOpts@ caused us to stop at one EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let hug = hsc_HUG hsc_env - let ibi = evalBreakpointToId eval_break - bid <- liftIO $ internalBreakIdToBreakId hug ibi - tick_brks <- liftIO $ readModBreaks hug (bi_tick_mod bid) + let ibi@InternalBreakpointId{ibi_info_index} + = evalBreakpointToId eval_break + bid <- liftIO $ internalBreakIdToBreakId hug ibi + (_, tick_brks) <- liftIO $ readModBreaks hug (bi_tick_mod bid) + breakArray <- getBreakArray interp ibi let span = modBreaks_locs tick_brks ! bi_tick_index bid decl = intercalate "." $ modBreaks_decls tick_brks ! bi_tick_index bid -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)? - bactive <- liftIO $ breakpointStatus interp (modBreaks_flags tick_brks) (bi_tick_index bid) + bactive <- liftIO $ breakpointStatus interp breakArray ibi_info_index apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt @@ -445,8 +450,8 @@ resumeExec step mbCnt -- When the user specified a break ignore count, set it -- in the interpreter case (mb_brkpt, mbCnt) of - (Just (bid, _ibi), Just cnt) -> - setupBreakpoint hsc_env bid cnt + (Just (bid, ibi), Just cnt) -> + setupBreakpoint interp ibi cnt _ -> return () let eval_opts = initEvalOpts dflags (enableGhcStepMode step) @@ -462,14 +467,16 @@ resumeExec step mbCnt | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157 -setupBreakpoint hsc_env bi cnt = do - let modl = bi_tick_mod bi - modBreaks <- liftIO $ readModBreaks (hsc_HUG hsc_env) modl - let breakarray = modBreaks_flags modBreaks - interp = hscInterp hsc_env - _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt - pure () +setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp ibi cnt = do + breakArray <- getBreakArray interp ibi + liftIO $ GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt + +getBreakArray :: GhcMonad m => Interp -> InternalBreakpointId -> m (ForeignRef BreakArray) +getBreakArray interp InternalBreakpointId{ibi_info_mod} = do + breakArrays <- liftIO $ breakarray_env . linker_env . expectJust + <$> Loader.getLoaderState interp + return $ expectJust $ lookupModuleEnv breakArrays ibi_info_mod back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) @@ -498,8 +505,8 @@ moveHist fn = do span <- case mb_info of Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") Just (bid, _ibi) -> liftIO $ do - brks <- readModBreaks (hsc_HUG hsc_env) (bi_tick_mod bid) - return $ modBreaks_locs brks ! bi_tick_index bid + (_, brks) <- readModBreaks (hsc_HUG hsc_env) (bi_tick_mod bid) + return $ modBreaks_locs brks ! bi_tick_index bid -- todo: getBreakLoc (hsc_env1, names) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span (snd <$> mb_info) let ic = hsc_IC hsc_env1 @@ -560,10 +567,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) + (info_brks, _) <- readModBreaks hug (ibi_info_mod ibi) bid <- internalBreakIdToBreakId hug ibi - tick_brks <- readModBreaks hug (bi_tick_mod bid) - let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks) + (_, tick_brks) <- readModBreaks hug (bi_tick_mod bid) + let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (imodBreaks_breakInfo info_brks) interp = hscInterp hsc_env occs = modBreaks_vars tick_brks ! bi_tick_index bid ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Platform.Profile import GHC.Runtime.Interpreter import GHCi.FFI -import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Types.Name @@ -81,17 +80,13 @@ import Control.Monad import Data.Char import GHC.Unit.Module -import qualified GHC.Unit.Home.Graph as HUG -import Data.Array import Data.Coerce (coerce) #if MIN_VERSION_rts(1,0,3) import qualified Data.ByteString.Char8 as BS #endif import Data.Map (Map) -import Data.IntMap (IntMap) import qualified Data.Map as Map -import qualified Data.IntMap as IntMap import qualified GHC.Data.FiniteMap as Map import Data.Ord import Data.Either ( partitionEithers ) @@ -101,8 +96,8 @@ import qualified Data.IntSet as IntSet import GHC.CoreToIface import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT) -import Control.Monad.Trans.State (StateT) +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -128,8 +123,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - (BcM_State{..}, proto_bcos) <- - runBc hsc_env this_mod mb_modBreaks $ do + (proto_bcos, BcM_State{..}) <- + runBc hsc_env this_mod $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds @@ -138,15 +133,12 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) let all_mod_breaks = case mb_modBreaks of - Just modBreaks -> Just (modBreaks, internalBreaks) + Just modBreaks -> Just (internalBreaks, modBreaks) Nothing -> Nothing -- no modBreaks, thus drop all -- internalBreaks? Will we ever want to have internal breakpoints in -- a module for which we're not doing breakpoints at all? probably - -- not? - -- TODO: Consider always returning InternalBreaks; - -- TODO: Consider making ModBreaks a SUM that can be empty instead of using Maybe. - cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries + cbc <- assembleBCOs profile proto_bcos tycs strings all_mod_breaks spt_entries -- Squash space leaks in the CompiledByteCode. This is really -- important, because when loading a set of modules into GHCi @@ -409,7 +401,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do current_mod <- getCurrentModule liftIO (readModBreaksMaybe (hsc_HUG hsc_env) current_mod) >>= \case Nothing -> pure code - Just ModBreaks {modBreaks_flags = breaks, modBreaks_ccs = cc_arr} -> do + Just _ -> do platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) @@ -417,20 +409,13 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id - let info_mod = current_mod - infox <- newBreakInfo breakInfo + ibi <- newBreakInfo breakInfo - let cc | Just interp <- hsc_interp hsc_env - , interpreterProfiled interp - = cc_arr ! bi_tick_index tick_id - | otherwise = toRemotePtr nullPtr - - breakInstr = BRK_FUN breaks (InternalBreakpointId info_mod infox) cc - - return $ breakInstr `consOL` code + return $ BRK_FUN ibi `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs --- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module +-- TODO: WHERE TO PUT +-- 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. @@ -449,19 +434,6 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs -- 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 $ getModBreaks hp - Nothing -> pure Nothing getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] getVarOffSets platform depth env = map getOffSet @@ -2642,34 +2614,31 @@ data BcM_Env = BcM_Env { bcm_hsc_env :: HscEnv , bcm_module :: Module -- current module (for breakpoints) - , bcm_mod_breaks :: Maybe ModBreaks -- this module's ModBreaks } data BcM_State = BcM_State { nextlabel :: !Word32 -- ^ For generating local labels , breakInfoIdx :: !Int -- ^ Next index for breakInfo array - , internalBreaks :: InternalModBreaks + , internalBreaks :: !InternalModBreaks -- ^ Info at breakpoints occurrences. Indexed with -- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in -- GHC.ByteCode.Breakpoints. } -newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (BcM_State, r)) +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) deriving (Functor, Applicative, Monad, MonadIO) via (ReaderT BcM_Env (StateT BcM_State IO)) -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_Env hsc_env this_mod modBreaks) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty)) +runBc :: HscEnv -> Module -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod (BcM m) + = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 (mkInternalModBreaks this_mod mempty)) instance HasDynFlags BcM where getDynFlags = hsc_dflags <$> getHscEnv getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \env st -> return (st, bcm_hsc_env env) +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags @@ -2686,12 +2655,12 @@ getLabelBc = BcM $ \_ st -> do let nl = nextlabel st when (nl == maxBound) $ panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) + return (LocalLabel nl, st{nextlabel = nl + 1}) getLabelsBc :: Word32 -> BcM [LocalLabel] getLabelsBc n = BcM $ \_ st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) newBreakInfo :: CgBreakInfo -> BcM InternalBreakpointId newBreakInfo info = BcM $ \env st -> @@ -2701,10 +2670,10 @@ newBreakInfo info = BcM $ \env st -> { internalBreaks = addInternalBreak ibi info (internalBreaks st) , breakInfoIdx = ix + 1 } - in return (st', ibi) + in return (ibi, st') getCurrentModule :: BcM Module -getCurrentModule = BcM $ \env st -> return (st, thisModule env) +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) tickFS :: FastString tickFS = fsLit "ticked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cbb38fecc7fad079204332299bc527... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cbb38fecc7fad079204332299bc527... You're receiving this email because of your account on gitlab.haskell.org.