+++ /dev/null
------------------------------------------------------------------------------
---
--- Support code for instrumentation and expansion of the breakpoint combinator
---
--- Pepe Iborra (supported by Google SoC) 2006
---
------------------------------------------------------------------------------
-
-\begin{code}
-module DsBreakpoint( debug_enabled
- , dsAndThenMaybeInsertBreakpoint
- , maybeInsertBreakpoint
- , breakpoints_enabled
- , mkBreakpointExpr
- ) where
-
-import TysPrim
-import TysWiredIn
-import PrelNames
-import Module
-import SrcLoc
-import TyCon
-import TypeRep
-import DataCon
-import Type
-import Id
-
-import IdInfo
-import BasicTypes
-import OccName
-
-import TcRnMonad
-import HsSyn
-import HsLit
-import CoreSyn
-import CoreUtils
-import Outputable
-import ErrUtils
-import FastString
-import DynFlags
-import MkId
-
-import DsMonad
-import {-#SOURCE#-}DsExpr ( dsLExpr )
-import Control.Monad
-import Data.IORef
-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 (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
- 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
- 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
-
-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: bad SrcSpan" (ppr loc)
-#endif
-dynBreakpoint loc = do
- let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
- breakpointAutoTy vanillaIdInfo
- dflags <- getDOptsDs
- ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
- return$ L loc (HsVar autoBreakpoint)
- where breakpointAutoTy = (ForAllTy alphaTyVar
- (FunTy (TyVarTy alphaTyVar)
- (TyVarTy alphaTyVar)))
-
--- Records a breakpoint site and returns the site number
-recordBkpt :: SrcLoc -> DsM (Int)
-recordBkpt loc = do
- sites_var <- getBkptSitesDs
- sites <- ioToIOEnv$ readIORef sites_var
- let site = length sites + 1
- let coords = (srcLocLine loc, srcLocCol loc)
- ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
- return site
-
-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 (mkTupleType [stringTy, intTy])
- (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
- (ForAllTy tyvar
- (extra
- (FunTy (TyVarTy tyvar)
- (TyVarTy tyvar))))))
- build name extra = do
- ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
- return$ Id.mkGlobalId VanillaGlobal name
- (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
- mkTupleType tys = mkTupleTy Boxed (length tys) tys
-
-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 )
-
-maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
- instrumenting <- isInstrumentationSpot lhsexpr
- scope <- getScope
- if instrumenting && not(isUnLiftedType ty) &&
- not(isEnabledNullScopeCoalescing && null scope)
- then do L _ dynBkpt <- dynBreakpoint loc
- return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
- else return lhsexpr
- where l = L loc
-dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
- coreExpr <- dsLExpr expr
- instrumenting <- isInstrumentationSpot expr
- 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 ty) dynBkpt)
- return (bkptCore `App` coreExpr)
- else return coreExpr
- where l = L loc
-#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