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             hvals = 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             hvalE = l hvals
  79             locE  = l locInfo
  80             msgE  = l (srcSpanLit loc)
  81         return $
  82             l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
  83     where l = L loc
  84           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
  85 --          isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
  86           srcSpanLit :: SrcSpan -> HsExpr Id
  87           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
  88           instrumenting = idName bkptFuncId == breakpointAutoName
  89 #else
  90 mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
  91 #endif
  92
  93 getScope :: DsM [Id]
  94 getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
  95     where 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) &&
  99                                           all isValidType ts
 100           isValidType _ = True
 101
 102 debug_enabled :: DsM Bool
 103 #if defined(GHCI) && defined(DEBUGGER)
 104 debug_enabled = do
 105     debugging      <- doptDs Opt_Debugging
 106     b_enabled      <- breakpoints_enabled
 107     return (debugging && b_enabled)
 108 #else
 109 debug_enabled = return False
 110 #endif
 111
 112 isInstrumentationSpot (L loc e) = do
 113   ghcmode   <- getGhcModeDs
 114   instrumenting <- debug_enabled
 115   return$ instrumenting
 116           && isGoodSrcSpan loc          -- Avoids 'derived' code
 117           && (not$ isRedundant e)
 118
 119 isEnabledNullScopeCoalescing = True
 120 isRedundant HsLet  {} = True
 121 isRedundant HsDo   {} = True
 122 isRedundant HsCase {} = False
 123 isRedundant     _     = False
 124
 125 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 126 #ifdef DEBUG
 127 dynBreakpoint loc | not (isGoodSrcSpan loc) =
 128                          pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
 129 #endif
 130 dynBreakpoint loc = do
 131     let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
 132                          breakpointAutoTy vanillaIdInfo
 133     dflags <- getDOptsDs
 134     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
 135     return$ L loc (HsVar autoBreakpoint)
 136   where breakpointAutoTy = (ForAllTy alphaTyVar
 137                                 (FunTy (TyVarTy  alphaTyVar)
 138                                  (TyVarTy alphaTyVar)))
 139
 140 -- Records a breakpoint site and returns the site number
 141 recordBkpt :: SrcLoc -> DsM (Int)
 142 recordBkpt loc = do
 143     sites_var <- getBkptSitesDs
 144     sites     <- ioToIOEnv$ readIORef sites_var
 145     let site   = length sites + 1
 146     let coords = (srcLocLine loc, srcLocCol loc)
 147     ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
 148     return site
 149
 150 mkJumpFunc :: Id -> DsM Id
 151 mkJumpFunc bkptFuncId
 152     | idName bkptFuncId == breakpointName
 153     = build breakpointJumpName id
 154     | idName bkptFuncId == breakpointCondName
 155     = build breakpointCondJumpName (FunTy boolTy)
 156     | idName bkptFuncId == breakpointAutoName
 157     = build breakpointAutoJumpName id
 158   where
 159         tyvar = alphaTyVar
 160         basicType extra opaqueTy =
 161                            (FunTy intTy
 162                             (FunTy (mkListTy opaqueTy)
 163                              (FunTy (mkTupleType [stringTy, stringTy, intTy])
 164                               (FunTy stringTy
 165                           (ForAllTy tyvar
 166                                (extra
 167                                 (FunTy (TyVarTy tyvar)
 168                                  (TyVarTy tyvar))))))))
 169         build name extra  = do
 170             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
 171             return$ Id.mkGlobalId VanillaGlobal name
 172                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
 173         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 174
 175 breakpoints_enabled :: DsM Bool
 176 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
 177 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 178
 179 #ifdef GHCI
 180 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
 181   instrumenting <- isInstrumentationSpot lhsexpr
 182   scope         <- getScope
 183   if instrumenting && not(isUnLiftedType ty) &&
 184      not(isEnabledNullScopeCoalescing && null scope)
 185          then do L _ dynBkpt <- dynBreakpoint loc
 186                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
 187          else return lhsexpr
 188   where l = L loc
 189 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
 190   coreExpr      <- dsLExpr expr
 191   instrumenting <- isInstrumentationSpot expr
 192   scope         <- getScope
 193   let ty = exprType coreExpr
 194   if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
 195      not(isEnabledNullScopeCoalescing && null scope)
 196          then do L _ dynBkpt<- dynBreakpoint loc
 197                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp ty) 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}