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