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
44 import {-#SOURCE#-}DsExpr ( dsLExpr )
47 import Foreign.StablePtr
50 mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
51 mkBreakpointExpr loc bkptFuncId ty = do
55 let mod_name = moduleNameFS$ moduleName mod
56 valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc
57 when (not instrumenting) $
58 warnDs (text "Extracted ids:" <+> (ppr scope $$
59 ppr (map idType scope)))
60 stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
61 site <- if instrumenting
62 then recordBkpt (srcSpanStart loc)
64 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
65 jumpFuncId <- mkJumpFunc bkptFuncId
66 let [opaqueDataCon] = tyConDataCons opaqueTyCon
67 opaqueId = dataConWrapId opaqueDataCon
68 opaqueTy = mkTyConApp opaqueTyCon []
70 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
72 -- Yes, I know... I'm gonna burn in hell.
73 Ptr addr# = castStablePtrToPtr stablePtr
74 locals = ExplicitList opaqueTy (map wrapInOpaque scope)
75 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
76 , HsLit (HsString mod_name)
77 , HsLit (HsInt (fromIntegral site))]
78 funE = l$ HsVar jumpFuncId
79 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
82 msgE = l (srcSpanLit loc)
84 l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE)
86 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
87 srcSpanLit :: SrcSpan -> HsExpr Id
88 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
89 instrumenting = idName bkptFuncId == breakpointAutoName
91 mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
95 getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
96 where isValidType (FunTy a b) = isValidType a && isValidType b
97 isValidType (NoteTy _ t) = isValidType t
98 isValidType (AppTy a b) = isValidType a && isValidType b
99 isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) &&
101 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
104 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
106 dynBreakpoint loc | not (isGoodSrcSpan loc) =
107 pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
109 dynBreakpoint loc = do
110 let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
111 breakpointAutoTy vanillaIdInfo
113 ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
114 return$ L loc (HsVar autoBreakpoint)
115 where breakpointAutoTy = (ForAllTy alphaTyVar
116 (FunTy (TyVarTy alphaTyVar)
117 (TyVarTy alphaTyVar)))
119 -- Records a breakpoint site and returns the site number
120 recordBkpt :: SrcLoc -> DsM (Int)
122 sites_var <- getBkptSitesDs
123 sites <- ioToIOEnv$ readIORef sites_var
124 let site = length sites + 1
125 let coords = (srcLocLine loc, srcLocCol loc)
126 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
129 mkJumpFunc :: Id -> DsM Id
130 mkJumpFunc bkptFuncId
131 | idName bkptFuncId == breakpointName
132 = build breakpointJumpName id
133 | idName bkptFuncId == breakpointCondName
134 = build breakpointCondJumpName (FunTy boolTy)
135 | idName bkptFuncId == breakpointAutoName
136 = build breakpointAutoJumpName id
139 basicType extra opaqueTy =
141 (FunTy (mkListTy opaqueTy)
142 (FunTy (mkTupleType [stringTy, stringTy, intTy])
146 (FunTy (TyVarTy tyvar)
147 (TyVarTy tyvar))))))))
148 build name extra = do
149 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
150 return$ Id.mkGlobalId VanillaGlobal name
151 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
152 mkTupleType tys = mkTupleTy Boxed (length tys) tys
154 debug_enabled, breakpoints_enabled :: DsM Bool
155 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
156 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
158 #if defined(GHCI) && defined(DEBUGGER)
160 debugging <- doptDs Opt_Debugging
161 b_enabled <- breakpoints_enabled
162 return (debugging && b_enabled)
164 breakpoints_enabled = do
165 ghcMode <- getGhcModeDs
166 currentModule <- getModuleDs
167 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
168 return ( not ignore_breakpoints
169 && ghcMode == Interactive
170 && currentModule /= iNTERACTIVE )
172 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
173 instrumenting <- isInstrumentationSpot lhsexpr
175 if instrumenting && not(isUnLiftedType ty) &&
176 not(isEnabledNullScopeCoalescing && null scope)
177 then do L _ dynBkpt <- dynBreakpoint loc
178 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
181 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
182 coreExpr <- dsLExpr expr
183 instrumenting <- isInstrumentationSpot expr
185 let ty = exprType coreExpr
186 if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
187 not(isEnabledNullScopeCoalescing && null scope)
188 then do L _ dynBkpt<- dynBreakpoint loc
189 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
190 return (bkptCore `App` coreExpr)
194 maybeInsertBreakpoint expr _ = return expr
195 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
196 breakpoints_enabled = return False
197 debug_enabled = return False
201 isInstrumentationSpot (L loc e) = do
202 ghcmode <- getGhcModeDs
203 instrumenting <- debug_enabled
204 return$ instrumenting
205 && isGoodSrcSpan loc -- Avoids 'derived' code
206 && (not$ isRedundant e)
208 isEnabledNullScopeCoalescing = True
209 isRedundant HsLet {} = True
210 isRedundant HsDo {} = True
211 isRedundant HsCase {} = False
212 isRedundant _ = False