Extend the GHC API with breakpoints and breakpoint handlers

The entry point is:
setBreakpointHandler :: Session -> BkptHandler Module -> IO ()

diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs
new file mode 100644 (file)
index 0000000..8bb1716
--- /dev/null
+++ b/compiler/main/Breakpoints.hs
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------\r
+--\r
+-- GHC API breakpoints. This module includes the main API (BkptHandler) and\r
+-- utility code for implementing a client to this API used in GHCi \r
+--\r
+-- Pepe Iborra (supported by Google SoC) 2006\r
+--\r
+-----------------------------------------------------------------------------\r
+\r
+module Breakpoints where\r
+\r
+import {-#SOURCE#-} HscTypes     ( Session )\r
+\r
+data BkptHandler a = BkptHandler {\r
+     handleBreakpoint  :: forall b. Session -> [(Id,HValue)] -> BkptLocation a ->  String -> b -> IO b\r
+   , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool\r
+   }\r
+\r
+nullBkptHandler = BkptHandler {\r
+    isAutoBkptEnabled = \ _ _     -> return False,\r
+    handleBreakpoint  = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b\r
+                              }\r
+\r
+type BkptLocation a = (a, SiteNumber)\r
+type SiteNumber   = Int\r

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 736aff3..1799033 100644 (file)
--- 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 (file)
--- 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 (file)
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