Add a cache for DebugViewInstances

haskell-debugger.cabal

@@ -65,6 +65,7 @@ library
                       GHC.Debugger.Utils,
                       GHC.Debugger.Runtime,
                       GHC.Debugger.Runtime.Instances,
+                      GHC.Debugger.Runtime.Instances.Discover,
 
                       GHC.Debugger.Runtime.Term.Key,
                       GHC.Debugger.Runtime.Term.Cache,

haskell-debugger/GHC/Debugger/Monad.hs

@@ -60,6 +60,8 @@ import GHC.Debugger.Session
 import GHC.Debugger.Session.Builtin
 import qualified GHC.Debugger.Breakpoint.Map as BM
 
+import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)
+
 -- | A debugger action.
 newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a }
   deriving ( Functor, Applicative, Monad, MonadIO
@@ -88,6 +90,9 @@ data DebuggerState = DebuggerState
       , termCache         :: IORef TermCache
       -- ^ TermCache
 
+      , rtinstancesCache :: IORef RuntimeInstancesCache
+      -- ^ RuntimeInstancesCache
+
       , genUniq           :: IORef Int
       -- ^ Generates unique ints
 
@@ -471,6 +476,7 @@ initialDebuggerState l hsDbgViewUid =
   DebuggerState <$> liftIO (newIORef BM.empty)
                 <*> liftIO (newIORef mempty)
                 <*> liftIO (newIORef mempty)
+                <*> liftIO (newIORef emptyRuntimeInstancesCache)
                 <*> liftIO (newIORef 0)
                 <*> pure hsDbgViewUid
                 <*> pure l

haskell-debugger/GHC/Debugger/Runtime/Instances.hs

@@ -1,19 +1,19 @@
 {-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments #-}
 module GHC.Debugger.Runtime.Instances where
 
 import Control.Exception
 import Control.Monad
 import Control.Monad.Reader
 
 import GHC
 import GHC.Builtin.Names
 import GHC.Core.TyCon
 import GHC.Core.Type
 import GHC.Driver.Config
 import GHC.Driver.Env
 import GHC.Driver.Main
 import GHC.HsToCore.Expr
 import GHC.HsToCore.Monad
 import GHC.Plugins
 import GHC.Rename.Env
 import GHC.Rename.Expr
@@ -34,6 +34,8 @@
 import GHC.Debugger.View.Class
 import GHC.Debugger.Logger as Logger
 
+import GHC.Debugger.Runtime.Instances.Discover
+
 --------------------------------------------------------------------------------
 -- * High level interface for 'DebugView' on 'Term's
 --------------------------------------------------------------------------------
@@ -45,7 +47,7 @@
   hsc_env <- getSession
   let interp = hscInterp hsc_env
   let ty = termType term
-  mbInst <- findDebugViewInstance ty
+  mbInst <- getDebugViewInstance ty
   case mbInst of
     Nothing -> return Nothing
     Just DebugViewInstance
@@ -95,7 +97,7 @@
   hsc_env <- getSession
   let interp = hscInterp hsc_env
   let ty = termType term
-  mbInst <- findDebugViewInstance ty
+  mbInst <- getDebugViewInstance ty
   case mbInst of
     Nothing -> return Nothing
     Just DebugViewInstance
@@ -149,127 +151,3 @@
     (head_term:) <$> listTermToTermsList tail_term'
 listTermToTermsList _ = pure []
 
---------------------------------------------------------------------------------
--- * Medium level interface for 'DebugView' on 'ForeignHValue's
---------------------------------------------------------------------------------
-
--- | A 'DebugView' instance wrapper to call on values on the (potentially
--- foreign) interpreter heap
-data DebugViewInstance = DebugViewInstance
-  { -- | 'debugValueIOWrapper' for a specific instance
-    instDebugValue  :: ForeignHValue -> IO (Either SomeException ForeignHValue)
-
-    -- | 'debugFieldsIOWrapper' for a specific instance
-  , instDebugFields :: ForeignHValue -> IO (Either SomeException ForeignHValue)
-
-    -- | 'VarValueIO' type
-    -- todo: pointless to compute this every time... (both of them)
-  , varValueIOTy  :: Type
-    -- | 'VarFieldsIO' type
-  , varFieldsIOTy :: Type
-  }
-
---------------------------------------------------------------------------------
--- * Impl. to find instance and load instance methods applied to right dictionary
---------------------------------------------------------------------------------
-
--- | Try to find the 'DebugView' instance for a given type using the
--- @haskell-debugger-view@ unit found at session set-up time (see
--- @'hsDbgViewUnitId'@)
-findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
-findDebugViewInstance needle_ty = do
-  hsc_env <- getSession
-
-  mhdv_uid <- getHsDebuggerViewUid
-  case mhdv_uid of
-    Just hdv_uid -> do
-      let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName
-      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr)
-
-      (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do
-
-        -- Types used by DebugView
-        varValueIOTy    <-  fmap mkTyConTy . tcLookupTyCon
-                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarValueIO"))
-        varFieldsIOTy   <-  fmap mkTyConTy . tcLookupTyCon
-                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldsIO"))
-
-        ioTyCon <- tcLookupTyCon ioTyConName
-
-        -- Try to compile and load an expression for all methods of `DebugView`
-        -- applied to the dictionary for the given Type (`needle_ty`)
-        let debugValueMN  = mthdRdrName "debugValueIOWrapper"
-            debugFieldsMN = mthdRdrName "debugFieldsIOWrapper"
-            debugValueWrapperMT =
-              mkVisFunTyMany needle_ty $
-                mkTyConApp ioTyCon [mkListTy varValueIOTy]
-            debugFieldsWrapperMT =
-              mkVisFunTyMany needle_ty $
-                mkTyConApp ioTyCon [mkListTy varFieldsIOTy]
-        !debugValue_fval  <- compileAndLoadMthd debugValueMN  debugValueWrapperMT
-        !debugFields_fval <- compileAndLoadMthd debugFieldsMN debugFieldsWrapperMT
-
-        let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
-            interp    = hscInterp hsc_env
-
-            -- If we hit a breakpoint while evaluating this, just keep going.
-            handleStatus (EvalBreak _ _ resume_ctxt _) = do
-              resume_ctxt_fhv <- mkFinalizedHValue interp resume_ctxt
-              handleStatus =<< Interp.resumeStmt interp eval_opts resume_ctxt_fhv
-            -- When completed, return value
-            handleStatus (EvalComplete _ (EvalException e)) =
-              return (Left (fromSerializableException e))
-            handleStatus (EvalComplete _ (EvalSuccess [hval])) =
-              return (Right hval)
-            handleStatus (EvalComplete _ (EvalSuccess _)) =
-              return (Left (SomeException (userError "unexpected more than one value bound for evaluation of DebugView method")))
-
-        return DebugViewInstance
-          { instDebugValue = \x_fval -> do
-              handleStatus =<< evalStmt interp eval_opts
-                (EvalThis debugValue_fval `EvalApp` EvalThis x_fval)
-          , instDebugFields = \x_fval -> do
-              handleStatus =<< evalStmt interp eval_opts
-                (EvalThis debugFields_fval `EvalApp` EvalThis x_fval)
-          , varValueIOTy
-          , varFieldsIOTy
-          }
-
-      case res of
-        Nothing -> do
-          logSDoc Logger.Debug $
-            text "Couldn't compile DebugView instance for" <+> ppr needle_ty $$ ppr err_msgs
-          -- The error is for debug purposes. We simply won't use a custom instance:
-          return Nothing
-        Just is ->
-          return $ Just is
-    Nothing ->
-      -- Custom view is disabled
-      return Nothing
-
--- | Try to compile and load a class method for the given type.
---
--- E.g. @compileAndLoadMthd "debugValue" (<ty> -> VarValue)@ returns the
--- foreign value for an expression @debugValue@ applied to the dictionary for
--- the requested type.
-compileAndLoadMthd :: RdrName -- ^ Name of method/name of function that takes dictionary
-                   -> Type    -- ^ The final type of expr when funct is alredy applied to dict
-                   -> TcM ForeignHValue
-compileAndLoadMthd mthName mthTy = do
-  hsc_env <- getTopEnv
-
-  let expr = nlHsVar mthName
-
-  -- Rn, Tc, desugar applied to DebugView dictionary
-  (expr', _)    <- rnExpr (unLoc expr)
-  (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)
-  ev            <- simplifyTop wcs
-  failIfErrsM -- Before Zonking! If solving the constraint failed, `ev == []`.
-  let final_exp = mkHsDictLet (EvBinds ev) (noLocA expr'')
-  tc_expr_final <- zonkTopLExpr final_exp
-  (_, Just ds_expr) <- initDsTc $ dsLExpr tc_expr_final
-
-  -- Compile to a BCO and load it
-  (mthd_fval, _, _) <- liftIO $ hscCompileCoreExpr hsc_env noSrcSpan ds_expr
-
-  return mthd_fval

haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs

@@ -0,0 +1,196 @@
+module GHC.Debugger.Runtime.Instances.Discover
+  (
+  -- * Runtime 'DebugView' instance
+    DebugViewInstance(..)
+
+  -- * Cache for runtime instances
+  , RuntimeInstancesCache
+  , getDebugViewInstance
+  , emptyRuntimeInstancesCache
+  ) where
+
+import Data.IORef
+import Data.Function ((&))
+import Control.Exception
+import Control.Monad.Reader
+
+import GHC
+import GHC.Builtin.Names
+import GHC.Core.TyCon
+import GHC.Core.Type
+import GHC.Core.Map.Type
+import GHC.Driver.Config
+import GHC.Driver.Env
+import GHC.Driver.Main
+import GHC.HsToCore.Expr
+import GHC.HsToCore.Monad
+import GHC.Plugins
+import GHC.Rename.Env
+import GHC.Rename.Expr
+import GHC.Runtime.Interpreter as Interp
+import GHC.Tc.Gen.Expr
+import GHC.Tc.Solver
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Zonk.Type
+import GHCi.Message
+
+import GHC.Debugger.Monad
+import GHC.Debugger.Session.Builtin
+import GHC.Debugger.Logger as Logger
+
+--------------------------------------------------------------------------------
+-- * The Cache-level interface for runtime 'DebugView' instances
+--------------------------------------------------------------------------------
+
+-- | Cache 'DebugView' instances found at runtime to avoid trying to find them again.
+-- If we found that a particular type doesn't have an instance, we record that as well.
+type RuntimeInstancesCache = TypeMap (Maybe DebugViewInstance)
+
+-- | Get a 'DebugViewInstance' for the given type, if one exists.
+-- Looks up in the cache and otherwise tries to find the instance.
+-- Returns @Nothing@ if no instance could be found.
+getDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
+getDebugViewInstance ty = do
+  rtinMapRef <- asks rtinstancesCache
+  rtinMap    <- readIORef rtinMapRef & liftIO
+  case lookupTypeMap rtinMap ty of
+    Nothing -> do
+      res <- findDebugViewInstance ty
+      writeIORef rtinMapRef
+        (extendTypeMap rtinMap ty res) & liftIO
+      return res
+    Just res ->
+      return res
+
+-- | An empty 'RuntimeInstancesCache'
+emptyRuntimeInstancesCache :: RuntimeInstancesCache
+emptyRuntimeInstancesCache = emptyTypeMap
+
+--------------------------------------------------------------------------------
+-- * Medium level interface for 'DebugView' on 'ForeignHValue's
+-- This is cached by GHC.Debugger.Runtime.Instances.Cache
+--------------------------------------------------------------------------------
+
+-- | A 'DebugView' instance wrapper to call on values on the (potentially
+-- foreign) interpreter heap
+data DebugViewInstance = DebugViewInstance
+  { -- | 'debugValueIOWrapper' for a specific instance
+    instDebugValue  :: ForeignHValue -> IO (Either SomeException ForeignHValue)
+
+    -- | 'debugFieldsIOWrapper' for a specific instance
+  , instDebugFields :: ForeignHValue -> IO (Either SomeException ForeignHValue)
+
+    -- | 'VarValueIO' type
+    -- todo: pointless to compute this every time... (both of them)
+  , varValueIOTy  :: Type
+    -- | 'VarFieldsIO' type
+  , varFieldsIOTy :: Type
+  }
+
+--------------------------------------------------------------------------------
+-- * Impl. to find instance and load instance methods applied to right dictionary
+--------------------------------------------------------------------------------
+
+-- | Try to find the 'DebugView' instance for a given type using the
+-- @haskell-debugger-view@ unit found at session set-up time (see
+-- @'hsDbgViewUnitId'@)
+findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
+findDebugViewInstance needle_ty = do
+  hsc_env <- getSession
+
+  mhdv_uid <- getHsDebuggerViewUid
+  case mhdv_uid of
+    Just hdv_uid -> do
+      let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName
+      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr)
+
+      (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do
+
+        -- Types used by DebugView
+        varValueIOTy    <-  fmap mkTyConTy . tcLookupTyCon
+                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarValueIO"))
+        varFieldsIOTy   <-  fmap mkTyConTy . tcLookupTyCon
+                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldsIO"))
+
+        ioTyCon <- tcLookupTyCon ioTyConName
+
+        -- Try to compile and load an expression for all methods of `DebugView`
+        -- applied to the dictionary for the given Type (`needle_ty`)
+        let debugValueMN  = mthdRdrName "debugValueIOWrapper"
+            debugFieldsMN = mthdRdrName "debugFieldsIOWrapper"
+            debugValueWrapperMT =
+              mkVisFunTyMany needle_ty $
+                mkTyConApp ioTyCon [mkListTy varValueIOTy]
+            debugFieldsWrapperMT =
+              mkVisFunTyMany needle_ty $
+                mkTyConApp ioTyCon [mkListTy varFieldsIOTy]
+        !debugValue_fval  <- compileAndLoadMthd debugValueMN  debugValueWrapperMT
+        !debugFields_fval <- compileAndLoadMthd debugFieldsMN debugFieldsWrapperMT
+
+        let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+            interp    = hscInterp hsc_env
+
+            -- If we hit a breakpoint while evaluating this, just keep going.
+            handleStatus (EvalBreak _ _ resume_ctxt _) = do
+              resume_ctxt_fhv <- mkFinalizedHValue interp resume_ctxt
+              handleStatus =<< Interp.resumeStmt interp eval_opts resume_ctxt_fhv
+            -- When completed, return value
+            handleStatus (EvalComplete _ (EvalException e)) =
+              return (Left (fromSerializableException e))
+            handleStatus (EvalComplete _ (EvalSuccess [hval])) =
+              return (Right hval)
+            handleStatus (EvalComplete _ (EvalSuccess _)) =
+              return (Left (SomeException (userError "unexpected more than one value bound for evaluation of DebugView method")))
+
+        return DebugViewInstance
+          { instDebugValue = \x_fval -> do
+              handleStatus =<< evalStmt interp eval_opts
+                (EvalThis debugValue_fval `EvalApp` EvalThis x_fval)
+          , instDebugFields = \x_fval -> do
+              handleStatus =<< evalStmt interp eval_opts
+                (EvalThis debugFields_fval `EvalApp` EvalThis x_fval)
+          , varValueIOTy
+          , varFieldsIOTy
+          }
+
+      case res of
+        Nothing -> do
+          logSDoc Logger.Debug $
+            text "Couldn't compile DebugView instance for" <+> ppr needle_ty $$ ppr err_msgs
+          -- The error is for debug purposes. We simply won't use a custom instance:
+          return Nothing
+        Just is ->
+          return $ Just is
+    Nothing ->
+      -- Custom view is disabled
+      return Nothing
+
+-- | Try to compile and load a class method for the given type.
+--
+-- E.g. @compileAndLoadMthd "debugValue" (<ty> -> VarValue)@ returns the
+-- foreign value for an expression @debugValue@ applied to the dictionary for
+-- the requested type.
+compileAndLoadMthd :: RdrName -- ^ Name of method/name of function that takes dictionary
+                   -> Type    -- ^ The final type of expr when funct is alredy applied to dict
+                   -> TcM ForeignHValue
+compileAndLoadMthd mthName mthTy = do
+  hsc_env <- getTopEnv
+
+  let expr = nlHsVar mthName
+
+  -- Rn, Tc, desugar applied to DebugView dictionary
+  (expr', _)    <- rnExpr (unLoc expr)
+  (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)
+  ev            <- simplifyTop wcs
+  failIfErrsM -- Before Zonking! If solving the constraint failed, `ev == []`.
+  let final_exp = mkHsDictLet (EvBinds ev) (noLocA expr'')
+  tc_expr_final <- zonkTopLExpr final_exp
+  (_, Just ds_expr) <- initDsTc $ dsLExpr tc_expr_final
+
+  -- Compile to a BCO and load it
+  (mthd_fval, _, _) <- liftIO $ hscCompileCoreExpr hsc_env noSrcSpan ds_expr
+
+  return mthd_fval

haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot

@@ -0,0 +1,7 @@
+module GHC.Debugger.Runtime.Instances.Discover where
+
+import GHC.Core.Map.Type
+
+type RuntimeInstancesCache = TypeMap (Maybe DebugViewInstance)
+data DebugViewInstance
+emptyRuntimeInstancesCache :: RuntimeInstancesCache