[Git][ghc/ghc][wip/romes/ghci-debugger] ghci-debugger: display thunks provenance if avail
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Feb 19 10:45:42 UTC 2025
Rodrigo Mesquita pushed to branch wip/romes/ghci-debugger at Glasgow Haskell Compiler / GHC
Commits:
dfc30565 by Rodrigo Mesquita at 2025-02-19T10:45:25+00:00
ghci-debugger: display thunks provenance if avail
Improves reporting on ghci breakpoints when IPE information is available
by printing, next to the thunk, the source file and src span where the
thunk originated.
Closes #25746
- - - - -
5 changed files:
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
Changes:
=====================================
compiler/GHC/Runtime/Debugger.hs
=====================================
@@ -184,10 +184,10 @@ bindSuspensions t = do
(term, names) <- t
return (RefWrap ty term, names)
}
- doSuspension hsc_env freeNames ct ty hval _name = do
+ doSuspension hsc_env freeNames ct ty hval _name ipe = do
name <- atomicModifyIORef' freeNames (\(Inf x xs)->(xs, x))
n <- newGrimName hsc_env name
- return (Suspension ct ty hval (Just n), [(n,ty,hval)])
+ return (Suspension ct ty hval (Just n) ipe, [(n,ty,hval)])
-- A custom Term printer to enable the use of Show instances
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -86,6 +86,7 @@ import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign hiding (shiftL, shiftR)
import System.IO.Unsafe
+import GHC.InfoProv
---------------------------------------------
-- * A representation of semi evaluated Terms
@@ -106,6 +107,7 @@ data Term = Term { ty :: RttiType
, ty :: RttiType
, val :: ForeignHValue
, bound_to :: Maybe Name -- Useful for printing
+ , infoprov :: Maybe InfoProv -- Provenance is printed when available
}
| NewtypeWrap{ -- At runtime there are no newtypes, and hence no
-- newtype constructors. A NewtypeWrap is just a
@@ -164,7 +166,7 @@ type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [
data TermFold a = TermFold { fTerm :: TermProcessor a a
, fPrim :: RttiType -> [Word] -> a
, fSuspension :: ClosureType -> RttiType -> ForeignHValue
- -> Maybe Name -> a
+ -> Maybe Name -> Maybe InfoProv -> a
, fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
, fRefWrap :: RttiType -> a -> a
@@ -175,7 +177,7 @@ data TermFoldM m a =
TermFoldM {fTermM :: TermProcessor a (m a)
, fPrimM :: RttiType -> [Word] -> m a
, fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
- -> Maybe Name -> m a
+ -> Maybe Name -> Maybe InfoProv -> m a
, fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
, fRefWrapM :: RttiType -> a -> m a
@@ -184,7 +186,7 @@ data TermFoldM m a =
foldTerm :: TermFold a -> Term -> a
foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
foldTerm tf (Prim ty v ) = fPrim tf ty v
-foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
+foldTerm tf (Suspension ct ty v b i) = fSuspension tf ct ty v b i
foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
@@ -192,7 +194,7 @@ foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
foldTermM :: Monad m => TermFoldM m a -> Term -> m a
foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
foldTermM tf (Prim ty v ) = fPrimM tf ty v
-foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
+foldTermM tf (Suspension ct ty v b i) = fSuspensionM tf ct ty v b i
foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
@@ -208,8 +210,8 @@ idTermFold = TermFold {
mapTermType :: (RttiType -> Type) -> Term -> Term
mapTermType f = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
- fSuspension = \ct ty hval n ->
- Suspension ct (f ty) hval n,
+ fSuspension = \ct ty hval n i ->
+ Suspension ct (f ty) hval n i,
fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
fRefWrap = \ty t -> RefWrap (f ty) t}
@@ -217,8 +219,8 @@ mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
mapTermTypeM f = foldTermM TermFoldM {
fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
fPrimM = (return.) . Prim,
- fSuspensionM = \ct ty hval n ->
- f ty >>= \ty' -> return $ Suspension ct ty' hval n,
+ fSuspensionM = \ct ty hval n i ->
+ f ty >>= \ty' -> return $ Suspension ct ty' hval n i,
fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
@@ -226,7 +228,7 @@ termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
- fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
+ fSuspension = \_ ty _ _ _ -> tyCoVarsOfType ty,
fPrim = \ _ _ -> emptyVarSet,
fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
@@ -284,8 +286,24 @@ ppr_termM _ _ t = ppr_termM1 t
ppr_termM1 :: Monad m => Term -> m SDoc
ppr_termM1 Prim{valRaw=words, ty=ty} =
return $ repPrim (tyConAppTyCon ty) words
-ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
- return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty))
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} =
+ return $ hcat $
+ [ char '_'
+ , whenPprDebug $
+ space <>
+ dcolon <>
+ pprSigmaType ty
+ ] ++
+ [ whenPprDebug $
+ space <>
+ char '<' <>
+ text (ipSrcFile ipe) <>
+ char ':' <>
+ text (ipSrcSpan ipe) <>
+ char '>'
+ | Just ipe <- [mipe]
+ , not $ null $ ipSrcFile ipe
+ ]
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
| otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty
ppr_termM1 Term{} = panic "ppr_termM1 - Term"
@@ -773,12 +791,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
clos <- trIO $ GHCi.getClosure interp a
- return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing)
+ ipe <- trIO $ GHCi.whereFrom interp a
+ return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe)
go !max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
clos <- trIO $ GHCi.getClosure interp a
+ ipe <- trIO $ GHCi.whereFrom interp a
case clos of
-- Thunks we may want to force
t | isThunk t && force -> do
@@ -797,7 +817,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
BlackholeClosure{indirectee=ind} -> do
traceTR (text "Following a BLACKHOLE")
ind_clos <- trIO (GHCi.getClosure interp ind)
- let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
+ ind_ipe <- trIO (GHCi.whereFrom interp ind)
+ let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing ind_ipe)
case ind_clos of
-- TSO and BLOCKING_QUEUE cases
BlockingQueueClosure{} -> return_bh_value
@@ -869,7 +890,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
_ -> do
traceTR (text "Unknown closure:" <+>
text (show (fmap (const ()) clos)))
- return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing)
+ return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe)
-- insert NewtypeWraps around newtypes
expandNewtypes = foldTerm idTermFold { fTerm = worker } where
@@ -885,8 +906,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- Avoid returning types where predicates have been expanded to dictionaries.
fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
- worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
- | otherwise = Suspension ct ty hval n
+ worker ct ty hval n i | isFunTy ty = Suspension ct (dictsView ty) hval n i
+ | otherwise = Suspension ct ty hval n i
extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
-> GenClosure ForeignHValue -> [Type] -> TcM [Term]
@@ -1384,8 +1405,8 @@ zonkTerm :: Term -> TcM Term
zonkTerm = foldTermM (TermFoldM
{ fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
return (Term ty' dc v tt)
- , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
- return (Suspension ct ty v b)
+ , fSuspensionM = \ct ty v b i -> zonkRttiType ty >>= \ty ->
+ return (Suspension ct ty v b i)
, fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
return$ NewtypeWrap ty' dc t
, fRefWrapM = \ty t -> return RefWrap `ap`
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Runtime.Interpreter
, breakpointStatus
, getBreakpointVar
, getClosure
+ , whereFrom
, getModBreaks
, seqHValue
, evalBreakpointToId
@@ -115,6 +116,7 @@ import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
+import qualified GHC.InfoProv as InfoProv
import GHC.Builtin.Names
import GHC.Types.Name
@@ -402,6 +404,11 @@ getClosure interp ref =
mb <- interpCmd interp (GetClosure hval)
mapM (mkFinalizedHValue interp) mb
+whereFrom :: Interp -> ForeignHValue -> IO (Maybe InfoProv.InfoProv)
+whereFrom interp ref =
+ withForeignRef ref $ \hval -> do
+ interpCmd interp (WhereFrom hval)
+
-- | Send a Seq message to the iserv process to force a value #2950
seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue interp unit_env ref =
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -34,6 +34,7 @@ import GHCi.BreakArray
import GHCi.ResolvedBCO
import GHC.LanguageExtensions
+import GHC.InfoProv
import qualified GHC.Exts.Heap as Heap
import GHC.ForeignSrcLang
import GHC.Fingerprint
@@ -224,6 +225,12 @@ data Message a where
:: HValueRef
-> Message (Heap.GenClosure HValueRef)
+ -- | Remote interface to GHC.InfoProv.whereFrom. This is used by
+ -- the GHCi debugger to inspect the provenance of thunks for :print.
+ WhereFrom
+ :: HValueRef
+ -> Message (Maybe InfoProv)
+
-- | Evaluate something. This is used to support :force in GHCi.
Seq
:: HValueRef
@@ -240,6 +247,7 @@ data Message a where
:: String
-> Message (RemotePtr BreakModule)
+
deriving instance Show (Message a)
@@ -511,6 +519,15 @@ instance Binary Heap.StgInfoTable
instance Binary Heap.ClosureType
instance Binary Heap.PrimType
instance Binary a => Binary (Heap.GenClosure a)
+instance Binary InfoProv where
+#if MIN_VERSION_base(4,20,0)
+ get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
+ put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8)
+ = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8
+#else
+ get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get
+ put (InfoProv x1 x2 x3 x4 x5 x6 x7) = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7
+#endif
data Msg = forall a . (Binary a, Show a) => Msg (Message a)
@@ -560,6 +577,7 @@ getMessage = do
38 -> Msg <$> (ResumeSeq <$> get)
39 -> Msg <$> (NewBreakModule <$> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
+ 41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
putMessage :: Message a -> Put
@@ -606,6 +624,7 @@ putMessage m = case m of
ResumeSeq a -> putWord8 38 >> put a
NewBreakModule name -> putWord8 39 >> put name
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
+ WhereFrom a -> putWord8 41 >> put a
{-
Note [Parallelize CreateBCOs serialization]
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -19,6 +19,7 @@ import GHCi.CreateBCO
import GHCi.InfoTable
#endif
+import qualified GHC.InfoProv as InfoProv
import GHCi.FFI
import GHCi.Message
import GHCi.ObjLink
@@ -115,6 +116,8 @@ run m = case m of
GetClosure ref -> do
clos <- Heap.getClosureData =<< localRef ref
mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
+ WhereFrom ref ->
+ InfoProv.whereFrom =<< localRef ref
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfc3056528d1c1e248bb175781c5a8d90a2958d5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfc3056528d1c1e248bb175781c5a8d90a2958d5
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/20250219/2aafb170/attachment-0001.html>
More information about the ghc-commits
mailing list