Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC Commits: 95a87614 by Rodrigo Mesquita at 2025-06-30T10:54:35+01:00 simpler - - - - - 3a0a3099 by Rodrigo Mesquita at 2025-06-30T11:29:24+01:00 allow allocating breakarrays outside of linking but in the linker env still - - - - - 7 changed files: - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -178,7 +178,7 @@ assert_modules_match ibi_mod imbs_mod = <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod) -------------------------------------------------------------------------------- - +-- Tick-level Breakpoint information -------------------------------------------------------------------------------- -- | Get the source span for this breakpoint ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -92,7 +92,7 @@ data ModuleInfo = ModuleInfo { minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, minf_safe :: SafeHaskellMode, - minf_modBreaks :: Maybe (InternalModBreaks, ModBreaks) + minf_modBreaks :: Maybe InternalModBreaks } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -150,8 +150,8 @@ getHomeModuleInfo hsc_env mdl = -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. minf_instances = instEnvElts $ md_insts details, minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = getModBreaks hmi })) -- | The list of top-level entities defined in a module @@ -197,6 +197,6 @@ modInfoIface = minf_iface modInfoSafe :: ModuleInfo -> SafeHaskellMode modInfoSafe = minf_safe -modInfoModBreaks :: ModuleInfo -> Maybe (InternalModBreaks, ModBreaks) +modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks modInfoModBreaks = minf_modBreaks ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -28,6 +28,7 @@ module GHC.Linker.Loader , extendLoadedEnv , deleteFromLoadedEnv -- * Internals + , allocateBreakArrays , rmDupLinkables , modifyLoaderState , initLinkDepsOpts @@ -705,12 +706,12 @@ loadDecls interp hsc_env span linkable = do allocateBreakArrays interp (breakarray_env le) - (catMaybes $ map bc_breaks cbcs) + (map bc_breaks cbcs) le2_ccs_env <- allocateCCS interp (ccs_env le) - (catMaybes $ map bc_breaks cbcs) + (map bc_breaks cbcs) let le2 = le { itbl_env = le2_itbl_env , addr_env = le2_addr_env , breakarray_env = le2_breakarray_env @@ -938,8 +939,8 @@ 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 - be2 <- allocateBreakArrays interp (breakarray_env le1) (catMaybes $ map bc_breaks cbcs) - ce2 <- allocateCCS interp (ccs_env le1) (catMaybes $ map bc_breaks cbcs) + be2 <- allocateBreakArrays interp (breakarray_env le1) (map bc_breaks cbcs) + ce2 <- allocateCCS interp (ccs_env le1) (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 @@ -1662,15 +1663,19 @@ allocateTopStrings interp topStrings prev_env = do allocateBreakArrays :: Interp -> ModuleEnv (ForeignRef BreakArray) -> - [(InternalModBreaks, ModBreaks)] -> + [InternalModBreaks] -> IO (ModuleEnv (ForeignRef BreakArray)) allocateBreakArrays interp = foldlM - ( \be0 (imbs, _mbs) -> do + ( \be0 imbs -> 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 + hi = maybe 0 fst (IM.lookupMax bi) -- allocate as many slots as internal breakpoints + if not $ elemModuleEnv (imodBreaks_module imbs) be0 then do + -- If no BreakArray is assigned to this module yet, create one + breakArray <- GHCi.newBreakArray interp hi + evaluate $ extendModuleEnv be0 (imodBreaks_module imbs) breakArray + else + return be0 ) -- | Given a list of 'InternalModBreaks' and 'ModBreaks' collected from a list @@ -1684,42 +1689,48 @@ allocateBreakArrays interp = allocateCCS :: Interp -> ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) -> - [(InternalModBreaks, ModBreaks)] -> + [InternalModBreaks] -> 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 + ( \(ccs_map :: ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) imbs -> do + case imodBreaks_modBreaks imbs of + Nothing -> return ccs_map -- don't add it + Just 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 + ( \ce0 imbs -> do let breakModl = imodBreaks_module imbs breakInfoMap = imodBreaks_breakInfo imbs - (hi, _) = IM.findMax breakInfoMap -- as many slots as internal breaks + hi = maybe 0 fst (IM.lookupMax 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] + if not $ elemModuleEnv breakModl ce0 then do + 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] + else + return ce0 ) ce mbss ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -17,6 +17,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints import GHC.Driver.Env import GHC.Driver.Monad import GHC.Driver.Session.Inspect @@ -196,7 +197,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 <$> (fmap snd . modInfoModBreaks =<< mi) + return $ mkTickArray . assocs . modBreaks_locs <$> (imodBreaks_modBreaks =<< modInfoModBreaks =<< mi) where mkTickArray :: [(BreakTickIndex, SrcSpan)] -> TickArray mkTickArray ticks @@ -210,7 +211,7 @@ makeModuleLineMap m = do getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) getModBreak m = do mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m - pure $ snd <$> modInfoModBreaks mod_info + pure $ imodBreaks_modBreaks =<< modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information @@ -237,6 +238,6 @@ getCurrentBreakModule = do return $ case resumes of [] -> Nothing (r:_) -> case resumeHistoryIx r of - 0 -> bi_tick_mod . fst <$> resumeBreakpointId r + 0 -> ibi_info_mod <$> resumeBreakpointId r ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -127,13 +127,11 @@ 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 import Data.Dynamic import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import Data.List.NonEmpty (NonEmpty) import Unsafe.Coerce ( unsafeCoerce ) @@ -146,26 +144,28 @@ import GHCi.BreakArray (BreakArray) getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> BreakpointId -> InternalBreakpointId -> IO History -mkHistory hug hval bid ibi = History hval bid ibi <$> findEnclosingDecls hug bid +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi getHistoryModule :: History -> Module -getHistoryModule = bi_tick_mod . historyBreakpointId +getHistoryModule = ibi_info_mod . historyBreakpointId getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan getHistorySpan hug hist = do - let bid = historyBreakpointId hist - (_, brks) <- readModBreaks hug (bi_tick_mod bid) - return $ getBreakLoc bid brks + let ibi = historyBreakpointId hist + brks <- expectJust <$> readModBreaks hug ibi + return $ expectJust $ getBreakLoc 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 -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HUG.HomeUnitGraph -> BreakpointId -> IO [String] -findEnclosingDecls hug bid = do - (_, brks) <- readModBreaks hug (bi_tick_mod bid) - return $ modBreaks_decls brks ! bi_tick_index bid +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + readModBreaks hug ibi >>= \case + Nothing -> return [] + Just brks -> return $ + fromMaybe [] (getBreakDecls ibi brks) -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m () @@ -353,12 +353,11 @@ handleRunStatus step expr bindings final_ids status history0 = do let hug = hsc_HUG hsc_env 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 + brks <- liftIO $ readModBreaks hug ibi + breakArray <- getBreakArray interp ibi (expectJust brks) let - span = getBreakLoc bid tick_brks - decl = intercalate "." $ modBreaks_decls tick_brks ! bi_tick_index bid + span = fromMaybe noSrcSpan $ getBreakLoc ibi =<< brks + decl = intercalate "." $ fromMaybe [] $ getBreakDecls ibi =<< brks -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)? bactive <- liftIO $ breakpointStatus interp breakArray ibi_info_index @@ -381,7 +380,7 @@ handleRunStatus step expr bindings final_ids status history0 = do , resumeBindings = bindings , resumeFinalIds = final_ids , resumeApStack = apStack_fhv - , resumeBreakpointId = Just (bid, ibi) + , resumeBreakpointId = Just ibi , resumeSpan = span , resumeHistory = toListBL history0 , resumeDecl = decl @@ -396,7 +395,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do - history1 <- liftIO $ mkHistory hug apStack_fhv bid ibi + history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' @@ -449,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 (_bid, ibi), Just cnt) -> + (Just ibi, Just cnt) -> setupBreakpoint interp ibi cnt _ -> return () @@ -459,24 +458,35 @@ resumeExec step mbCnt hug = hsc_HUG hsc_env hist' = case mb_brkpt of Nothing -> pure prevHistoryLst - Just (bid, ibi) + Just ibi | breakHere False step span -> do - hist1 <- liftIO (mkHistory hug apStack bid ibi) + hist1 <- liftIO (mkHistory hug apStack ibi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 setupBreakpoint interp ibi cnt = do - breakArray <- getBreakArray interp ibi + hug <- hsc_HUG <$> getSession + ims <- liftIO $ readModBreaks hug ibi + breakArray <- getBreakArray interp ibi (expectJust ims) 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 - pprTraceM "hello" (ppr $ moduleEnvKeys breakArrays) - return $ expectJust $ lookupModuleEnv breakArrays ibi_info_mod +getBreakArray :: GhcMonad m => Interp -> InternalBreakpointId -> InternalModBreaks -> m (ForeignRef BreakArray) +getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do + + liftIO $ modifyLoaderState interp $ \ld_st -> do + let le = linker_env ld_st + + -- Recall that BreakArrays are allocated only at BCO link time, so if we + -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here. + ba_env <- allocateBreakArrays interp (breakarray_env le) [imbs] + + return + ( ld_st { linker_env = le{breakarray_env = ba_env} } + , expectJust {- just computed -} $ + lookupModuleEnv ba_env ibi_info_mod + ) back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) @@ -504,11 +514,11 @@ moveHist fn = do update_ic apStack mb_info = 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 $ getBreakLoc bid brks + Just ibi -> liftIO $ do + brks <- readModBreaks (hsc_HUG hsc_env) ibi + return $ fromMaybe noSrcSpan $ getBreakLoc ibi =<< brks (hsc_env1, names) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack span (snd <$> mb_info) + liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } @@ -527,7 +537,7 @@ moveHist fn = do update_ic apStack mb_brkpt else case history !! (new_ix - 1) of History{..} -> - update_ic historyApStack (Just (historyBreakpointId, historyInternalBreakpointId)) + update_ic historyApStack (Just historyBreakpointId) -- ----------------------------------------------------------------------------- @@ -567,12 +577,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) - bid <- internalBreakIdToBreakId hug ibi - (_, tick_brks) <- readModBreaks hug (bi_tick_mod bid) - let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (imodBreaks_breakInfo info_brks) + info_brks <- readModBreaks hug ibi + let info = getInternalBreak ibi (expectJust info_brks) interp = hscInterp hsc_env - occs = modBreaks_vars tick_brks ! bi_tick_index bid + occs = fromMaybe [] $ getBreakVars 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/Eval/Types.hs ===================================== @@ -176,9 +176,8 @@ data Resume = Resume , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. - , resumeBreakpointId :: Maybe (BreakpointId, InternalBreakpointId) + , resumeBreakpointId :: Maybe InternalBreakpointId -- ^ the internal breakpoint we stopped at - -- and a cached computation of BreakpointId from it. -- (Nothing <=> exception) , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, @@ -195,9 +194,7 @@ type ResumeBindings = ([TyThing], IcGlobalRdrEnv) data History = History { historyApStack :: ForeignHValue - , historyBreakpointId :: BreakpointId - -- ^ Cache the 'BreakpointId' computed from the 'InternalBreakpointId' - , historyInternalBreakpointId :: InternalBreakpointId + , historyBreakpointId :: InternalBreakpointId -- ^ internal breakpoint identifier , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint ===================================== ghc/GHCi/UI.hs ===================================== @@ -45,6 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv) import GHC.Runtime.Eval.Utils -- The GHC interface +import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks) import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHCi.BreakArray( breakOn, breakOff ) @@ -1564,7 +1565,6 @@ afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before - -> GHC.ExecResult -> m GHC.ExecResult afterRunStmt step run_result = do resumes <- GHC.getResumeContext - hug <- hsc_HUG <$> GHC.getSession case run_result of GHC.ExecComplete{..} -> case execResult of @@ -3793,7 +3793,7 @@ pprStopped res = <> text (GHC.resumeDecl res)) <> char ',' <+> ppr (GHC.resumeSpan res) where - mb_mod_name = moduleName . ibi_info_mod . snd <$> GHC.resumeBreakpointId res + mb_mod_name = moduleName . ibi_info_mod <$> GHC.resumeBreakpointId res showUnits :: GHC.GhcMonad m => m () showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do @@ -4448,7 +4448,7 @@ breakById inp = do Left sdoc -> printForUser sdoc Right (mod, mod_info, fun_str) -> do let modBreaks = expectJust (GHC.modInfoModBreaks mod_info) - findBreakAndSet mod $ \_ -> findBreakForBind fun_str (snd modBreaks) + findBreakAndSet mod $ \_ -> maybe [] (findBreakForBind fun_str) (imodBreaks_modBreaks modBreaks) breakSyntax :: a breakSyntax = throwGhcException $ CmdLineError ("Syntax: :break [<mod>.]<func>[.<func>]\n" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/748ddd689188339a7c1a829a12a85d9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/748ddd689188339a7c1a829a12a85d9... You're receiving this email because of your account on gitlab.haskell.org.