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