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 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
  55 mkBreakpointExpr loc bkptFuncId = do
  56         scope' <- getLocalBindsDs
  57         mod  <- getModuleDs
  58         let scope = filter (isValidType .idType ) scope'
  59             mod_name = moduleNameFS$ moduleName mod
  60         if null scope && instrumenting
  61          then return (l$ HsVar lazyId)
  62          else do
  63           when (not instrumenting) $
  64               warnDs (text "Extracted ids:" <+> (ppr scope $$
  65                                                    ppr (map idType scope)))
  66           stablePtr <- ioToIOEnv $ newStablePtr scope
  67           site <- if instrumenting
  68                    then recordBkpt (srcSpanStart loc)
  69                    else return 0
  70           ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
  71           jumpFuncId <- mkJumpFunc bkptFuncId
  72           let [opaqueDataCon] = tyConDataCons opaqueTyCon
  73               opaqueId = dataConWrapId opaqueDataCon
  74               opaqueTy = mkTyConApp opaqueTyCon []
  75               wrapInOpaque id =
  76                   l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
  77                           (l(HsVar id)))
  78            -- Yes, I know... I'm gonna burn in hell.
  79               Ptr addr# = castStablePtrToPtr stablePtr
  80               hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
  81               locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
  82                                 , HsLit (HsString mod_name)
  83                                 , HsLit (HsInt (fromIntegral site))]
  84
  85               funE  = l$ HsVar jumpFuncId
  86               ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
  87               hvalE = l hvals
  88               locE  = l locInfo
  89               msgE  = l (srcSpanLit loc)
  90           return$  l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
  91     where l = L loc
  92           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
  93 --          isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
  94           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) && all isValidType ts
  98           isValidType _ = True
  99           srcSpanLit :: SrcSpan -> HsExpr Id
 100           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
 101           instrumenting = idName bkptFuncId == breakpointAutoName
 102
 103 debug_enabled :: DsM Bool
 104 #if defined(GHCI) && defined(DEBUGGER)
 105 debug_enabled = do
 106     debugging      <- doptDs Opt_Debugging
 107     b_enabled      <- breakpoints_enabled
 108     return (debugging && b_enabled)
 109 #else
 110 debug_enabled = return False
 111 #endif
 112
 113 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 114 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
 115
 116 isInstrumentationSpot (L loc e) = do
 117   ghcmode   <- getGhcModeDs
 118   instrumenting <- debug_enabled
 119   return$ instrumenting
 120           && isGoodSrcSpan loc          -- Avoids 'derived' code
 121           && (not$ isRedundant e)
 122
 123 isRedundant HsLet  {} = True
 124 isRedundant HsDo   {} = True
 125 isRedundant HsCase {} = True
 126 isRedundant     _     = False
 127
 128 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 129 dynBreakpoint loc | not (isGoodSrcSpan loc) =
 130                          pprPanic "dynBreakpoint" (ppr loc)
 131 dynBreakpoint loc = do
 132     let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
 133                          breakpointAutoTy vanillaIdInfo
 134     dflags <- getDOptsDs
 135     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
 136     return$ L loc (HsVar autoBreakpoint)
 137   where breakpointAutoTy = (ForAllTy alphaTyVar
 138                                 (FunTy (TyVarTy  alphaTyVar)
 139                                  (TyVarTy alphaTyVar)))
 140
 141 -- Records a breakpoint site and returns the site number
 142 recordBkpt :: SrcLoc -> DsM (Int)
 143 --recordBkpt | trace "recordBkpt" False = undefined
 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
 180 #ifdef GHCI
 181 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
 182   instrumenting <- isInstrumentationSpot lhsexpr
 183   if instrumenting
 184          then do L _ dynBkpt <- dynBreakpoint loc
 185 --                 return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
 186                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
 187          else return lhsexpr
 188   where l = L loc
 189
 190 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
 191   coreExpr  <- dsLExpr expr
 192   instrumenting <- isInstrumentationSpot expr
 193   if instrumenting
 194          then do L _ dynBkpt<- dynBreakpoint loc
 195                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
 196                  return (bkptCore `App` coreExpr)
 197          else return coreExpr
 198   where l = L loc
 199
 200 breakpoints_enabled = do
 201     ghcMode            <- getGhcModeDs
 202     currentModule      <- getModuleDs
 203     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
 204     return ( not ignore_breakpoints
 205           && ghcMode == Interactive
 206           && currentModule /= iNTERACTIVE )
 207 #else
 208 maybeInsertBreakpoint expr _ = return expr
 209 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
 210 breakpoints_enabled = return False
 211 #endif
 212 \end{code}