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 -> DsM (LHsExpr Id)
51 mkBreakpointExpr loc bkptFuncId = do
54 let mod_name = moduleNameFS$ moduleName mod
55 when (not instrumenting) $
56 warnDs (text "Extracted ids:" <+> (ppr scope $$
57 ppr (map idType scope)))
58 stablePtr <- ioToIOEnv $ newStablePtr scope
59 site <- if instrumenting
60 then recordBkpt (srcSpanStart loc)
62 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
63 jumpFuncId <- mkJumpFunc bkptFuncId
64 let [opaqueDataCon] = tyConDataCons opaqueTyCon
65 opaqueId = dataConWrapId opaqueDataCon
66 opaqueTy = mkTyConApp opaqueTyCon []
68 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
70 -- Yes, I know... I'm gonna burn in hell.
71 Ptr addr# = castStablePtrToPtr stablePtr
72 hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
73 locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
74 , HsLit (HsString mod_name)
75 , HsLit (HsInt (fromIntegral site))]
76 funE = l$ HsVar jumpFuncId
77 ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
80 msgE = l (srcSpanLit loc)
82 l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
84 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
85 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
86 srcSpanLit :: SrcSpan -> HsExpr Id
87 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
88 instrumenting = idName bkptFuncId == breakpointAutoName
90 mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
94 getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
95 where 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) &&
102 debug_enabled :: DsM Bool
103 #if defined(GHCI) && defined(DEBUGGER)
105 debugging <- doptDs Opt_Debugging
106 b_enabled <- breakpoints_enabled
107 return (debugging && b_enabled)
109 debug_enabled = return False
112 isInstrumentationSpot (L loc e) = do
113 ghcmode <- getGhcModeDs
114 instrumenting <- debug_enabled
115 return$ instrumenting
116 && isGoodSrcSpan loc -- Avoids 'derived' code
117 && (not$ isRedundant e)
119 isEnabledNullScopeCoalescing = True
120 isRedundant HsLet {} = True
121 isRedundant HsDo {} = True
122 isRedundant HsCase {} = False
123 isRedundant _ = False
125 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
127 dynBreakpoint loc | not (isGoodSrcSpan loc) =
128 pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
130 dynBreakpoint loc = do
131 let autoBreakpoint = Id.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)
143 sites_var <- getBkptSitesDs
144 sites <- ioToIOEnv$ readIORef sites_var
145 let site = length sites + 1
146 let coords = (srcLocLine loc, srcLocCol loc)
147 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
150 mkJumpFunc :: Id -> DsM Id
151 mkJumpFunc bkptFuncId
152 | idName bkptFuncId == breakpointName
153 = build breakpointJumpName id
154 | idName bkptFuncId == breakpointCondName
155 = build breakpointCondJumpName (FunTy boolTy)
156 | idName bkptFuncId == breakpointAutoName
157 = build breakpointAutoJumpName id
160 basicType extra opaqueTy =
162 (FunTy (mkListTy opaqueTy)
163 (FunTy (mkTupleType [stringTy, stringTy, intTy])
167 (FunTy (TyVarTy tyvar)
168 (TyVarTy tyvar))))))))
169 build name extra = do
170 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
171 return$ Id.mkGlobalId VanillaGlobal name
172 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
173 mkTupleType tys = mkTupleTy Boxed (length tys) tys
175 breakpoints_enabled :: DsM Bool
176 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
177 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
180 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
181 instrumenting <- isInstrumentationSpot lhsexpr
183 if instrumenting && not(isUnLiftedType ty) &&
184 not(isEnabledNullScopeCoalescing && null scope)
185 then do L _ dynBkpt <- dynBreakpoint loc
186 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
189 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
190 coreExpr <- dsLExpr expr
191 instrumenting <- isInstrumentationSpot expr
193 let ty = exprType coreExpr
194 if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
195 not(isEnabledNullScopeCoalescing && null scope)
196 then do L _ dynBkpt<- dynBreakpoint loc
197 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
198 return (bkptCore `App` coreExpr)
202 breakpoints_enabled = do
203 ghcMode <- getGhcModeDs
204 currentModule <- getModuleDs
205 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
206 return ( not ignore_breakpoints
207 && ghcMode == Interactive
208 && currentModule /= iNTERACTIVE )
210 maybeInsertBreakpoint expr _ = return expr
211 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
212 breakpoints_enabled = return False