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