breakpointCond

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index e8e9e7b..a93b1d7 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -11,7 +11,7 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
 import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
 import IOEnv            ( ioToIOEnv )
-import PrelNames        ( breakpointJumpName )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 import TysWiredIn       ( unitTy )
 import TypeRep          ( Type(..) )
 #endif
@@ -215,7 +215,7 @@ dsExpr expr@(HsLam a_Match)
 #if defined(GHCI) && defined(BREAKPOINT)
 dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
     | HsVar funId <- fun
-    , idName funId == breakpointJumpName
+    , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
     , ids <- filter (not.hasTyVar.idType) (extractIds arg)
     = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
          stablePtr <- ioToIOEnv $ newStablePtr ids

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 9e9c262..d45bddc 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -26,7 +26,7 @@ import TcType           ( tidyTopType )
 import qualified Id     ( setIdType )
 import IdInfo           ( GlobalIdDetails(..) )
 import Linker           ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker  )
-import PrelNames        ( breakpointJumpName )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 #endif
 
 -- The GHC interface
@@ -209,6 +209,11 @@ printScopeMsg session location ids
         nest 2 (pprWithCommas showId ids)
     where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
 
+jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
+jumpCondFunction session ptr hValues location True b = b
+jumpCondFunction session ptr hValues location False b
+    = jumpFunction session ptr hValues location b
+
 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
     = unsafePerformIO $
@@ -251,7 +256,8 @@ interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 interactiveUI session srcs maybe_expr = do
 #if defined(GHCI) && defined(BREAKPOINT)
    initDynLinker =<< GHC.getSessionDynFlags session
-   extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
+   extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
+                 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
 #endif
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
@@ -831,7 +837,8 @@ afterLoad ok session = do
   setContextAfterLoad session graph'
   modulesLoadedMsg ok (map GHC.ms_mod graph')
 #if defined(GHCI) && defined(BREAKPOINT)
-  io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
+  io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
+                    ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
 #endif
 
 setContextAfterLoad session [] = do

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index ca63e96..3d57033 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -184,8 +184,8 @@ basicKnownKeyNames
        -- Others
        otherwiseIdName, 
        plusIntegerName, timesIntegerName,
-       eqStringName, assertName, breakpointName, assertErrorName,
-        runSTRepName,
+       eqStringName, assertName, breakpointName, breakpointCondName,
+        assertErrorName, runSTRepName,
        printName, fstName, sndName,
 
        -- MonadFix
@@ -477,11 +477,17 @@ andName             = varQual pREL_BASE FSLIT("&&")         andIdKey
 orName           = varQual pREL_BASE FSLIT("||")         orIdKey
 assertName        = varQual pREL_BASE FSLIT("assert")     assertIdKey
 breakpointName    = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey
+breakpointCondName= varQual pREL_BASE FSLIT("breakpointCond") breakpointCondIdKey
 breakpointJumpName
     = mkInternalName
         breakpointJumpIdKey
         (mkOccNameFS varName FSLIT("breakpointJump"))
         noSrcLoc
+breakpointCondJumpName
+    = mkInternalName
+        breakpointCondJumpIdKey
+        (mkOccNameFS varName FSLIT("breakpointCondJump"))
+        noSrcLoc
 
 -- PrelTup
 fstName                  = varQual pREL_TUP FSLIT("fst") fstIdKey
@@ -901,7 +907,9 @@ lazyIdKey                 = mkPreludeMiscIdUnique 60
 assertErrorIdKey             = mkPreludeMiscIdUnique 61
 
 breakpointIdKey               = mkPreludeMiscIdUnique 62
-breakpointJumpIdKey           = mkPreludeMiscIdUnique 63
+breakpointCondIdKey           = mkPreludeMiscIdUnique 63
+breakpointJumpIdKey           = mkPreludeMiscIdUnique 64
+breakpointCondJumpIdKey       = mkPreludeMiscIdUnique 65
 
 -- Parallel array functions
 nullPIdKey                   = mkPreludeMiscIdUnique 80

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 716a85a..87af074 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -34,7 +34,8 @@ import PrelNames      ( thFAKE, hasKey, assertIdKey, assertErrorName,
                          loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
                          negateName, thenMName, bindMName, failMName )
 #if defined(GHCI) && defined(BREAKPOINT)
-import PrelNames        ( breakpointJumpName, undefined_RDR, breakpointIdKey )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName
+                        , undefined_RDR, breakpointIdKey, breakpointCondIdKey )
 import UniqFM           ( eltsUFM )
 import DynFlags         ( GhcMode(..) )
 import SrcLoc           ( srcSpanFile, srcSpanStartLine )
@@ -99,20 +100,25 @@ rnExpr (HsVar v)
        lclEnv         <- getLclEnv
        ignore_asserts <- doptM Opt_IgnoreAsserts
        ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
