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 <- getScope
  58         mod   <- getModuleDs
  59         let mod_name = moduleNameFS$ moduleName mod
  60         when (not instrumenting) $
  61               warnDs (text "Extracted ids:" <+> (ppr scope $$
  62                                                    ppr (map idType scope)))
  63         stablePtr <- ioToIOEnv $ newStablePtr scope
  64         site <- if instrumenting
  65                    then recordBkpt (srcSpanStart loc)
  66                    else return 0
  67         ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
  68         jumpFuncId <- mkJumpFunc bkptFuncId
  69         let [opaqueDataCon] = tyConDataCons opaqueTyCon
  70             opaqueId = dataConWrapId opaqueDataCon
  71             opaqueTy = mkTyConApp opaqueTyCon []
  72             wrapInOpaque id =
  73                   l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
  74                           (l(HsVar id)))
  75            -- Yes, I know... I'm gonna burn in hell.
  76             Ptr addr# = castStablePtrToPtr stablePtr
  77             hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
  78             locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
  79                               , HsLit (HsString mod_name)
  80                               , HsLit (HsInt (fromIntegral site))]
  81             funE  = l$ HsVar jumpFuncId
  82             ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
  83             hvalE = l hvals
  84             locE  = l locInfo
  85             msgE  = l (srcSpanLit loc)
  86         return $
  87             l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
  88     where l = L loc
  89           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
  90 --          isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
  91           srcSpanLit :: SrcSpan -> HsExpr Id
  92           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
  93           instrumenting = idName bkptFuncId == breakpointAutoName
  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 _ = True
 106
 107 debug_enabled :: DsM Bool
 108 #if defined(GHCI) && defined(DEBUGGER)
 109 debug_enabled = do
 110     debugging      <- doptDs Opt_Debugging
 111     b_enabled      <- breakpoints_enabled
 112     return (debugging && b_enabled)
 113 #else
 114 debug_enabled = return False
 115 #endif
 116
 117 isInstrumentationSpot (L loc e) = do
 118   ghcmode   <- getGhcModeDs
 119   instrumenting <- debug_enabled
 120   return$ instrumenting
 121           && isGoodSrcSpan loc          -- Avoids 'derived' code
 122           && (not$ isRedundant e)
 123
 124 isEnabledNullScopeCoalescing = True
 125 isRedundant HsLet  {} = True
 126 isRedundant HsDo   {} = True
 127 isRedundant HsCase {} = False
 128 isRedundant     _     = False
 129
 130 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 131 #ifdef DEBUG
 132 dynBreakpoint loc | not (isGoodSrcSpan loc) =
 133                          pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
 134 #endif
 135 dynBreakpoint loc = do
 136     let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
 137                          breakpointAutoTy vanillaIdInfo
 138     dflags <- getDOptsDs
 139     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
 140     return$ L loc (HsVar autoBreakpoint)
 141   where breakpointAutoTy = (ForAllTy alphaTyVar
 142                                 (FunTy (TyVarTy  alphaTyVar)
 143                                  (TyVarTy alphaTyVar)))
 144
 145 -- Records a breakpoint site and returns the site number
 146 recordBkpt :: SrcLoc -> DsM (Int)
 147 recordBkpt loc = do
 148     sites_var <- getBkptSitesDs
 149     sites     <- ioToIOEnv$ readIORef sites_var
 150     let site   = length sites + 1
 151     let coords = (srcLocLine loc, srcLocCol loc)
 152     ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
 153     return site
 154
 155 mkJumpFunc :: Id -> DsM Id
 156 mkJumpFunc bkptFuncId
 157     | idName bkptFuncId == breakpointName
 158     = build breakpointJumpName id
 159     | idName bkptFuncId == breakpointCondName
 160     = build breakpointCondJumpName (FunTy boolTy)
 161     | idName bkptFuncId == breakpointAutoName
 162     = build breakpointAutoJumpName id
 163   where
 164         tyvar = alphaTyVar
 165         basicType extra opaqueTy =
 166                            (FunTy intTy
 167                             (FunTy (mkListTy opaqueTy)
 168                              (FunTy (mkTupleType [stringTy, stringTy, intTy])
 169                               (FunTy stringTy
 170                           (ForAllTy tyvar
 171                                (extra
 172                                 (FunTy (TyVarTy tyvar)
 173                                  (TyVarTy tyvar))))))))
 174         build name extra  = do
 175             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
 176             return$ Id.mkGlobalId VanillaGlobal name
 177                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
 178         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 179
 180 breakpoints_enabled :: DsM Bool
 181 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
 182 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 183
 184 #ifdef GHCI
 185 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
 186   instrumenting <- isInstrumentationSpot lhsexpr
 187   scope         <- getScope
 188   if instrumenting && not(isUnLiftedType ty) &&
 189      not(isEnabledNullScopeCoalescing && null scope)
 190          then do L _ dynBkpt <- dynBreakpoint loc
 191                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
 192          else return lhsexpr
 193   where l = L loc
 194 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
 195   coreExpr      <- dsLExpr expr
 196   instrumenting <- isInstrumentationSpot expr
 197   scope         <- getScope
 198   let ty = exprType coreExpr
 199   if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
 200      not(isEnabledNullScopeCoalescing && null scope)
 201          then do L _ dynBkpt<- dynBreakpoint loc
 202                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
 203                  return (bkptCore `App` coreExpr)
 204          else return coreExpr
 205   where l = L loc
 206
 207 breakpoints_enabled = do
 208     ghcMode            <- getGhcModeDs
 209     currentModule      <- getModuleDs
 210     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
 211     return ( not ignore_breakpoints
 212           && ghcMode == Interactive
 213           && currentModule /= iNTERACTIVE )
 214 #else
 215 maybeInsertBreakpoint expr _ = return expr
 216 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
 217 breakpoints_enabled = return False
 218 #endif
 219 \end{code}