-----------------------------------------------------------------------------
\begin{code}
-module DsBreakpoint(
- dsAndThenMaybeInsertBreakpoint
+module DsBreakpoint( debug_enabled
+ , dsAndThenMaybeInsertBreakpoint
, maybeInsertBreakpoint
, breakpoints_enabled
, mkBreakpointExpr
) where
-import IOEnv ( ioToIOEnv )
-import TysPrim ( alphaTyVar )
-import TysWiredIn ( intTy, stringTy, mkTupleTy, mkListTy, boolTy )
+import TysPrim
+import TysWiredIn
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 Module
+import SrcLoc
+import TyCon
+import TypeRep
import DataCon
import Type
-import MkId ( unsafeCoerceId, lazyId )
-import Name ( Name, mkInternalName )
-import Var ( mkTyVar )
-import Id ( Id, idType, mkGlobalId, idName )
+import Id
-import IdInfo ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) )
-import BasicTypes ( Boxity(Boxed) )
-import OccName ( mkOccName, tvName )
+import IdInfo
+import BasicTypes
+import OccName
import TcRnMonad
import HsSyn
-import HsLit ( HsLit(HsString, HsInt) )
-import CoreSyn ( CoreExpr, Expr (App) )
-import CoreUtils ( exprType )
+import HsLit
+import CoreSyn
+import CoreUtils
import Outputable
-import ErrUtils ( debugTraceMsg )
-import FastString ( mkFastString, unpackFS )
-import DynFlags ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) )
+import ErrUtils
+import FastString
+import DynFlags
+import MkId
import DsMonad
import {-#SOURCE#-}DsExpr ( dsLExpr )
import Control.Monad
import Data.IORef
-import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
-import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
-
-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) $
+import Foreign.StablePtr
+import GHC.Exts
+
+#ifdef GHCI
+mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
+mkBreakpointExpr loc bkptFuncId ty = do
+ scope <- getScope
+ mod <- getModuleDs
+ u <- newUnique
+ let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc
+ 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 =
+ stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
+ site <- if instrumenting
+ then recordBkpt (srcSpanStart loc)
+ else return 0
+ ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
+ jumpFuncId <- mkJumpFunc bkptFuncId
+ Just mod_name_ref <- getModNameRefDs
+ 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)
+ Ptr addr# = castStablePtrToPtr stablePtr
+ locals = ExplicitList opaqueTy (map wrapInOpaque scope)
+ locInfo = nlTuple [ HsVar mod_name_ref
+ , HsLit (HsInt (fromIntegral site))]
+ funE = l$ HsVar jumpFuncId
+ ptrE = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
+ locE = locInfo
+ msgE = srcSpanLit loc
+ argsE = nlTuple [ptrE, locals, msgE]
+ lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
+ argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
+ return $
+ l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
+
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
+ mkTupleType tys = mkTupleTy Boxed (length tys) tys
+#else
+mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
+#endif
-debug_enabled :: DsM Bool
-debug_enabled = do
- debugging <- doptDs Opt_Debugging
- b_enabled <- breakpoints_enabled
- return (debugging && b_enabled)
-
-maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
---maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
-
-isInstrumentationSpot (L loc e) = do
- ghcmode <- getGhcModeDs
- instrumenting <- debug_enabled
- return$ instrumenting
- && isGoodSrcSpan loc -- Avoids 'derived' code
- && (not$ isRedundant e)
-
-isRedundant HsLet {} = True
-isRedundant HsDo {} = True
-isRedundant HsCase {} = True
-isRedundant _ = False
+getScope :: DsM [Id]
+getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
+ where 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 (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
+ isValidType _ = True
dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
+#ifdef DEBUG
dynBreakpoint loc | not (isGoodSrcSpan loc) =
- pprPanic "dynBreakpoint" (ppr loc)
+ pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
+#endif
dynBreakpoint loc = do
- let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
+ let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
breakpointAutoTy vanillaIdInfo
dflags <- getDOptsDs
ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
-- Records a breakpoint site and returns the site number
recordBkpt :: SrcLoc -> DsM (Int)
---recordBkpt | trace "recordBkpt" False = undefined
recordBkpt loc = do
sites_var <- getBkptSitesDs
sites <- ioToIOEnv$ readIORef sites_var
where
tyvar = alphaTyVar
basicType extra opaqueTy =
- (FunTy intTy
- (FunTy (mkListTy opaqueTy)
- (FunTy (mkTupleType [stringTy, stringTy, intTy])
- (FunTy stringTy
+ (FunTy (mkTupleType [stringTy, intTy])
+ (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
(ForAllTy tyvar
(extra
(FunTy (TyVarTy tyvar)
- (TyVarTy tyvar))))))))
+ (TyVarTy tyvar))))))
build name extra = do
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
- return$ mkGlobalId VanillaGlobal name
+ return$ Id.mkGlobalId VanillaGlobal name
(basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
mkTupleType tys = mkTupleTy Boxed (length tys) tys
-breakpoints_enabled :: DsM Bool
+debug_enabled, breakpoints_enabled :: DsM Bool
dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
+maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
+
+#if defined(GHCI) && defined(DEBUGGER)
+debug_enabled = do
+ debugging <- doptDs Opt_Debugging
+ b_enabled <- breakpoints_enabled
+ return (debugging && b_enabled)
+
+breakpoints_enabled = do
+ ghcMode <- getGhcModeDs
+ currentModule <- getModuleDs
+ dflags <- getDOptsDs
+ ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
+ return ( not ignore_breakpoints
+ && hscTarget dflags == HscInterpreted
+ && currentModule /= iNTERACTIVE )
-#ifdef GHCI
maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
instrumenting <- isInstrumentationSpot lhsexpr
- if instrumenting
+ scope <- getScope
+ if instrumenting && not(isUnLiftedType ty) &&
+ not(isEnabledNullScopeCoalescing && null scope)
then do L _ dynBkpt <- dynBreakpoint loc
--- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
else return lhsexpr
where l = L loc
-
dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
- coreExpr <- dsLExpr expr
+ coreExpr <- dsLExpr expr
instrumenting <- isInstrumentationSpot expr
- if instrumenting
+ scope <- getScope
+ let ty = exprType coreExpr
+ if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
+ not(isEnabledNullScopeCoalescing && null scope)
then do L _ dynBkpt<- dynBreakpoint loc
- bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
+ bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
return (bkptCore `App` coreExpr)
else return coreExpr
where l = L loc
-
-breakpoints_enabled = do
- ghcMode <- getGhcModeDs
- currentModule <- getModuleDs
- ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
- return ( not ignore_breakpoints
- && ghcMode == Interactive
- && currentModule /= iNTERACTIVE )
#else
maybeInsertBreakpoint expr _ = return expr
dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
breakpoints_enabled = return False
+debug_enabled = return False
#endif
+
+
+isInstrumentationSpot (L loc e) = do
+ ghcmode <- getGhcModeDs
+ instrumenting <- debug_enabled
+ return$ instrumenting
+ && isGoodSrcSpan loc -- Avoids 'derived' code
+ && (not$ isRedundant e)
+
+isEnabledNullScopeCoalescing = True
+isRedundant HsLet {} = True
+isRedundant HsDo {} = True
+isRedundant HsCase {} = False
+isRedundant _ = False
+
\end{code}
projects / ghc-hetmet.git / blobdiff