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