+       ghcMode        <- getGhcMode
        let conds = [ (name `hasKey` assertIdKey
                       && not ignore_asserts,
                       do (e, fvs) <- mkAssertErrorExpr
                          return (e, fvs `addOneFV` name))
 #if defined(GHCI) && defined(BREAKPOINT)
                    , (name `hasKey` breakpointIdKey
-                      && not ignore_breakpoints,
-                      do ghcMode <- getGhcMode
-                         case ghcMode of
-                           Interactive
-                               -> do let isWantedName = not.isTyVarName
-                                     (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv))
-                                     return (e, fvs `addOneFV` name)
-                           _ -> return (HsVar name, unitFV name)
+                      && not ignore_breakpoints
+                      && ghcMode == Interactive,
+                         do let isWantedName = not.isTyVarName
+                            (e, fvs) <- mkBreakpointExpr (filter isWantedName (eltsUFM localRdrEnv))
+                            return (e, fvs `addOneFV` name)
+                     )
+                   , (name `hasKey` breakpointCondIdKey
+                      && not ignore_breakpoints
+                      && ghcMode == Interactive,
+                         do let isWantedName = not.isTyVarName
+                            (e, fvs) <- mkBreakpointCondExpr (filter isWantedName (eltsUFM localRdrEnv))
+                            return (e, fvs `addOneFV` name)
                      )
 #endif
                    ]
@@ -941,8 +947,14 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
 
 \begin{code}
 #if defined(GHCI) && defined(BREAKPOINT)
-mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakPointExpr scope
+mkBreakpointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakpointExpr = mkBreakpointExpr' breakpointJumpName
+
+mkBreakpointCondExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakpointCondExpr = mkBreakpointExpr' breakpointCondJumpName
+
+mkBreakpointExpr' :: Name -> [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakpointExpr' breakpointFunc scope
     = do sloc <- getSrcSpanM
          undef <- lookupOccRn undefined_RDR
          let inLoc = L sloc
@@ -951,7 +963,7 @@ mkBreakPointExpr scope
              mkExpr' fnName [] = inLoc (HsVar fnName)
              mkExpr' fnName (arg:args)
                  = lHsApp (mkExpr' fnName args) (inLoc arg)
-             expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg]
+             expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, HsLit msg]
              mkScopeArg args
                  = unLoc $ mkExpr undef (map HsVar args)
              msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 4fa3d8d..a287014 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -16,8 +16,8 @@ import Var              ( mkTyVar, mkGlobalId )
 import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
 import OccName          ( mkOccName, tvName )
 import SrcLoc           ( noSrcLoc  )
-import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy )
-import PrelNames        ( breakpointJumpName )
+import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy, boolTy )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 import NameEnv          ( mkNameEnv )
 #endif
 
@@ -29,8 +29,7 @@ import HscTypes               ( HscEnv(..), ModGuts(..), ModIface(..),
                          Deprecs(..), FixityEnv, FixItem, 
                          lookupType, unQualInScope )
 import Module          ( Module, unitModuleEnv )
-import RdrName         ( GlobalRdrEnv, emptyGlobalRdrEnv,      
-                         LocalRdrEnv, emptyLocalRdrEnv )
+import RdrName         ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
 import Name            ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
 import Type            ( Type )
 import TcType          ( tcIsTyVarTy, tcGetTyVar )
@@ -139,17 +138,23 @@ initTc hsc_env hsc_src mod do_this
                           unique <- newUnique ;
                           let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                 tyvar = mkTyVar var liftedTypeKind;
-                                breakpointJumpType = mkGlobalId
-                                                     (VanillaGlobal)
-                                                     (breakpointJumpName)
-                                                     (FunTy intTy
-                                                      (FunTy (mkListTy unitTy)
-                                                       (FunTy stringTy
-                                                        (ForAllTy tyvar
-                                                         (FunTy (TyVarTy tyvar)
-                                                          (TyVarTy tyvar))))))
-                                                     (vanillaIdInfo);
-                                new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+                                basicType extra = (FunTy intTy
+                                                   (FunTy (mkListTy unitTy)
+                                                    (FunTy stringTy
+                                                     (ForAllTy tyvar
+                                                      (extra
+                                                       (FunTy (TyVarTy tyvar)
+                                                        (TyVarTy tyvar)))))));
+                                breakpointJumpType
+                                    = mkGlobalId VanillaGlobal breakpointJumpName
+                                                 (basicType id) vanillaIdInfo;
+                                breakpointCondJumpType
+                                    = mkGlobalId VanillaGlobal breakpointCondJumpName
+                                                 (basicType (FunTy boolTy)) vanillaIdInfo;
+                                new_env = mkNameEnv [(breakpointJumpName
+                                                     , AGlobal (AnId breakpointJumpType))
+                                                    ,(breakpointCondJumpName
+                                                     , AGlobal (AnId breakpointCondJumpType))];
                               };
                           r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
 #else