Allow inspecting arbitrarily deep structures and displaying forced strings in full

This is done by refactoring how we were preserving terms in a cache and
when how we were returning the fields of existing terms.

Namely, any nested-field we were getting by looking at the subterms of
the parent -- and the subterms of the parent were only traversed up to
depth 5.

In a structure such as (p = Depth "d=1" (Depth "d=2" (Depth "d=3" (Depth "d=4" (Depth "d=5" (Depth "d=6" OK))))))
only the top-most identifier "p" would get a Term cached and all nested fields were gotten from it.

Now, we've refactored and simplified the code s.t. getting this
right is much easier:

Every referenceable term (either directly by name or via a name + path
of fields) can be obtained by traversing the heap using
`GHC.Debugger.Runtime.obtainTerm`. They are indexed by the new
`TermKey` from `GHC.Debugger.Runtime.Term.Key`. Moreover,
`obtainTerm` uses a cache (`GHC.Debugger.Runtime.Term.Cache`) to avoid
redundant computation -- but if it misses the cache it always knows how
to reconstruct a term. The reconstruction for Ids is trivially
@obtainTermFromId@, while for Id+Paths it is done by recursively
`seq`ing the wanted subterms until the leaf is found and returned.

Fixes #8 and #9

Author: alt-romes

ghc-debugger.cabal

@@ -47,6 +47,11 @@ library
                       GHC.Debugger.Stopped,
                       GHC.Debugger.Stopped.Variables,
                       GHC.Debugger.Utils,
+                      GHC.Debugger.Runtime,
+
+                      GHC.Debugger.Runtime.Term.Key,
+                      GHC.Debugger.Runtime.Term.Cache,
+
                       GHC.Debugger.Monad,
                       GHC.Debugger.Interface.Messages
     -- other-modules:

ghc-debugger/GHC/Debugger/Evaluation.hs

@@ -153,5 +153,5 @@ inspectName n = do
     Nothing -> do
       liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n)
       pure Nothing
-    Just tt -> Just <$> tyThingToVarInfo 2 tt
+    Just tt -> Just <$> tyThingToVarInfo tt
 

ghc-debugger/GHC/Debugger/Monad.hs

@@ -42,6 +42,8 @@ import qualified Data.IntMap as IM
 import Control.Monad.Reader
 
 import GHC.Debugger.Interface.Messages
+import GHC.Debugger.Runtime.Term.Key
+import GHC.Debugger.Runtime.Term.Cache
 import System.Posix.Signals
 
 -- | A debugger action.
