diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index a87ccf9..fbd95a5 100644 --- a/haskell-debugger.cabal +++ b/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, diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 84a4ef4..da00bad 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index 61ef7dc..c0aec34 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -34,6 +34,8 @@ import GHC.Debugger.Session.Builtin 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 @@ debugValueTerm term = do 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 @@ debugFieldsTerm term = do 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 @@ listTermToTermsList Term{subTerms=[head_term, tail_term]} (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" ( -> 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs new file mode 100644 index 0000000..6c8b0ae --- /dev/null +++ b/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" ( -> 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot new file mode 100644 index 0000000..ddcd67d --- /dev/null +++ b/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