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