--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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}
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
import DsMonad
#ifdef GHCI
+import PrelNames
+import DsBreakpoint
-- Template Haskell stuff iff bootstrapped
import DsMeta
+#else
+import DsBreakpoint
#endif
import HsSyn
| 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}
%************************************************************************
\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)
= 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 ->
otherwiseIdName,
plusIntegerName, timesIntegerName,
eqStringName, assertName, breakpointName, breakpointCondName,
+ breakpointAutoName, opaqueTyConName,
assertErrorName, runSTRepName,
printName, fstName, sndName,
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
breakpointCondJumpIdKey
(mkOccNameFS varName FSLIT("breakpointCondJump"))
noSrcLoc
+breakpointAutoJumpName
+ = mkInternalName
+ breakpointAutoJumpIdKey
+ (mkOccNameFS varName FSLIT("breakpointAutoJump"))
+ noSrcLoc
-- PrelTup
fstName = varQual dATA_TUP FSLIT("fst") fstIdKey
instCoercionTyConKey = mkPreludeTyConUnique 97
unsafeCoercionTyConKey = mkPreludeTyConUnique 98
+opaqueTyConKey = mkPreludeTyConUnique 103
---------------- Template Haskell -------------------
-- USES TyConUniques 100-129
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
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 )
&& 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
%************************************************************************
%* *
-\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
= hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what)
2 (ppr binds)
\end{code}
+
+
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)
\end{code}
\begin{code}
+
initTc :: HscEnv
-> HscSource
-> Module
\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;
(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}
projects / ghc-hetmet.git / commitdiff