1abfb0caba86228ec9b15d1397d908b89080717a
[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 mkJumpFunc :: Id -> DsM Id  
108 mkJumpFunc bkptFuncId
109     | idName bkptFuncId == breakpointName 
110     = build breakpointJumpName id
111     | idName bkptFuncId == breakpointCondName 
112     = build breakpointCondJumpName (FunTy boolTy)
113     | idName bkptFuncId == breakpointAutoName 
114     = build breakpointAutoJumpName id
115   where 
116         tyvar = alphaTyVar
117         basicType extra opaqueTy = 
118                            (FunTy intTy
119                             (FunTy (mkListTy opaqueTy)
120                              (FunTy (mkTupleType [stringTy, stringTy, intTy])
121                               (FunTy stringTy
122                           (ForAllTy tyvar
123                                (extra
124                                 (FunTy (TyVarTy tyvar)
125                                  (TyVarTy tyvar))))))))
126         build name extra  = do 
127             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
128             return$ mkGlobalId VanillaGlobal name
129                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
130         mkTupleType tys = mkTupleTy Boxed (length tys) tys
131
132 #endif
133 \end{code}