From: Pepe Iborra Date: Sun, 10 Dec 2006 20:37:29 +0000 (+0000) Subject: The breakpoint primitive X-Git-Tag: 2006-12-17~14 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3a99fa889bdff0c86df20cb18c71d30e30a79b43 The breakpoint primitive --- diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs new file mode 100644 index 0000000..1abfb0c --- /dev/null +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- +-- Support code for instrumentation and expansion of the breakpoint combinator +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- + +\begin{code} +module DsBreakpoint( + dsAndThenMaybeInsertBreakpoint + , maybeInsertBreakpoint + , breakpoints_enabled + , mkBreakpointExpr + ) where + +import IOEnv ( ioToIOEnv ) +import TysPrim ( alphaTyVar ) +import TysWiredIn ( intTy, stringTy, mkTupleTy, mkListTy, boolTy ) +import PrelNames +import Module ( moduleName, moduleNameFS, modulePackageId ) +import PackageConfig ( packageIdFS) +import SrcLoc ( SrcLoc, Located(..), SrcSpan, srcSpanFile, + noLoc, noSrcLoc, isGoodSrcSpan, + srcLocLine, srcLocCol, srcSpanStart ) + +import TyCon ( isUnLiftedTyCon, tyConDataCons ) +import TypeRep ( Type(..) ) +import DataCon +import Type +import MkId ( unsafeCoerceId, lazyId ) +import Name ( Name, mkInternalName ) +import Var ( mkTyVar ) +import Id ( Id, idType, mkGlobalId, idName ) + +import IdInfo ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) ) +import BasicTypes ( Boxity(Boxed) ) +import OccName ( mkOccName, tvName ) + +import TcRnMonad +import HsSyn +import HsLit ( HsLit(HsString, HsInt) ) +import CoreSyn ( CoreExpr, Expr (App) ) +import CoreUtils ( exprType ) +import Outputable +import ErrUtils ( debugTraceMsg ) +import FastString ( mkFastString, unpackFS ) +import DynFlags ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) ) + +import DsMonad +import {-#SOURCE#-}DsExpr ( dsLExpr ) +import Control.Monad +import Data.IORef +import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr ) +import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# ) + +#if defined(GHCI) +mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id) +mkBreakpointExpr loc bkptFuncId = do + scope' <- getLocalBindsDs + mod <- getModuleDs + let scope = filter (isValidType .idType ) scope' + mod_name = moduleNameFS$ moduleName mod + if null scope && instrumenting + then return (l$ HsVar lazyId) + else do + when (not instrumenting) $ + warnDs (text "Extracted ids:" <+> (ppr scope $$ + ppr (map idType scope))) + stablePtr <- ioToIOEnv $ newStablePtr scope + site <- if instrumenting + then recordBkpt (srcSpanStart loc) + else return 0 + ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName + jumpFuncId <- mkJumpFunc bkptFuncId + let [opaqueDataCon] = tyConDataCons opaqueTyCon + opaqueId = dataConWrapId opaqueDataCon + opaqueTy = mkTyConApp opaqueTyCon [] + wrapInOpaque id = + l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId))) + (l(HsVar id))) + -- Yes, I know... I'm gonna burn in hell. + Ptr addr# = castStablePtrToPtr stablePtr + hvals = ExplicitList opaqueTy (map wrapInOpaque scope) + locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod)) + , HsLit (HsString mod_name) + , HsLit (HsInt (fromIntegral site))] + + funE = l$ HsVar jumpFuncId + ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))) + hvalE = l hvals + locE = l locInfo + msgE = l (srcSpanLit loc) + return$ l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE) + where l = L loc + nlTuple exps = ExplicitTuple (map noLoc exps) Boxed +-- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? + isValidType (FunTy a b) = isValidType a && isValidType b + isValidType (NoteTy _ t) = isValidType t + isValidType (AppTy a b) = isValidType a && isValidType b + isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts + isValidType _ = True + srcSpanLit :: SrcSpan -> HsExpr Id + srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) + instrumenting = idName bkptFuncId == breakpointAutoName + +mkJumpFunc :: Id -> DsM Id +mkJumpFunc bkptFuncId + | idName bkptFuncId == breakpointName + = build breakpointJumpName id + | idName bkptFuncId == breakpointCondName + = build breakpointCondJumpName (FunTy boolTy) + | idName bkptFuncId == breakpointAutoName + = build breakpointAutoJumpName id + where + tyvar = alphaTyVar + basicType extra opaqueTy = + (FunTy intTy + (FunTy (mkListTy opaqueTy) + (FunTy (mkTupleType [stringTy, stringTy, intTy]) + (FunTy stringTy + (ForAllTy tyvar + (extra + (FunTy (TyVarTy tyvar) + (TyVarTy tyvar)))))))) + build name extra = do + ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName + return$ mkGlobalId VanillaGlobal name + (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo + mkTupleType tys = mkTupleTy Boxed (length tys) tys + +#endif +\end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 2bb2cc4..554149c 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -9,15 +9,7 @@ Desugaring exporessions. module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" -#if defined(GHCI) && defined(BREAKPOINT) -import Foreign.StablePtr -import GHC.Exts -import IOEnv -import PrelNames -import TysWiredIn -import TypeRep -import TyCon -#endif + import Match import MatchLit @@ -29,8 +21,12 @@ import DsArrows import DsMonad #ifdef GHCI +import PrelNames +import DsBreakpoint -- Template Haskell stuff iff bootstrapped import DsMeta +#else +import DsBreakpoint #endif import HsSyn @@ -179,6 +175,7 @@ scrungleMatch var scrut body | x == var = Case scrut bndr ty alts scrungle (Let binds body) = Let binds (scrungle body) scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other)) + \end{code} %************************************************************************ @@ -189,10 +186,21 @@ scrungleMatch var scrut body \begin{code} dsLExpr :: LHsExpr Id -> DsM CoreExpr + +#if defined(GHCI) +dsLExpr (L loc expr@(HsWrap w (HsVar v))) + | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName] + = do areBreakpointsEnabled <- breakpoints_enabled + if areBreakpointsEnabled + then do + L _ breakpointExpr <- mkBreakpointExpr loc v + dsLExpr (L loc $ HsWrap w breakpointExpr) + else putSrcSpanDs loc $ dsExpr expr +#endif + dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr - dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar var) = returnDs (Var var) @@ -210,37 +218,6 @@ dsExpr expr@(HsLam a_Match) = matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) -> returnDs (mkLams binders matching_code) -#if defined(GHCI) && defined(BREAKPOINT) -dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsWrap _ fun)) (L loc arg))) _) - | HsVar funId <- fun - , idName funId `elem` [breakpointJumpName, breakpointCondJumpName] - , ids <- filter (isValidType . idType) (extractIds arg) - = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids)) - stablePtr <- ioToIOEnv $ newStablePtr ids - -- Yes, I know... I'm gonna burn in hell. - let Ptr addr# = castStablePtrToPtr stablePtr - funCore <- dsLExpr realFun - argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))) - hvalCore <- dsLExpr (L loc (extractHVals ids)) - return ((funCore `App` argCore) `App` hvalCore) - where extractIds :: HsExpr Id -> [Id] - extractIds (HsApp fn arg) - | HsVar argId <- unLoc arg - = argId:extractIds (unLoc fn) - | HsWrap co_fn arg' <- unLoc arg - , HsVar argId <- arg' -- SLPJ: not sure what is going on here - = error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn) - extractIds x = [] - extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids) - -- checks for tyvars and unlifted kinds. - isValidType (TyVarTy _) = False - isValidType (FunTy a b) = isValidType a && isValidType b - isValidType (NoteTy _ t) = isValidType t - isValidType (AppTy a b) = isValidType a && isValidType b - isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts - isValidType _ = True -#endif - dsExpr expr@(HsApp fun arg) = dsLExpr fun `thenDs` \ core_fun -> dsLExpr arg `thenDs` \ core_arg -> diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 9ff85fa..9c51339 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -186,6 +186,7 @@ basicKnownKeyNames otherwiseIdName, plusIntegerName, timesIntegerName, eqStringName, assertName, breakpointName, breakpointCondName, + breakpointAutoName, opaqueTyConName, assertErrorName, runSTRepName, printName, fstName, sndName, @@ -490,6 +491,9 @@ orName = varQual gHC_BASE FSLIT("||") orIdKey assertName = varQual gHC_BASE FSLIT("assert") assertIdKey breakpointName = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey +breakpointAutoName= varQual gHC_BASE FSLIT("breakpointAuto") breakpointAutoIdKey +opaqueTyConName = tcQual gHC_BASE FSLIT("Opaque") opaqueTyConKey + breakpointJumpName = mkInternalName breakpointJumpIdKey @@ -500,6 +504,11 @@ breakpointCondJumpName breakpointCondJumpIdKey (mkOccNameFS varName FSLIT("breakpointCondJump")) noSrcLoc +breakpointAutoJumpName + = mkInternalName + breakpointAutoJumpIdKey + (mkOccNameFS varName FSLIT("breakpointAutoJump")) + noSrcLoc -- PrelTup fstName = varQual dATA_TUP FSLIT("fst") fstIdKey @@ -819,6 +828,7 @@ rightCoercionTyConKey = mkPreludeTyConUnique 96 instCoercionTyConKey = mkPreludeTyConUnique 97 unsafeCoercionTyConKey = mkPreludeTyConUnique 98 +opaqueTyConKey = mkPreludeTyConUnique 103 ---------------- Template Haskell ------------------- -- USES TyConUniques 100-129 @@ -931,10 +941,12 @@ assertErrorIdKey = mkPreludeMiscIdUnique 61 breakpointIdKey = mkPreludeMiscIdUnique 62 breakpointCondIdKey = mkPreludeMiscIdUnique 63 -breakpointJumpIdKey = mkPreludeMiscIdUnique 64 -breakpointCondJumpIdKey = mkPreludeMiscIdUnique 65 +breakpointAutoIdKey = mkPreludeMiscIdUnique 64 +breakpointJumpIdKey = mkPreludeMiscIdUnique 65 +breakpointCondJumpIdKey = mkPreludeMiscIdUnique 66 +breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 67 -inlineIdKey = mkPreludeMiscIdUnique 66 +inlineIdKey = mkPreludeMiscIdUnique 68 -- Parallel array functions nullPIdKey = mkPreludeMiscIdUnique 80 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 211ed58..1c80bc0 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -35,13 +35,7 @@ import SrcLoc ( SrcSpan ) import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, negateName, thenMName, bindMName, failMName ) -#if defined(GHCI) && defined(BREAKPOINT) -import PrelNames ( breakpointJumpName, breakpointCondJumpName - , undefined_RDR, breakpointIdKey, breakpointCondIdKey ) -import UniqFM ( eltsUFM ) -import DynFlags ( GhcMode(..) ) -import Name ( isTyVarName ) -#endif + import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) @@ -106,22 +100,6 @@ rnExpr (HsVar v) && not ignore_asserts, do (e, fvs) <- mkAssertErrorExpr return (e, fvs `addOneFV` name)) -#if defined(GHCI) && defined(BREAKPOINT) - , (name `hasKey` breakpointIdKey - && 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 ] case lookup True conds of Just action -> action @@ -945,48 +923,14 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ %* * -\subsubsection{breakpoint utils} +\subsubsection{Assertion utils} %* * %************************************************************************ \begin{code} -#if defined(GHCI) && defined(BREAKPOINT) -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 - lHsApp x y = inLoc (HsApp x y) - mkExpr fnName args = mkExpr' fnName (reverse args) - mkExpr' fnName [] = inLoc (HsVar fnName) - mkExpr' fnName (arg:args) - = lHsApp (mkExpr' fnName args) (inLoc arg) - expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg] - mkScopeArg args = unLoc $ mkExpr undef (map HsVar args) - msg = srcSpanLit sloc - return (expr, emptyFVs) - -srcSpanLit :: SrcSpan -> HsExpr Name -srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) -#endif - srcSpanPrimLit :: SrcSpan -> HsExpr Name srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span)))) -\end{code} -%************************************************************************ -%* * -\subsubsection{Assertion utils} -%* * -%************************************************************************ - -\begin{code} mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) -- Return an expression for (assertError "Foo.hs:27") mkAssertErrorExpr @@ -1015,3 +959,5 @@ badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} + + diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index b560566..6a7f4fb 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -14,16 +14,12 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all -#if defined(GHCI) && defined(BREAKPOINT) +#if defined(GHCI) import TypeRep -import Var import IdInfo -import OccName -import SrcLoc import TysWiredIn import PrelNames -import NameEnv -import TcEnv +import {-#SOURCE#-} TcEnv #endif import HsSyn hiding (LIE) @@ -72,6 +68,7 @@ ioToTcRn = ioToIOEnv \end{code} \begin{code} + initTc :: HscEnv -> HscSource -> Module @@ -163,7 +160,7 @@ initTcPrintErrors env mod todo = do \begin{code} addBreakpointBindings :: TcM a -> TcM a addBreakpointBindings thing_inside -#if defined(GHCI) && defined(BREAKPOINT) +#if defined(GHCI) = do { unique <- newUnique ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; tyvar = mkTyVar var liftedTypeKind; @@ -175,10 +172,10 @@ addBreakpointBindings thing_inside (FunTy (TyVarTy tyvar) (TyVarTy tyvar))))))); breakpointJumpId - = mkGlobalId VanillaGlobal breakpointJumpName + = Id.mkGlobalId VanillaGlobal breakpointJumpName (basicType id) vanillaIdInfo; breakpointCondJumpId - = mkGlobalId VanillaGlobal breakpointCondJumpName + = Id.mkGlobalId VanillaGlobal breakpointCondJumpName (basicType (FunTy boolTy)) vanillaIdInfo } ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside}