[Git][ghc/ghc][wip/romes/ghci-debugger-2] 2 commits: ghci: only compute locals at breakpoint if useful
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Feb 24 16:13:30 UTC 2025
Rodrigo Mesquita pushed to branch wip/romes/ghci-debugger-2 at Glasgow Haskell Compiler / GHC
Commits:
f3a970a6 by Rodrigo Mesquita at 2025-02-24T15:33:08+00:00
ghci: only compute locals at breakpoint if useful
Specifically, :steplocal and :stepmodule, unlike :step, will never see
the information that is arduously computed by `bindLocalsAtBreakpoint`
because they will only stop on breakpoints either at the same function
or in the same module, respectively.
Nonetheless, ghci would stop at all breakpoints, compute all this
information, and only afterwards check whether we are going to stop at
this breakpoint.
With this commit we pass the "do we care about this predicate" down the
call stack to decide at `bindLocalsAtBreakpoint` whether or not to
compute the information.
Fixes #25779 (problem 1 of 3).
- - - - -
b4e514d8 by Rodrigo Mesquita at 2025-02-24T15:33:11+00:00
ghci: Don't set virtualCWD on every iteration
When using :steplocal, we will break and resume from every breakpoint
until we find a breakpoint in the same function as the one we called
:steplocal from originally.
However, resume and exec are incredibly slow because of all the calls to
withVirtualCWD (amongst other bad inefficiencies in this loop that are
fixed by the previous and next commit)
The calls to withVirtualCWD were introduced to fix #2973, but this bug
is no longer reproducible -- regardless of the calls to withVirtualCWD.
Fixes #25779 (problem 2 of 3)
- - - - -
2 changed files:
- compiler/GHC/Runtime/Eval.hs
- ghc/GHCi/UI/Monad.hs
Changes:
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -232,17 +232,16 @@ execStmt' stmt stmt_text ExecOptions{..} = do
updateFixityEnv fix_env
status <-
- withVirtualCWD $
- liftIO $ do
- let eval_opts = initEvalOpts idflags' (isStep execSingleStep)
- evalStmt interp eval_opts (execWrap hval)
+ liftIO $ do
+ let eval_opts = initEvalOpts idflags' (isStep execSingleStep)
+ evalStmt interp eval_opts (execWrap hval)
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_gre_cache ic)
size = ghciHistSize idflags'
- handleRunStatus execSingleStep stmt_text bindings ids
+ handleRunStatus (const True) execSingleStep stmt_text bindings ids
status (emptyHistory size)
runDecls :: GhcMonad m => String -> m [Name]
@@ -282,32 +281,6 @@ them. The relevant predicate is OccName.isDerivedOccName.
See #11051 for more background and examples.
-}
-withVirtualCWD :: GhcMonad m => m a -> m a
-withVirtualCWD m = do
- hsc_env <- getSession
-
- -- a virtual CWD is only necessary when we're running interpreted code in
- -- the same process as the compiler.
- case interpInstance <$> hsc_interp hsc_env of
- Just (ExternalInterp {}) -> m
- _ -> do
- let ic = hsc_IC hsc_env
- let set_cwd = do
- dir <- liftIO $ getCurrentDirectory
- case ic_cwd ic of
- Just dir -> liftIO $ setCurrentDirectory dir
- Nothing -> return ()
- return dir
-
- reset_cwd orig_dir = do
- virt_dir <- liftIO $ getCurrentDirectory
- hsc_env <- getSession
- let old_IC = hsc_IC hsc_env
- setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
- liftIO $ setCurrentDirectory orig_dir
-
- MC.bracket set_cwd reset_cwd $ \_ -> m
-
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
@@ -315,14 +288,17 @@ emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
handleRunStatus :: GhcMonad m
- => SingleStep -> String
+ => (SrcSpan -> Bool)
+ -- ^ @True@ if we want to stop at a breakpoint with this
+ -- @SrcSpan@ (always true for :step, but not for :steplocal or :stepmodule)
+ -> SingleStep -> String
-> ResumeBindings
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
-handleRunStatus step expr bindings final_ids status history0
+handleRunStatus step_here step expr bindings final_ids status history0
| RunAndLogSteps <- step = tracing
| otherwise = not_tracing
where
@@ -351,7 +327,7 @@ handleRunStatus step expr bindings final_ids status history0
fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
let eval_opts = initEvalOpts dflags True
status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
- handleRunStatus RunAndLogSteps expr bindings final_ids
+ handleRunStatus step_here RunAndLogSteps expr bindings final_ids
status history'
| otherwise
= not_tracing
@@ -369,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0
Just break -> fmap Just $ liftIO $
evalBreakpointToId (hsc_HPT hsc_env) break
(hsc_env1, names, span, decl) <- liftIO $
- bindLocalsAtBreakpoint hsc_env apStack_fhv ibi
+ bindLocalsAtBreakpoint step_here hsc_env apStack_fhv ibi
let
resume = Resume
{ resumeStmt = expr
@@ -405,9 +381,14 @@ handleRunStatus step expr bindings final_ids status history0
= return (ExecComplete (Left (fromSerializableException e)) alloc)
-resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
+resumeExec :: GhcMonad m
+ => (SrcSpan -> Bool)
+ -- ^ Returns True if the given Breakpoint SrcSpan is where we want
+ -- to step to. Always true for :step, but :steplocal and :stepmodule
+ -- don't stop at all locations.
+ -> SingleStep -> Maybe Int
-> m ExecResult
-resumeExec canLogSpan step mbCnt
+resumeExec step_here step mbCnt
= do
hsc_env <- getSession
let ic = hsc_IC hsc_env
@@ -445,7 +426,7 @@ resumeExec canLogSpan step mbCnt
, resumeBreakpointId = mb_brkpt
, resumeSpan = span
, resumeHistory = hist } ->
- withVirtualCWD $ do
+ do
-- When the user specified a break ignore count, set it
-- in the interpreter
case (mb_brkpt, mbCnt) of
@@ -458,11 +439,11 @@ resumeExec canLogSpan step mbCnt
hist' = case mb_brkpt of
Nothing -> pure prevHistoryLst
Just bi
- | not $ canLogSpan span -> pure prevHistoryLst
+ | not $ step_here span -> pure prevHistoryLst
| otherwise -> do
hist1 <- liftIO (mkHistory hsc_env apStack bi)
return $ hist1 `consBL` fromListBL 50 hist
- handleRunStatus step expr bindings final_ids status =<< hist'
+ handleRunStatus step_here step expr bindings final_ids status =<< hist'
setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157
setupBreakpoint hsc_env bi cnt = do
@@ -499,7 +480,7 @@ moveHist fn = do
let
update_ic apStack mb_info = do
(hsc_env1, names, span, decl) <-
- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
+ liftIO $ bindLocalsAtBreakpoint (const True) hsc_env apStack mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
@@ -528,7 +509,14 @@ result_fs :: FastString
result_fs = fsLit "_result"
bindLocalsAtBreakpoint
- :: HscEnv
+ :: (SrcSpan -> Bool)
+ -- ^ @True@ if we want to stop at a breakpoint with this
+ -- @SrcSpan@ (always true for :step, but not for :steplocal or :stepmodule).
+ --
+ -- To avoid needless computation, we only actually compute the bindings
+ -- if we intend to use them. Thus, if @False@, @HscEnv@ is unchanged
+ -- from the input and @[Name]@ is empty.
+ -> HscEnv
-> ForeignHValue
-> Maybe InternalBreakpointId
-> IO (HscEnv, [Name], SrcSpan, String)
@@ -537,7 +525,7 @@ bindLocalsAtBreakpoint
-- breakpoint. We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
-bindLocalsAtBreakpoint hsc_env apStack Nothing = do
+bindLocalsAtBreakpoint _step_here hsc_env apStack Nothing = do
let exn_occ = mkVarOccFS (fsLit "_exception")
span = mkGeneralSrcSpan (fsLit "<unknown>")
exn_name <- newInteractiveBinder hsc_env exn_occ span
@@ -556,75 +544,77 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do
- let
- interp = hscInterp hsc_env
-
- info_mod = ibi_info_mod ibi
- info_hmi <- expectJust "bindLocalsAtBreakpoint" <$> lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)
- let
- info_brks = getModBreaks info_hmi
- info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
-
- tick_mod = ibi_tick_mod ibi
- tick_hmi <- expectJust "bindLocalsAtBreakpoint" <$> lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)
- let
- tick_brks = getModBreaks tick_hmi
- occs = modBreaks_vars tick_brks ! ibi_tick_index ibi
- span = modBreaks_locs tick_brks ! ibi_tick_index ibi
- decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
-
- -- Rehydrate to understand the breakpoint info relative to the current environment.
- -- This design is critical to preventing leaks (#22530)
- (mbVars, result_ty) <- initIfaceLoad hsc_env
- $ initIfaceLcl info_mod (text "debugger") NotBoot
- $ hydrateCgBreakInfo info
-
- let
-
- -- Filter out any unboxed ids by changing them to Nothings;
- -- we can't bind these at the prompt
- mbPointers = nullUnboxed <$> mbVars
-
- (ids, offsets, occs') = syncOccs mbPointers occs
-
- free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)
-
- -- It might be that getIdValFromApStack fails, because the AP_STACK
- -- has been accidentally evaluated, or something else has gone wrong.
- -- So that we don't fall over in a heap when this happens, just don't
- -- bind any free variables instead, and we emit a warning.
- mb_hValues <-
- mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets
- when (any isNothing mb_hValues) $
- debugTraceMsg (hsc_logger hsc_env) 1 $
- text "Warning: _result has been evaluated, some bindings have been lost"
-
- us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
- let tv_subst = newTyVars us free_tvs
- (filtered_ids, occs'') = unzip -- again, sync the occ-names
- [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
- tidy_tys = tidyOpenTypes emptyTidyEnv $
- map (substTy tv_subst . idType) filtered_ids
-
- new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
- result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
-
- let result_id = Id.mkVanillaGlobal result_name
- (substTy tv_subst result_ty)
- result_ok = isPointer result_id
-
- final_ids | result_ok = result_id : new_ids
- | otherwise = new_ids
- ictxt0 = hsc_IC hsc_env
- ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
- names = map idName new_ids
-
- let fhvs = catMaybes mb_hValues
- Loader.extendLoadedEnv interp (zip names fhvs)
- when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
- hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
- return (hsc_env1, if result_ok then result_name:names else names, span, decl)
+bindLocalsAtBreakpoint step_here hsc_env apStack_fhv (Just ibi) = do
+ let tick_mod = ibi_tick_mod ibi
+ tick_hmi <- expectJust "bindLocalsAtBreakpoint" <$> lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)
+ let
+ tick_brks = getModBreaks tick_hmi
+ occs = modBreaks_vars tick_brks ! ibi_tick_index ibi
+ span = modBreaks_locs tick_brks ! ibi_tick_index ibi
+ decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
+ if step_here span then do
+ let
+ interp = hscInterp hsc_env
+
+ info_mod = ibi_info_mod ibi
+ info_hmi <- expectJust "bindLocalsAtBreakpoint" <$> lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)
+ let
+ info_brks = getModBreaks info_hmi
+ info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
+
+ -- Rehydrate to understand the breakpoint info relative to the current environment.
+ -- This design is critical to preventing leaks (#22530)
+ (mbVars, result_ty) <- initIfaceLoad hsc_env
+ $ initIfaceLcl info_mod (text "debugger") NotBoot
+ $ hydrateCgBreakInfo info
+
+ let
+
+ -- Filter out any unboxed ids by changing them to Nothings;
+ -- we can't bind these at the prompt
+ mbPointers = nullUnboxed <$> mbVars
+
+ (ids, offsets, occs') = syncOccs mbPointers occs
+
+ free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)
+
+ -- It might be that getIdValFromApStack fails, because the AP_STACK
+ -- has been accidentally evaluated, or something else has gone wrong.
+ -- So that we don't fall over in a heap when this happens, just don't
+ -- bind any free variables instead, and we emit a warning.
+ mb_hValues <-
+ mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets
+ when (any isNothing mb_hValues) $
+ debugTraceMsg (hsc_logger hsc_env) 1 $
+ text "Warning: _result has been evaluated, some bindings have been lost"
+
+ us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
+ let tv_subst = newTyVars us free_tvs
+ (filtered_ids, occs'') = unzip -- again, sync the occ-names
+ [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
+ tidy_tys = tidyOpenTypes emptyTidyEnv $
+ map (substTy tv_subst . idType) filtered_ids
+
+ new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
+ result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
+
+ let result_id = Id.mkVanillaGlobal result_name
+ (substTy tv_subst result_ty)
+ result_ok = isPointer result_id
+
+ final_ids | result_ok = result_id : new_ids
+ | otherwise = new_ids
+ ictxt0 = hsc_IC hsc_env
+ ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
+ names = map idName new_ids
+
+ let fhvs = catMaybes mb_hValues
+ Loader.extendLoadedEnv interp (zip names fhvs)
+ when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
+ hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
+ return (hsc_env1, if result_ok then result_name:names else names, span, decl)
+ else do
+ return (hsc_env, [], span, decl)
where
-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -402,13 +402,13 @@ runDecls' decls = do
(Just <$> GHC.runParsedDecls decls)
resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult
-resume canLogSpan step mbIgnoreCnt = do
+resume step_here step mbIgnoreCnt = do
st <- getGHCiState
reifyGHCi $ \x ->
withProgName (progname st) $
withArgs (args st) $
reflectGHCi x $ do
- GHC.resumeExec canLogSpan step mbIgnoreCnt
+ GHC.resumeExec step_here step mbIgnoreCnt
-- --------------------------------------------------------------------------
-- timing & statistics
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5fd7c6c195f5ecfb7c91fae60eb9fa06dc67b504...b4e514d8ac6fd04cf08d688a183e7a422daf21ab
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5fd7c6c195f5ecfb7c91fae60eb9fa06dc67b504...b4e514d8ac6fd04cf08d688a183e7a422daf21ab
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250224/36a5cff0/attachment-0001.html>
More information about the ghc-commits
mailing list