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# )
57 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
58 mkBreakpointExpr loc bkptFuncId = do
59 scope' <- getLocalBindsDs
61 let scope = filter (isValidType .idType ) scope'
62 mod_name = moduleNameFS$ moduleName mod
63 if null scope && instrumenting
64 then return (l$ HsVar lazyId)
66 when (not instrumenting) $
67 warnDs (text "Extracted ids:" <+> (ppr scope $$
68 ppr (map idType scope)))
69 stablePtr <- ioToIOEnv $ newStablePtr scope
70 site <- if instrumenting
71 then recordBkpt (srcSpanStart loc)
73 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
74 jumpFuncId <- mkJumpFunc bkptFuncId
75 let [opaqueDataCon] = tyConDataCons opaqueTyCon
76 opaqueId = dataConWrapId opaqueDataCon
77 opaqueTy = mkTyConApp opaqueTyCon []
79 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
81 -- Yes, I know... I'm gonna burn in hell.
82 Ptr addr# = castStablePtrToPtr stablePtr
83 hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
84 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
85 , HsLit (HsString mod_name)
86 , HsLit (HsInt (fromIntegral site))]
88 funE = l$ HsVar jumpFuncId
89 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
92 msgE = l (srcSpanLit loc)
93 return$ l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
95 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
96 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
97 isValidType (FunTy a b) = isValidType a && isValidType b
98 isValidType (NoteTy _ t) = isValidType t
99 isValidType (AppTy a b) = isValidType a && isValidType b
100 isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
102 srcSpanLit :: SrcSpan -> HsExpr Id
103 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
104 instrumenting = idName bkptFuncId == breakpointAutoName
106 debug_enabled :: DsM Bool
108 debugging <- doptDs Opt_Debugging
109 b_enabled <- breakpoints_enabled
110 return (debugging && b_enabled)
112 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
113 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
115 isInstrumentationSpot (L loc e) = do
116 ghcmode <- getGhcModeDs
117 instrumenting <- debug_enabled
118 return$ instrumenting
119 && isGoodSrcSpan loc -- Avoids 'derived' code
120 && (not$ isRedundant e)
122 isRedundant HsLet {} = True
123 isRedundant HsDo {} = True
124 isRedundant HsCase {} = True
125 isRedundant _ = False
127 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
128 dynBreakpoint loc | not (isGoodSrcSpan loc) =
129 pprPanic "dynBreakpoint" (ppr loc)
130 dynBreakpoint loc = do
131 let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
132 breakpointAutoTy vanillaIdInfo
134 ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
135 return$ L loc (HsVar autoBreakpoint)
136 where breakpointAutoTy = (ForAllTy alphaTyVar
137 (FunTy (TyVarTy alphaTyVar)
138 (TyVarTy alphaTyVar)))
140 -- Records a breakpoint site and returns the site number
141 recordBkpt :: SrcLoc -> DsM (Int)
142 --recordBkpt | trace "recordBkpt" False = undefined
144 sites_var <- getBkptSitesDs
145 sites <- ioToIOEnv$ readIORef sites_var
146 let site = length sites + 1
147 let coords = (srcLocLine loc, srcLocCol loc)
148 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
151 mkJumpFunc :: Id -> DsM Id
152 mkJumpFunc bkptFuncId
153 | idName bkptFuncId == breakpointName
154 = build breakpointJumpName id
155 | idName bkptFuncId == breakpointCondName
156 = build breakpointCondJumpName (FunTy boolTy)
157 | idName bkptFuncId == breakpointAutoName
158 = build breakpointAutoJumpName id
161 basicType extra opaqueTy =
163 (FunTy (mkListTy opaqueTy)
164 (FunTy (mkTupleType [stringTy, stringTy, intTy])
168 (FunTy (TyVarTy tyvar)
169 (TyVarTy tyvar))))))))
170 build name extra = do
171 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
172 return$ mkGlobalId VanillaGlobal name
173 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
174 mkTupleType tys = mkTupleTy Boxed (length tys) tys
176 breakpoints_enabled :: DsM Bool
177 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
180 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
181 instrumenting <- isInstrumentationSpot lhsexpr
183 then do L _ dynBkpt <- dynBreakpoint loc
184 -- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
185 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
189 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
190 coreExpr <- dsLExpr expr
191 instrumenting <- isInstrumentationSpot expr
193 then do L _ dynBkpt<- dynBreakpoint loc
194 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
195 return (bkptCore `App` coreExpr)
199 breakpoints_enabled = do
200 ghcMode <- getGhcModeDs
201 currentModule <- getModuleDs
202 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
203 return ( not ignore_breakpoints
204 && ghcMode == Interactive
205 && currentModule /= iNTERACTIVE )
207 maybeInsertBreakpoint expr _ = return expr
208 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
209 breakpoints_enabled = return False