From 0fa697bca153468bf073aad1fe02d5b4055059f2 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Tue, 2 May 2006 17:43:40 +0000 Subject: [PATCH] breakpointCond --- compiler/deSugar/DsExpr.lhs | 4 ++-- compiler/ghci/InteractiveUI.hs | 13 ++++++++++--- compiler/prelude/PrelNames.lhs | 14 +++++++++++--- compiler/rename/RnExpr.lhs | 36 ++++++++++++++++++++++++------------ compiler/typecheck/TcRnMonad.lhs | 35 ++++++++++++++++++++--------------- 5 files changed, 67 insertions(+), 35 deletions(-) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index e8e9e7b..a93b1d7 100644 --- 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 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4