1 -----------------------------------------------------------------------------
3 -- Support code for instrumentation and expansion of the breakpoint combinator
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
11 dsAndThenMaybeInsertBreakpoint
12 , maybeInsertBreakpoint
17 import IOEnv ( ioToIOEnv )
18 import TysPrim ( alphaTyVar )
19 import TysWiredIn ( intTy, stringTy, mkTupleTy, mkListTy, boolTy )
21 import Module ( moduleName, moduleNameFS, modulePackageId )
22 import PackageConfig ( packageIdFS)
23 import SrcLoc ( SrcLoc, Located(..), SrcSpan, srcSpanFile,
24 noLoc, noSrcLoc, isGoodSrcSpan,
25 srcLocLine, srcLocCol, srcSpanStart )
27 import TyCon ( isUnLiftedTyCon, tyConDataCons )
28 import TypeRep ( Type(..) )
31 import MkId ( unsafeCoerceId, lazyId )
32 import Name ( Name, mkInternalName )
33 import Var ( mkTyVar )
34 import Id ( Id, idType, mkGlobalId, idName )
36 import IdInfo ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) )
37 import BasicTypes ( Boxity(Boxed) )
38 import OccName ( mkOccName, tvName )
42 import HsLit ( HsLit(HsString, HsInt) )
43 import CoreSyn ( CoreExpr, Expr (App) )
44 import CoreUtils ( exprType )
46 import ErrUtils ( debugTraceMsg )
47 import FastString ( mkFastString, unpackFS )
48 import DynFlags ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) )
51 import {-#SOURCE#-}DsExpr ( dsLExpr )
54 import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
55 import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
58 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
59 mkBreakpointExpr loc bkptFuncId = do
60 scope' <- getLocalBindsDs
62 let scope = filter (isValidType .idType ) scope'
63 mod_name = moduleNameFS$ moduleName mod
64 if null scope && instrumenting
65 then return (l$ HsVar lazyId)
67 when (not instrumenting) $
68 warnDs (text "Extracted ids:" <+> (ppr scope $$
69 ppr (map idType scope)))
70 stablePtr <- ioToIOEnv $ newStablePtr scope
71 site <- if instrumenting
72 then recordBkpt (srcSpanStart loc)
74 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
75 jumpFuncId <- mkJumpFunc bkptFuncId
76 let [opaqueDataCon] = tyConDataCons opaqueTyCon
77 opaqueId = dataConWrapId opaqueDataCon
78 opaqueTy = mkTyConApp opaqueTyCon []
80 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
82 -- Yes, I know... I'm gonna burn in hell.
83 Ptr addr# = castStablePtrToPtr stablePtr
84 hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
85 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
86 , HsLit (HsString mod_name)
87 , HsLit (HsInt (fromIntegral site))]
89 funE = l$ HsVar jumpFuncId
90 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
93 msgE = l (srcSpanLit loc)
94 return$ l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
96 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
97 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
98 isValidType (FunTy a b) = isValidType a && isValidType b
99 isValidType (NoteTy _ t) = isValidType t
100 isValidType (AppTy a b) = isValidType a && isValidType b
101 isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
103 srcSpanLit :: SrcSpan -> HsExpr Id
104 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
105 instrumenting = idName bkptFuncId == breakpointAutoName
107 debug_enabled :: DsM Bool
109 debugging <- doptDs Opt_Debugging
110 b_enabled <- breakpoints_enabled
111 return (debugging && b_enabled)
113 breakpoints_enabled :: DsM Bool
114 breakpoints_enabled = do
115 ghcMode <- getGhcModeDs
116 currentModule <- getModuleDs
117 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
118 return ( not ignore_breakpoints
119 && ghcMode == Interactive
120 && currentModule /= iNTERACTIVE )
122 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
123 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
124 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
125 instrumenting <- isInstrumentationSpot lhsexpr
127 then do L _ dynBkpt <- dynBreakpoint loc
128 -- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
129 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
133 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
134 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
135 coreExpr <- dsLExpr expr
136 instrumenting <- isInstrumentationSpot expr
138 then do L _ dynBkpt<- dynBreakpoint loc
139 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
140 return (bkptCore `App` coreExpr)
144 isInstrumentationSpot (L loc e) = do
145 ghcmode <- getGhcModeDs
146 instrumenting <- debug_enabled
147 return$ instrumenting
148 && isGoodSrcSpan loc -- Avoids 'derived' code
149 && (not$ isRedundant e)
151 isRedundant HsLet {} = True
152 isRedundant HsDo {} = True
153 isRedundant HsCase {} = True
154 isRedundant _ = False
156 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
157 dynBreakpoint loc | not (isGoodSrcSpan loc) =
158 pprPanic "dynBreakpoint" (ppr loc)
159 dynBreakpoint loc = do
160 let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
161 breakpointAutoTy vanillaIdInfo
163 ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
164 return$ L loc (HsVar autoBreakpoint)
165 where breakpointAutoTy = (ForAllTy alphaTyVar
166 (FunTy (TyVarTy alphaTyVar)
167 (TyVarTy alphaTyVar)))
169 -- Records a breakpoint site and returns the site number
170 recordBkpt :: SrcLoc -> DsM (Int)
171 --recordBkpt | trace "recordBkpt" False = undefined
173 sites_var <- getBkptSitesDs
174 sites <- ioToIOEnv$ readIORef sites_var
175 let site = length sites + 1
176 let coords = (srcLocLine loc, srcLocCol loc)
177 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
180 mkJumpFunc :: Id -> DsM Id
181 mkJumpFunc bkptFuncId
182 | idName bkptFuncId == breakpointName
183 = build breakpointJumpName id
184 | idName bkptFuncId == breakpointCondName
185 = build breakpointCondJumpName (FunTy boolTy)
186 | idName bkptFuncId == breakpointAutoName
187 = build breakpointAutoJumpName id
190 basicType extra opaqueTy =
192 (FunTy (mkListTy opaqueTy)
193 (FunTy (mkTupleType [stringTy, stringTy, intTy])
197 (FunTy (TyVarTy tyvar)
198 (TyVarTy tyvar))))))))
199 build name extra = do
200 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
201 return$ mkGlobalId VanillaGlobal name
202 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
203 mkTupleType tys = mkTupleTy Boxed (length tys) tys
206 maybeInsertBreakpoint expr _ = return expr
207 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
208 breakpoints_enabled = False