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