0282d6dbdba6fb734f2252df1183bea25b2c0a5e
[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( debug_enabled
11                    , dsAndThenMaybeInsertBreakpoint
12                    , maybeInsertBreakpoint
13                    , breakpoints_enabled
14                    , mkBreakpointExpr
15                    ) where
16
17 import TysPrim
18 import TysWiredIn
19 import PrelNames        
20 import Module
21 import SrcLoc
22 import TyCon
23 import TypeRep
24 import DataCon          
25 import Type             
26 import Id 
27
28 import IdInfo
29 import BasicTypes
30 import OccName
31
32 import TcRnMonad
33 import HsSyn            
34 import HsLit
35 import CoreSyn
36 import CoreUtils
37 import Outputable
38 import ErrUtils
39 import FastString
40 import DynFlags
41 import MkId
42  
43 import DsMonad 
44 import {-#SOURCE#-}DsExpr ( dsLExpr ) 
45 import Control.Monad
46 import Data.IORef
47 import Foreign.StablePtr
48 import GHC.Exts
49
50 #ifdef GHCI
51 mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
52 mkBreakpointExpr loc bkptFuncId ty = do
53         scope <- getScope
54         mod   <- getModuleDs
55         u     <- newUnique
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)
63                         else return 0
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 []
70             wrapInOpaque id = 
71                   l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
72                           (l(HsVar id)))
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#)))))
80             locE  = locInfo
81             msgE  = srcSpanLit loc
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]
85         return $ 
86             l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
87
88     where l = L loc
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
94 #else
95 mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
96 #endif
97
98 getScope :: DsM [Id]
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) && 
104                                           all isValidType ts
105 --        isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? 
106           isValidType _ = True
107
108 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
109 #ifdef DEBUG
110 dynBreakpoint loc | not (isGoodSrcSpan loc) = 
111                          pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
112 #endif
113 dynBreakpoint loc = do 
114     let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName 
115                          breakpointAutoTy vanillaIdInfo
116     dflags <- getDOptsDs 
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)))
122
123 -- Records a breakpoint site and returns the site number
124 recordBkpt :: SrcLoc -> DsM (Int)
125 recordBkpt loc = do
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) 
131     return site
132
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
141   where 
142         tyvar = alphaTyVar
143         basicType extra opaqueTy = 
144                (FunTy (mkTupleType [stringTy, intTy])
145                  (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
146                           (ForAllTy tyvar
147                                (extra
148                                 (FunTy (TyVarTy tyvar)
149                                  (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
155
156 debug_enabled, breakpoints_enabled :: DsM Bool
157 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
158 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
159
160 #if defined(GHCI) && defined(DEBUGGER)
161 debug_enabled = do
162     debugging      <- doptDs Opt_Debugging
163     b_enabled      <- breakpoints_enabled
164     return (debugging && b_enabled)
165
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 )
173
174 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
175   instrumenting <- isInstrumentationSpot lhsexpr
176   scope         <- getScope
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)
181          else return lhsexpr
182   where l = L loc
183 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
184   coreExpr      <- dsLExpr expr
185   instrumenting <- isInstrumentationSpot expr
186   scope         <- getScope
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)
193          else return coreExpr
194   where l = L loc
195 #else
196 maybeInsertBreakpoint expr _ = return expr
197 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
198 breakpoints_enabled = return False
199 debug_enabled = return False
200 #endif
201
202
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)
209
210 isEnabledNullScopeCoalescing = True
211 isRedundant HsLet  {} = True
212 isRedundant HsDo   {} = True
213 isRedundant HsCase {} = False
214 isRedundant     _     = False
215
216 \end{code}