Commit 0fa697bc authored by David Himmelstrup's avatar David Himmelstrup
Browse files

breakpointCond

parent a9da016a
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment