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
48 import {-#SOURCE#-}DsExpr ( dsLExpr )
51 import Foreign.StablePtr
55 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
56 mkBreakpointExpr loc bkptFuncId = do
57 scope' <- getLocalBindsDs
59 let scope = filter (isValidType .idType ) scope'
60 mod_name = moduleNameFS$ moduleName mod
61 if null scope && instrumenting
62 then return (l$ HsVar lazyId)
64 when (not instrumenting) $
65 warnDs (text "Extracted ids:" <+> (ppr scope $$
66 ppr (map idType scope)))
67 stablePtr <- ioToIOEnv $ newStablePtr scope
68 site <- if instrumenting
69 then recordBkpt (srcSpanStart loc)
71 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
72 jumpFuncId <- mkJumpFunc bkptFuncId
73 let [opaqueDataCon] = tyConDataCons opaqueTyCon
74 opaqueId = dataConWrapId opaqueDataCon
75 opaqueTy = mkTyConApp opaqueTyCon []
77 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
79 -- Yes, I know... I'm gonna burn in hell.
80 Ptr addr# = castStablePtrToPtr stablePtr
81 hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
82 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
83 , HsLit (HsString mod_name)
84 , HsLit (HsInt (fromIntegral site))]
86 funE = l$ HsVar jumpFuncId
87 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
90 msgE = l (srcSpanLit loc)
91 return$ l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
93 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
94 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
95 isValidType (FunTy a b) = isValidType a && isValidType b
96 isValidType (NoteTy _ t) = isValidType t
97 isValidType (AppTy a b) = isValidType a && isValidType b
98 isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
100 srcSpanLit :: SrcSpan -> HsExpr Id
101 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
102 instrumenting = idName bkptFuncId == breakpointAutoName
104 mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
107 debug_enabled :: DsM Bool
108 #if defined(GHCI) && defined(DEBUGGER)
110 debugging <- doptDs Opt_Debugging
111 b_enabled <- breakpoints_enabled
112 return (debugging && b_enabled)
114 debug_enabled = return False
117 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
118 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
120 isInstrumentationSpot (L loc e) = do
121 ghcmode <- getGhcModeDs
122 instrumenting <- debug_enabled
123 return$ instrumenting
124 && isGoodSrcSpan loc -- Avoids 'derived' code
125 && (not$ isRedundant e)
127 isRedundant HsLet {} = True
128 isRedundant HsDo {} = True
129 isRedundant HsCase {} = True
130 isRedundant _ = False
132 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
133 dynBreakpoint loc | not (isGoodSrcSpan loc) =
134 pprPanic "dynBreakpoint" (ppr loc)
135 dynBreakpoint loc = do
136 let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
137 breakpointAutoTy vanillaIdInfo
139 ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
140 return$ L loc (HsVar autoBreakpoint)
141 where breakpointAutoTy = (ForAllTy alphaTyVar
142 (FunTy (TyVarTy alphaTyVar)
143 (TyVarTy alphaTyVar)))
145 -- Records a breakpoint site and returns the site number
146 recordBkpt :: SrcLoc -> DsM (Int)
147 --recordBkpt | trace "recordBkpt" False = undefined
149 sites_var <- getBkptSitesDs
150 sites <- ioToIOEnv$ readIORef sites_var
151 let site = length sites + 1
152 let coords = (srcLocLine loc, srcLocCol loc)
153 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
156 mkJumpFunc :: Id -> DsM Id
157 mkJumpFunc bkptFuncId
158 | idName bkptFuncId == breakpointName
159 = build breakpointJumpName id
160 | idName bkptFuncId == breakpointCondName
161 = build breakpointCondJumpName (FunTy boolTy)
162 | idName bkptFuncId == breakpointAutoName
163 = build breakpointAutoJumpName id
166 basicType extra opaqueTy =
168 (FunTy (mkListTy opaqueTy)
169 (FunTy (mkTupleType [stringTy, stringTy, intTy])
173 (FunTy (TyVarTy tyvar)
174 (TyVarTy tyvar))))))))
175 build name extra = do
176 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
177 return$ Id.mkGlobalId VanillaGlobal name
178 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
179 mkTupleType tys = mkTupleTy Boxed (length tys) tys
181 breakpoints_enabled :: DsM Bool
182 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
185 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
186 instrumenting <- isInstrumentationSpot lhsexpr
188 then do L _ dynBkpt <- dynBreakpoint loc
189 -- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
190 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
194 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
195 coreExpr <- dsLExpr expr
196 instrumenting <- isInstrumentationSpot expr
198 then do L _ dynBkpt<- dynBreakpoint loc
199 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
200 return (bkptCore `App` coreExpr)
204 breakpoints_enabled = do
205 ghcMode <- getGhcModeDs
206 currentModule <- getModuleDs
207 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
208 return ( not ignore_breakpoints
209 && ghcMode == Interactive
210 && currentModule /= iNTERACTIVE )
212 maybeInsertBreakpoint expr _ = return expr
213 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
214 breakpoints_enabled = return False