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

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)
 
 
@@ -515,6 +523,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)
 
@@ -564,6 +581,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
@@ -610,6 +628,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