From ead424357937b23f30295608b467aacbc3a8a8bc Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Dec 2006 18:40:27 +0000 Subject: [PATCH] Extend the GHC API with breakpoints and breakpoint handlers The entry point is: setBreakpointHandler :: Session -> BkptHandler Module -> IO () --- compiler/main/Breakpoints.hs | 25 +++++++++++++ compiler/main/DynFlags.hs | 9 ++++- compiler/main/GHC.hs | 78 ++++++++++++++++++++++++++++++++++++++- compiler/main/HscTypes.lhs-boot | 3 ++ 4 files changed, 112 insertions(+), 3 deletions(-) create mode 100644 compiler/main/Breakpoints.hs create mode 100644 compiler/main/HscTypes.lhs-boot diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs new file mode 100644 index 0000000..8bb1716 --- /dev/null +++ b/compiler/main/Breakpoints.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- +-- GHC API breakpoints. This module includes the main API (BkptHandler) and +-- utility code for implementing a client to this API used in GHCi +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- + +module Breakpoints where + +import {-#SOURCE#-} HscTypes ( Session ) + +data BkptHandler a = BkptHandler { + handleBreakpoint :: forall b. Session -> [(Id,HValue)] -> BkptLocation a -> String -> b -> IO b + , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool + } + +nullBkptHandler = BkptHandler { + isAutoBkptEnabled = \ _ _ -> return False, + handleBreakpoint = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b + } + +type BkptLocation a = (a, SiteNumber) +type SiteNumber = Int diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 736aff3..1799033 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -84,6 +84,9 @@ import Util ( split ) import Data.Char ( isDigit, isUpper ) import System.IO ( hPutStrLn, stderr ) +import Breakpoints ( BkptHandler ) +import Module ( ModuleName ) + -- ----------------------------------------------------------------------------- -- DynFlags @@ -303,6 +306,9 @@ data DynFlags = DynFlags { -- message output log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO () + + -- breakpoint handling + ,bkptHandler :: Maybe (BkptHandler Module) } data HscTarget @@ -411,7 +417,8 @@ defaultDynFlags = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - + + bkptHandler = Nothing, flags = [ Opt_ReadUserPackageConf, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bd772fb..c292cf0 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -82,6 +82,7 @@ module GHC ( compileExpr, HValue, dynCompileExpr, lookupName, + getBreakpointHandler, setBreakpointHandler, obtainTerm, #endif @@ -343,6 +344,12 @@ defaultCleanupHandler dflags inner = inner +#if defined(GHCI) +GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)]) + -- stores the current breakpoint handler to help setContext to + -- restore it after a context change +#endif + -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed @@ -1924,7 +1931,7 @@ setContext :: Session -> [Module] -- entire top level scope of these modules -> [Module] -- exports only of these modules -> IO () -setContext (Session ref) toplev_mods export_mods = do +setContext sess@(Session ref) toplev_mods export_mods = do hsc_env <- readIORef ref let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env @@ -1935,7 +1942,7 @@ setContext (Session ref) toplev_mods export_mods = do writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, ic_exports = export_mods, ic_rn_gbl_env = all_env }} - + reinstallBreakpointHandlers sess -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv @@ -2194,6 +2201,73 @@ showModule s mod_summary = withSession s $ \hsc_env -> do where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) +getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module)) +getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler + +setBreakpointHandler :: Session -> BkptHandler Module -> IO () +setBreakpointHandler session handler = do + dflags <- getSessionDynFlags session + setSessionDynFlags session dflags{ bkptHandler = Just handler } + let linkEnv = [ ( breakpointJumpName + , unsafeCoerce# (jumpFunction session handler)) + , ( breakpointCondJumpName + , unsafeCoerce# (jumpCondFunction session handler)) + , ( breakpointAutoJumpName + , unsafeCoerce# (jumpAutoFunction session handler)) + ] + writeIORef v_bkptLinkEnv linkEnv + dflags <- getSessionDynFlags session + reinstallBreakpointHandlers session + +reinstallBreakpointHandlers :: Session -> IO () +reinstallBreakpointHandlers session = do + dflags <- getSessionDynFlags session + let mode = ghcMode dflags + when (mode == Interactive) $ do + linkEnv <- readIORef v_bkptLinkEnv + initDynLinker dflags + extendLinkEnv linkEnv + +type SiteInfo = (String, String, SiteNumber) +jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> Int -> [Opaque] + -> SiteInfo -> String -> b -> b +jumpCondFunction :: Session -> BkptHandler Module -> Int -> [Opaque] + -> SiteInfo -> String -> Bool -> b -> b +jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a + -> String -> b -> IO b + +jumpCondFunction _ _ _ _ _ _ False b = b +jumpCondFunction session handler ptr hValues siteInfo locmsg True b + = jumpFunction session handler ptr hValues siteInfo locmsg b + +jumpFunction session handler ptr hValues siteInfo locmsg b + | site <- mkSite siteInfo + = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b + +jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = + do + ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) + ASSERT (length ids == length wrapped_hValues) return () + let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues] + handleBreakpoint handler session (zip ids hValues) site locmsg b + +jumpAutoFunction session handler ptr hValues siteInfo locmsg b + | site <- mkSite siteInfo + = unsafePerformIO $ do + break <- isAutoBkptEnabled handler session site + if break + then jumpFunctionM session handler ptr hValues site locmsg b + else return b + +jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b + | site <- mkSite siteInfo + = unsafePerformIO $ do + jumpFunctionM session handler ptr hValues site locmsg b + +mkSite :: SiteInfo -> BkptLocation Module +mkSite (pkgName, modName, sitenum) = + (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum) + obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) obtainTerm sess force id = withSession sess $ \hsc_env -> getHValue (varName id) >>= traverse (cvObtainTerm hsc_env force Nothing) diff --git a/compiler/main/HscTypes.lhs-boot b/compiler/main/HscTypes.lhs-boot new file mode 100644 index 0000000..c80d231 --- /dev/null +++ b/compiler/main/HscTypes.lhs-boot @@ -0,0 +1,3 @@ +> module HscTypes where +> +> data Session \ No newline at end of file -- 1.7.10.4