Breakpoint code instrumentation
[ghc.git] / compiler / deSugar / DsBreakpoint.lhs
1 -----------------------------------------------------------------------------
2 --
3 -- Support code for instrumentation and expansion of the breakpoint combinator
4 --
5 -- Pepe Iborra (supported by Google SoC) 2006
6 --
7 -----------------------------------------------------------------------------
8
9 \begin{code}
10 module DsBreakpoint( 
11                      dsAndThenMaybeInsertBreakpoint
12                    , maybeInsertBreakpoint
13                    , breakpoints_enabled
14                    , mkBreakpointExpr
15                    ) where
16
17 import IOEnv            ( ioToIOEnv )
18 import TysPrim          ( alphaTyVar )
19 import TysWiredIn       ( intTy, stringTy, mkTupleTy, mkListTy, boolTy )
20 import PrelNames        
21 import Module           ( moduleName, moduleNameFS, modulePackageId )
22 import PackageConfig    ( packageIdFS)
23 import SrcLoc           ( SrcLoc, Located(..), SrcSpan, srcSpanFile,
24                           noLoc, noSrcLoc, isGoodSrcSpan,
25                           srcLocLine, srcLocCol, srcSpanStart )
26
27 import TyCon            ( isUnLiftedTyCon, tyConDataCons )
28 import TypeRep          ( Type(..) )
29 import DataCon          
30 import Type             
31 import MkId             ( unsafeCoerceId, lazyId )
32 import Name             ( Name, mkInternalName )
33 import Var              ( mkTyVar )
34 import Id               ( Id, idType, mkGlobalId, idName )
35
36 import IdInfo           ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) )
37 import BasicTypes       ( Boxity(Boxed) )
38 import OccName          ( mkOccName, tvName )
39
40 import TcRnMonad
41 import HsSyn            
42 import HsLit            ( HsLit(HsString, HsInt) )
43 import CoreSyn          ( CoreExpr, Expr (App) )
44 import CoreUtils        ( exprType )
45 import Outputable
46 import ErrUtils         ( debugTraceMsg )
47 import FastString       ( mkFastString, unpackFS )
48 import DynFlags         ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) )
49  
50 import DsMonad 
51 import {-#SOURCE#-}DsExpr ( dsLExpr ) 
52 import Control.Monad
53 import Data.IORef
54 import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
55 import GHC.Exts         ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
56
57 #if defined(GHCI)
58 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
59 mkBreakpointExpr loc bkptFuncId = do
60         scope' <- getLocalBindsDs
61         mod  <- getModuleDs
62         let scope = filter (isValidType .idType ) scope'
63             mod_name = moduleNameFS$ moduleName mod
64         if null scope && instrumenting
65          then return (l$ HsVar lazyId) 
66          else do
67           when (not instrumenting) $
68               warnDs (text "Extracted ids:" <+> (ppr scope $$ 
69                                                    ppr (map idType scope)))
70           stablePtr <- ioToIOEnv $ newStablePtr scope
71           site <- if instrumenting
72                    then recordBkpt (srcSpanStart loc)
73                    else return 0
74           ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
75           jumpFuncId <- mkJumpFunc bkptFuncId
76           let [opaqueDataCon] = tyConDataCons opaqueTyCon
77               opaqueId = dataConWrapId opaqueDataCon
78               opaqueTy = mkTyConApp opaqueTyCon []
79               wrapInOpaque id = 
80                   l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
81                           (l(HsVar id)))
82            -- Yes, I know... I'm gonna burn in hell.
83               Ptr addr# = castStablePtrToPtr stablePtr
84               hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
85               locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
86                                 , HsLit (HsString mod_name)
87                                 , HsLit (HsInt (fromIntegral site))]
88               
89               funE  = l$ HsVar jumpFuncId
90               ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
91               hvalE = l hvals
92               locE  = l locInfo
93               msgE  = l (srcSpanLit loc)
94           return$  l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
95     where l = L loc
96           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
97 --          isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? 
98           isValidType (FunTy a b) = isValidType a && isValidType b
99           isValidType (NoteTy _ t) = isValidType t
100           isValidType (AppTy a b) = isValidType a && isValidType b
101           isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
102           isValidType _ = True
103           srcSpanLit :: SrcSpan -> HsExpr Id
104           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
105           instrumenting = idName bkptFuncId == breakpointAutoName
106
107 debug_enabled :: DsM Bool
108 debug_enabled = do
109     debugging      <- doptDs Opt_Debugging
110     b_enabled      <- breakpoints_enabled
111     return (debugging && b_enabled)
112
113 breakpoints_enabled :: DsM Bool
114 breakpoints_enabled = do
115     ghcMode            <- getGhcModeDs
116     currentModule      <- getModuleDs
117     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
118     return ( not ignore_breakpoints 
119           && ghcMode == Interactive 
120           && currentModule /= iNTERACTIVE )
121
122 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
123 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
124 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
125   instrumenting <- isInstrumentationSpot lhsexpr
126   if instrumenting
127          then do L _ dynBkpt <- dynBreakpoint loc 
128 --                 return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
129                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
130          else return lhsexpr
131   where l = L loc
132
133 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
134 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
135   coreExpr  <- dsLExpr expr
136   instrumenting <- isInstrumentationSpot expr
137   if instrumenting
138          then do L _ dynBkpt<- dynBreakpoint loc
139                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
140                  return (bkptCore `App` coreExpr)
141          else return coreExpr
142   where l = L loc
143
144 isInstrumentationSpot (L loc e) = do
145   ghcmode   <- getGhcModeDs
146   instrumenting <- debug_enabled 
147   return$ instrumenting     
148           && isGoodSrcSpan loc          -- Avoids 'derived' code
149           && (not$ isRedundant e)
150
151 isRedundant HsLet  {} = True
152 isRedundant HsDo   {} = True
153 isRedundant HsCase {} = True
154 isRedundant     _     = False
155
156 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
157 dynBreakpoint loc | not (isGoodSrcSpan loc) = 
158                          pprPanic "dynBreakpoint" (ppr loc)
159 dynBreakpoint loc = do 
160     let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName 
161                          breakpointAutoTy vanillaIdInfo
162     dflags <- getDOptsDs 
163     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
164     return$ L loc (HsVar autoBreakpoint)
165   where breakpointAutoTy = (ForAllTy alphaTyVar
166                                 (FunTy (TyVarTy  alphaTyVar)
167                                  (TyVarTy alphaTyVar)))
168
169 -- Records a breakpoint site and returns the site number
170 recordBkpt :: SrcLoc -> DsM (Int)
171 --recordBkpt | trace "recordBkpt" False = undefined
172 recordBkpt loc = do
173     sites_var <- getBkptSitesDs
174     sites     <- ioToIOEnv$ readIORef sites_var
175     let site   = length sites + 1
176     let coords = (srcLocLine loc, srcLocCol loc)
177     ioToIOEnv$ writeIORef sites_var ((site, coords) : sites) 
178     return site
179
180 mkJumpFunc :: Id -> DsM Id  
181 mkJumpFunc bkptFuncId
182     | idName bkptFuncId == breakpointName 
183     = build breakpointJumpName id
184     | idName bkptFuncId == breakpointCondName 
185     = build breakpointCondJumpName (FunTy boolTy)
186     | idName bkptFuncId == breakpointAutoName 
187     = build breakpointAutoJumpName id
188   where 
189         tyvar = alphaTyVar
190         basicType extra opaqueTy = 
191                            (FunTy intTy
192                             (FunTy (mkListTy opaqueTy)
193                              (FunTy (mkTupleType [stringTy, stringTy, intTy])
194                               (FunTy stringTy
195                           (ForAllTy tyvar
196                                (extra
197                                 (FunTy (TyVarTy tyvar)
198                                  (TyVarTy tyvar))))))))
199         build name extra  = do 
200             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
201             return$ mkGlobalId VanillaGlobal name
202                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
203         mkTupleType tys = mkTupleTy Boxed (length tys) tys
204
205 #else
206 maybeInsertBreakpoint expr _ = return expr
207 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
208 breakpoints_enabled = False
209 #endif
210 \end{code}