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
#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
import qualified Id ( setIdType )
import IdInfo ( GlobalIdDetails(..) )
import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
-import PrelNames ( breakpointJumpName )
+import PrelNames ( breakpointJumpName, breakpointCondJumpName )
#endif
-- The GHC interface
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 $
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
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
-- Others
otherwiseIdName,
plusIntegerName, timesIntegerName,
- eqStringName, assertName, breakpointName, assertErrorName,
- runSTRepName,
+ eqStringName, assertName, breakpointName, breakpointCondName,
+ assertErrorName, runSTRepName,
printName, fstName, sndName,
-- MonadFix
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
assertErrorIdKey = mkPreludeMiscIdUnique 61
breakpointIdKey = mkPreludeMiscIdUnique 62
-breakpointJumpIdKey = mkPreludeMiscIdUnique 63
+breakpointCondIdKey = mkPreludeMiscIdUnique 63
+breakpointJumpIdKey = mkPreludeMiscIdUnique 64
+breakpointCondJumpIdKey = mkPreludeMiscIdUnique 65
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 80
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 )
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
]
\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
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)))
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
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 )
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