@@ -57,20 +59,21 @@ data DebuggerState = DebuggerState
       { activeBreakpoints :: IORef (ModuleEnv (IM.IntMap (BreakpointStatus, BreakpointKind)))
         -- ^ Maps a 'BreakpointId' in Trie representation to the
         -- 'BreakpointStatus' it was activated with.
-      , varReferences     :: IORef (IM.IntMap (Name, Term), NameEnv Int)
+
+      , varReferences     :: IORef (IM.IntMap TermKey, TermKeyMap Int)
       -- ^ When we're stopped at a breakpoint, this maps variable reference to
       -- Terms to allow further inspection and forcing by reference.
       --
       -- This map is only valid while stopped in this context. After stepping
       -- or resuming evaluation in any available way, this map becomes invalid
       -- and should therefore be cleaned.
       --
-      -- The NameEnv map is a reverse lookup map to find which references already exist for given names
-      , varFieldsMap      :: IORef (NameEnv (IM.IntMap Name))
-      -- ^ A mapping from Name to an IntMap mapping indices to their unique Names
-      -- e.g. `x :-> { 1 :-> _1, 2 :-> _2 }
-      -- This map allows us to re-use Names for sub-fields rather than creating
-      -- them new every time. See 'mkIndexVarName'
+      -- The TermKeyMap map is a reverse lookup map to find which references
+      -- already exist for given names
+
+      , termCache         :: IORef TermCache
+      -- ^ TermCache
+
       , genUniq           :: IORef Int
       -- ^ Generates unique ints
       }
@@ -309,54 +312,29 @@ getModuleByPath path = do
 --------------------------------------------------------------------------------
 
 -- | Find a variable's associated Term and Name by reference ('Int')
-lookupVarByReference :: Int -> Debugger (Maybe (Name, Term))
+lookupVarByReference :: Int -> Debugger (Maybe TermKey)
 lookupVarByReference i = do
   ioref <- asks varReferences
   (rm, _) <- readIORef ioref & liftIO
   return $ IM.lookup i rm
 
--- | Inserts a mapping from the given variable reference to the variable's
--- associated Term and the Name it is bound to for display
---
--- Returns: the variable reference (either a fresh one, or the existing one for this name)
-insertVarReference :: Name -> Term -> Debugger Int
-insertVarReference name term = do
-  ioref <- asks varReferences
-  (rm, nm) <- readIORef ioref & liftIO
-  (i, nm') <- case lookupNameEnv nm name of
-    Nothing       -> do
+-- | Finds or creates an integer var reference for the given 'TermKey'.
+-- TODO: Arguably, this mapping should be part of the debug-adapter, and
+-- ghc-debugger should deal in 'TermKey' terms only.
+getVarReference :: TermKey -> Debugger Int
+getVarReference key = do
+  ioref     <- asks varReferences
+  (rm, tkm) <- readIORef ioref & liftIO
+  (i, tkm') <- case lookupTermKeyMap key tkm of
+    Nothing -> do
       new_i <- freshInt
-      return (new_i, extendNameEnv nm name new_i)
-    Just existing ->
-      return (existing, nm)
-  let
-    rm' = IM.insert i (name, term) rm
-  writeIORef ioref (rm', nm') & liftIO
+      return (new_i, insertTermKeyMap key new_i tkm)
+    Just existing_i ->
+      return (existing_i, tkm)
+  let rm' = IM.insert i key rm
+  writeIORef ioref (rm', tkm') & liftIO
   return i
 
--- | Create or find the 'Name' for a parent Name by positional index
---
--- The name is cached the first time it is created and re-used for subsequent
--- accesses in the same context.
-mkPositionalVarFieldName :: Name {-^ Parent Name -} -> Int {-^ Index -} -> Debugger Name
-mkPositionalVarFieldName parent ix = do
-  vfm_ref <- asks varFieldsMap
-  vfm <- liftIO $ readIORef vfm_ref
-  let ixmap = case lookupNameEnv vfm parent of
-        Nothing  -> mempty
-        Just ixm -> ixm
-  case IM.lookup ix ixmap of
-    Just fieldName -> return fieldName
-    Nothing -> do
-      u <- liftIO $ uniqFromTag 'F'
-      let
-        fieldName
-          = mkDerivedInternalName (\nocc -> mkVarOcc ("_" ++ show @Int ix))
-                                  u parent
-      liftIO $ writeIORef vfm_ref $
-        extendNameEnv vfm parent (IM.insert ix fieldName ixmap)
-      return fieldName
-
 -- | Whenever we run a request that continues execution from the current
 -- suspended state, such as Next,Step,Continue, this function should be called
 -- to delete the variable references that become invalid as we leave the
@@ -367,17 +345,18 @@ mkPositionalVarFieldName parent ix = do
 -- See also section "Lifetime of Objects References" in the DAP specification.
 leaveSuspendedState :: Debugger ()
 leaveSuspendedState = do
-  -- TODO:
-  --  [ ] Preserve bindings introduced by evaluate requests?
   ioref <- asks varReferences
-  vfRef <- asks varFieldsMap
   liftIO $ writeIORef ioref mempty
-  liftIO $ writeIORef vfRef mempty
 
 --------------------------------------------------------------------------------
 -- Utilities
 --------------------------------------------------------------------------------
 
+defaultDepth :: Int
+defaultDepth =  2 -- the depth determines how much of the runtime structure is traversed.
+                  -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures
+                  -- so we only depth enough to get to the next level of subterms.
+
 -- | Evaluate a suspended Term to WHNF.
 --
 -- Used in @'getVariables'@ to reply to a variable introspection request.
@@ -393,9 +372,11 @@ seqTerm term = do
       () <- fromEvalResult r
       let
         forceThunks = False {- whether to force the thunk subterms -}
-        forceDepth  = 5
+        forceDepth  = defaultDepth
       cvObtainTerm hsc_env forceDepth forceThunks ty val
-    NewtypeWrap{wrapped_term} -> seqTerm wrapped_term
+    NewtypeWrap{wrapped_term} -> do
+      wrapped_term' <- seqTerm wrapped_term
+      return term{wrapped_term=wrapped_term'}
     _ -> return term
 
 -- | Evaluate a Term to NF

ghc-debugger/GHC/Debugger/Runtime.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-}
+module GHC.Debugger.Runtime where
+
+import Data.IORef
+import Control.Monad.Reader
+import Control.Monad.IO.Class
+import qualified Data.List as L
+
+import GHC
+import GHC.Types.Id
+import GHC.Types.FieldLabel
+import GHC.Tc.Utils.TcType
+import GHC.Runtime.Eval
+import GHC.Types.Unique.Supply (uniqFromTag)
+import GHC.Types.Name.Env
+
+import GHC.Debugger.Runtime.Term.Key
+import GHC.Debugger.Runtime.Term.Cache
+import GHC.Debugger.Monad
+
+-- | Obtain the runtime 'Term' from a 'TermKey'.
+--
+-- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the
+-- 'Term' if possible. On a cache miss the Term will be reconstructed from
+-- scratch and stored in the cache.
+obtainTerm :: TermKey -> Debugger Term
+obtainTerm key = do
+  tc_ref <- asks termCache
+  tc     <- liftIO $ readIORef tc_ref
+  case lookupTermCache key tc of
+    -- cache miss: reconstruct, then store.
+    Nothing ->
+      let
+        -- For boring types we want to get the value as it is (by traversing it to
+        -- the end), rather than stopping short and returning a suspension (e.g.
+        -- for the string tail), because boring types are printed whole rather than
+        -- being represented by an expandable structure.
+        depth i = if isBoringTy (GHC.idType i) then maxBound else defaultDepth
+
+        -- Recursively get terms until we hit the desired key.
+        getTerm = \case
+          FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i
+          FromPath k pf -> do
+            term <- getTerm k >>= \case
+              -- When the key points to a Suspension, the real thing should
+              -- already be forced. It's just that the shallow depth meant we
+              -- returned a Suspension nonetheless while recursing in `getTerm`.
+              t@Suspension{} -> do
+                t' <- seqTerm t
+                -- update term cache with intermediate values?
+                -- insertTermCache k t'
+                return t'
+              t -> return t
+            return $ case term of
+              Term{dc=Right dc, subTerms} -> case pf of
+                PositionalIndex ix -> subTerms !! (ix-1)
+                LabeledField fl    ->
+                  case L.findIndex (== fl) (map flSelector $ dataConFieldLabels dc) of
+                    Just ix -> subTerms !! (ix-1)
+                    Nothing -> error "Couldn't find labeled field in dataConFieldLabels"
+              NewtypeWrap{wrapped_term} ->
+                wrapped_term -- regardless of PathFragment
+              _ -> error "Unexpected term for the given TermKey"
+       in do
+        term <- getTerm key
+        liftIO $ writeIORef tc_ref (insertTermCache key term tc)
+        return term
+
+    -- cache hit
+    Just hit -> return hit
+
+-- | A boring type is one for which we don't care about the structure and would
+-- rather see "whole" when being inspected. Strings and literals are a good
+-- example, because it's more useful to see the string value than it is to see
+-- a linked list of characters where each has to be forced individually.
+isBoringTy :: Type -> Bool
+isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t
+                || isIntegerTy t || isNaturalTy t || isCharTy t
+
+

ghc-debugger/GHC/Debugger/Runtime/Term/Cache.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE GADTs #-}
+module GHC.Debugger.Runtime.Term.Cache where
+
+import GHC
+import GHC.Types.Id
+import GHC.Tc.Utils.TcType
+import GHC.Runtime.Eval
+import GHC.Types.Unique.Supply (uniqFromTag)
+import GHC.Types.Var.Env
+
+import GHC.Debugger.Runtime.Term.Key
+
+import Data.Map (Map)
+import qualified Data.Map as M
+
+--------------------------------------------------------------------------------
+-- * Term Cache
+--------------------------------------------------------------------------------
+
+-- | A term cache maps Names to Terms.
+--
+-- We use the term cache to avoid redundant computation forcing (unique) names
+-- we've already forced before.
+--
+-- A kind of trie map from 'TermKey's. The Map entry for no-path-fragments is
+-- the 'Term' of the original 'Id'.
+type TermCache = TermKeyMap Term
+
+-- | Lookup a 'TermKey' in a 'TermCache'.
+-- Returns @Nothing@ for a cache miss and @Just@ otherwise.
+lookupTermCache :: TermKey -> TermCache -> Maybe Term
+lookupTermCache = lookupTermKeyMap
+
+-- | Inserts a 'Term' for the given 'TermKey' in the 'TermCache'.
+--
+-- Overwrites existing values.
+insertTermCache :: TermKey -> Term -> TermCache -> TermCache
+insertTermCache = insertTermKeyMap
+
+--------------------------------------------------------------------------------
+-- * TermKeyMap
+--------------------------------------------------------------------------------
+
+-- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.
+type TermKeyMap a = IdEnv (Map [PathFragment] a)
+
+-- | Lookup a 'TermKey' in a 'TermKeyMap'.
+lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a
+lookupTermKeyMap key tc = do
+  let (i, path) = unconsTermKey key
+  path_map <- lookupVarEnv tc i
+  M.lookup path path_map
+
+-- | Inserts a 'Term' for the given 'TermKey' in the 'TermKeyMap'.
+--
+-- Overwrites existing values.
+insertTermKeyMap :: TermKey -> a -> TermKeyMap a -> TermKeyMap a
+insertTermKeyMap key term tc =
+  let
+    (i, path) = unconsTermKey key
+    new_map = case lookupVarEnv tc i of
+      Nothing           -> M.singleton path term
+      Just existing_map -> M.insert path term existing_map
+  in extendVarEnv tc i new_map

ghc-debugger/GHC/Debugger/Runtime/Term/Key.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE GADTs, ViewPatterns #-}
+module GHC.Debugger.Runtime.Term.Key where
+
+import Prelude hiding ((<>))
+
+import GHC
+import GHC.Utils.Outputable
+import GHC.Types.Id
+import GHC.Tc.Utils.TcType
+import GHC.Runtime.Eval
+import GHC.Types.Unique.Supply (uniqFromTag)
+import GHC.Types.Name.Env
+
+-- | A 'TermKey' serves to fetch a Term in a Debugger session.
+-- Note: A 'TermKey' is only valid in the stopped context it was created in.
+data TermKey where
+  -- | Obtain a term from an Id.
+  FromId :: Id -> TermKey
+
+  -- | Append a PathFragment to the current Term Key. Used to construct keys
+  -- for indexed and labeled fields.
+  FromPath :: TermKey -> PathFragment -> TermKey
+
+-- | A term may be identified by an 'Id' (such as a local variable) plus a list
+-- of 'PathFragment's to an arbitrarily nested field.
+data PathFragment
+  -- | A positional index is an index from 1 to inf
+  = PositionalIndex Int
+  -- | A labeled field indexes a datacon fields by name
+  | LabeledField Name
+  deriving (Eq, Ord)
+
+instance Outputable TermKey where
+  ppr (FromId i)          = ppr i
+  ppr (FromPath _ last_p) = ppr last_p
+
+instance Outputable PathFragment where
+  ppr (PositionalIndex i) = text "_" <> ppr i
+  ppr (LabeledField n)    = ppr n
+
+-- | >>> unconsTermKey (FromPath (FromPath (FromId hi) (Pos 1)) (Pos 2))
+-- (hi, [1, 2])
+unconsTermKey :: TermKey -> (Id, [PathFragment])
+unconsTermKey = go [] where
+  go acc (FromId i) = (i, reverse acc)
+  go acc (FromPath k p) = go (p:acc) k