Extend the local bindings at a breakpoint with one for the wrapped expression

By popular request, in a breakpoint it is possible now to inspect the result of the expression wrapped by the breakpoint.

The user interface for this is right now preliminar; there is a new binding called '_result' at every breakpoint. Suggestions are welcome!

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 71248e4..869cde6 100644 (file)
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -47,15 +47,17 @@ import Data.IORef
 import Foreign.StablePtr
 import GHC.Exts
 #ifdef GHCI
-mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
-mkBreakpointExpr loc bkptFuncId = do
+mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
+mkBreakpointExpr loc bkptFuncId ty = do
         scope <- getScope
         mod   <- getModuleDs
+        u     <- newUnique
         let mod_name = moduleNameFS$ moduleName mod
+            valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc 
         when (not instrumenting) $
               warnDs (text "Extracted ids:" <+> (ppr scope $$ 
                                                    ppr (map idType scope)))
-        stablePtr <- ioToIOEnv $ newStablePtr scope
+        stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
         site      <- if instrumenting
                         then recordBkpt (srcSpanStart loc)
                         else return 0

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index adf4c3d..23db23f 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -192,12 +192,16 @@ dsLExpr :: LHsExpr Id -> DsM CoreExpr
 #if defined(GHCI)
 dsLExpr (L loc expr@(HsWrap w (HsVar v)))
     | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
+    , WpTyApp ty <- simpWrapper w
     = do areBreakpointsEnabled <- breakpoints_enabled
          if areBreakpointsEnabled
            then do
-              L _ breakpointExpr <- mkBreakpointExpr loc v
+              L _ breakpointExpr <- mkBreakpointExpr loc v ty
               dsLExpr (L loc $ HsWrap w breakpointExpr)
            else putSrcSpanDs loc $ dsExpr expr
+       where simpWrapper (WpCompose w1 WpHole) = w1
+             simpWrapper (WpCompose WpHole w1) = w1
+             simpWrapper w = w
 #endif
 
 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 169a99f..52212d6 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -2208,6 +2208,7 @@ foreign import "rts_evalStableIO"  {- safe -}
   -- more informative than the C type!
 -}
 
+
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 
@@ -2224,6 +2225,9 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
                      where
                         obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
+-----------------------------------------------------------------------------
+-- Breakpoint handlers
+
 getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
 getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
  
@@ -2251,6 +2255,9 @@ reinstallBreakpointHandlers session = do
     initDynLinker dflags 
     extendLinkEnv linkEnv
 
+-----------------------------------------------------------------------
+-- Jump functions
+
 type SiteInfo = (String, String, SiteNumber)
 jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> Int -> [Opaque] 
                                 -> SiteInfo -> String -> b -> b
@@ -2270,8 +2277,7 @@ jumpFunction session handler ptr hValues siteInfo 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]
+         let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
          handleBreakpoint handler session (zip ids hValues) site locmsg b
 
 jumpAutoFunction session handler ptr hValues siteInfo locmsg b