Commit 3a99fa88 authored by mnislaih's avatar mnislaih

The breakpoint primitive

parent 3e4ee05c
-----------------------------------------------------------------------------
--
-- 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}
......@@ -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 ->
......
......@@ -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
......
......@@ -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}
......@@ -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}
......
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