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}