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
59 let mod_name = moduleNameFS$ moduleName mod
60 when (not instrumenting) $
61 warnDs (text "Extracted ids:" <+> (ppr scope $$
62 ppr (map idType scope)))
63 stablePtr <- ioToIOEnv $ newStablePtr scope
64 site <- if instrumenting
65 then recordBkpt (srcSpanStart loc)
67 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
68 jumpFuncId <- mkJumpFunc bkptFuncId
69 let [opaqueDataCon] = tyConDataCons opaqueTyCon
70 opaqueId = dataConWrapId opaqueDataCon
71 opaqueTy = mkTyConApp opaqueTyCon []
73 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
75 -- Yes, I know... I'm gonna burn in hell.
76 Ptr addr# = castStablePtrToPtr stablePtr
77 hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
78 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
79 , HsLit (HsString mod_name)
80 , HsLit (HsInt (fromIntegral site))]
81 funE = l$ HsVar jumpFuncId
82 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
85 msgE = l (srcSpanLit loc)
87 l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
89 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
90 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
91 srcSpanLit :: SrcSpan -> HsExpr Id
92 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
93 instrumenting = idName bkptFuncId == breakpointAutoName
95 mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
99 getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
100 where isValidType (FunTy a b) = isValidType a && isValidType b
101 isValidType (NoteTy _ t) = isValidType t
102 isValidType (AppTy a b) = isValidType a && isValidType b
103 isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) &&
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 isInstrumentationSpot (L loc e) = do
118 ghcmode <- getGhcModeDs
119 instrumenting <- debug_enabled
120 return$ instrumenting
121 && isGoodSrcSpan loc -- Avoids 'derived' code
122 && (not$ isRedundant e)
124 isEnabledNullScopeCoalescing = True
125 isRedundant HsLet {} = True
126 isRedundant HsDo {} = True
127 isRedundant HsCase {} = False
128 isRedundant _ = False
130 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
132 dynBreakpoint loc | not (isGoodSrcSpan loc) =
133 pprPanic "dynBreakpoint: bad SrcSpan" (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)
148 sites_var <- getBkptSitesDs
149 sites <- ioToIOEnv$ readIORef sites_var
150 let site = length sites + 1
151 let coords = (srcLocLine loc, srcLocCol loc)
152 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
155 mkJumpFunc :: Id -> DsM Id
156 mkJumpFunc bkptFuncId
157 | idName bkptFuncId == breakpointName
158 = build breakpointJumpName id
159 | idName bkptFuncId == breakpointCondName
160 = build breakpointCondJumpName (FunTy boolTy)
161 | idName bkptFuncId == breakpointAutoName
162 = build breakpointAutoJumpName id
165 basicType extra opaqueTy =
167 (FunTy (mkListTy opaqueTy)
168 (FunTy (mkTupleType [stringTy, stringTy, intTy])
172 (FunTy (TyVarTy tyvar)
173 (TyVarTy tyvar))))))))
174 build name extra = do
175 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
176 return$ Id.mkGlobalId VanillaGlobal name
177 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
178 mkTupleType tys = mkTupleTy Boxed (length tys) tys
180 breakpoints_enabled :: DsM Bool
181 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
182 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
185 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
186 instrumenting <- isInstrumentationSpot lhsexpr
188 if instrumenting && not(isUnLiftedType ty) &&
189 not(isEnabledNullScopeCoalescing && null scope)
190 then do L _ dynBkpt <- dynBreakpoint loc
191 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
194 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
195 coreExpr <- dsLExpr expr
196 instrumenting <- isInstrumentationSpot expr
198 let ty = exprType coreExpr
199 if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
200 not(isEnabledNullScopeCoalescing && null scope)
201 then do L _ dynBkpt<- dynBreakpoint loc
202 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
203 return (bkptCore `App` coreExpr)
207 breakpoints_enabled = do
208 ghcMode <- getGhcModeDs
209 currentModule <- getModuleDs
210 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
211 return ( not ignore_breakpoints
212 && ghcMode == Interactive
213 && currentModule /= iNTERACTIVE )
215 maybeInsertBreakpoint expr _ = return expr
216 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
217 breakpoints_enabled = return False