1 -----------------------------------------------------------------------------
3 -- Support code for instrumentation and expansion of the breakpoint combinator
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
10 module DsBreakpoint( debug_enabled
11 , dsAndThenMaybeInsertBreakpoint
12 , maybeInsertBreakpoint
44 import {-#SOURCE#-}DsExpr ( dsLExpr )
47 import Foreign.StablePtr
51 mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
52 mkBreakpointExpr loc bkptFuncId ty = do
56 let 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 Just mod_name_ref <- getModNameRefDs
67 let [opaqueDataCon] = tyConDataCons opaqueTyCon
68 opaqueId = dataConWrapId opaqueDataCon
69 opaqueTy = mkTyConApp opaqueTyCon []
71 l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
73 -- Yes, I know... I'm gonna burn in hell.
74 Ptr addr# = castStablePtrToPtr stablePtr
75 locals = ExplicitList opaqueTy (map wrapInOpaque scope)
76 locInfo = nlTuple [ HsVar mod_name_ref
77 , HsLit (HsInt (fromIntegral site))]
78 funE = l$ HsVar jumpFuncId
79 ptrE = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
82 argsE = nlTuple [ptrE, locals, msgE]
83 lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
84 argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
86 l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
89 nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
90 srcSpanLit :: SrcSpan -> HsExpr Id
91 srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
92 instrumenting = idName bkptFuncId == breakpointAutoName
93 mkTupleType tys = mkTupleTy Boxed (length tys) tys
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) &&
105 -- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
108 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
110 dynBreakpoint loc | not (isGoodSrcSpan loc) =
111 pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
113 dynBreakpoint loc = do
114 let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
115 breakpointAutoTy vanillaIdInfo
117 ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
118 return$ L loc (HsVar autoBreakpoint)
119 where breakpointAutoTy = (ForAllTy alphaTyVar
120 (FunTy (TyVarTy alphaTyVar)
121 (TyVarTy alphaTyVar)))
123 -- Records a breakpoint site and returns the site number
124 recordBkpt :: SrcLoc -> DsM (Int)
126 sites_var <- getBkptSitesDs
127 sites <- ioToIOEnv$ readIORef sites_var
128 let site = length sites + 1
129 let coords = (srcLocLine loc, srcLocCol loc)
130 ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
133 mkJumpFunc :: Id -> DsM Id
134 mkJumpFunc bkptFuncId
135 | idName bkptFuncId == breakpointName
136 = build breakpointJumpName id
137 | idName bkptFuncId == breakpointCondName
138 = build breakpointCondJumpName (FunTy boolTy)
139 | idName bkptFuncId == breakpointAutoName
140 = build breakpointAutoJumpName id
143 basicType extra opaqueTy =
144 (FunTy (mkTupleType [stringTy, intTy])
145 (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
148 (FunTy (TyVarTy tyvar)
150 build name extra = do
151 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
152 return$ Id.mkGlobalId VanillaGlobal name
153 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
154 mkTupleType tys = mkTupleTy Boxed (length tys) tys
156 debug_enabled, breakpoints_enabled :: DsM Bool
157 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
158 maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
160 #if defined(GHCI) && defined(DEBUGGER)
162 debugging <- doptDs Opt_Debugging
163 b_enabled <- breakpoints_enabled
164 return (debugging && b_enabled)
166 breakpoints_enabled = do
167 ghcMode <- getGhcModeDs
168 currentModule <- getModuleDs
169 ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
170 return ( not ignore_breakpoints
171 && ghcMode == Interactive
172 && currentModule /= iNTERACTIVE )
174 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
175 instrumenting <- isInstrumentationSpot lhsexpr
177 if instrumenting && not(isUnLiftedType ty) &&
178 not(isEnabledNullScopeCoalescing && null scope)
179 then do L _ dynBkpt <- dynBreakpoint loc
180 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
183 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
184 coreExpr <- dsLExpr expr
185 instrumenting <- isInstrumentationSpot expr
187 let ty = exprType coreExpr
188 if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
189 not(isEnabledNullScopeCoalescing && null scope)
190 then do L _ dynBkpt<- dynBreakpoint loc
191 bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
192 return (bkptCore `App` coreExpr)
196 maybeInsertBreakpoint expr _ = return expr
197 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
198 breakpoints_enabled = return False
199 debug_enabled = return False
203 isInstrumentationSpot (L loc e) = do
204 ghcmode <- getGhcModeDs
205 instrumenting <- debug_enabled
206 return$ instrumenting
207 && isGoodSrcSpan loc -- Avoids 'derived' code
208 && (not$ isRedundant e)
210 isEnabledNullScopeCoalescing = True
211 isRedundant HsLet {} = True
212 isRedundant HsDo {} = True
213 isRedundant HsCase {} = False
214 isRedundant _ = False