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( debug_enabled
  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 SrcLoc
  22 import TyCon
  23 import TypeRep
  24 import DataCon
  25 import Type
  26 import Id
  27
  28 import IdInfo
  29 import BasicTypes
  30 import OccName
  31
  32 import TcRnMonad
  33 import HsSyn
  34 import HsLit
  35 import CoreSyn
  36 import CoreUtils
  37 import Outputable
  38 import ErrUtils
  39 import FastString
  40 import DynFlags
  41 import MkId
  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
  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 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         Just mod_name_ref  <- getModNameRefDs
  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 [ HsVar mod_name_ref
  77                               , HsLit (HsInt (fromIntegral site))]
  78             funE  = l$ HsVar jumpFuncId
  79             ptrE  = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
  80             locE  = locInfo
  81             msgE  = srcSpanLit loc
  82             argsE = nlTuple [ptrE, locals, msgE]
  83             lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
  84             argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
  85         return $
  86             l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
  87
  88     where l = L loc
  89           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
  90           srcSpanLit :: SrcSpan -> HsExpr Id
  91           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
  92           instrumenting = idName bkptFuncId == breakpointAutoName
  93           mkTupleType tys = mkTupleTy Boxed (length tys) tys
  94 #else
  95 mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
  96 #endif
  97
  98 getScope :: DsM [Id]
  99 getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
 100     where isValidType (FunTy a b)  = isValidType a && isValidType b
 101           isValidType (NoteTy _ t) = isValidType t
 102           isValidType (AppTy a b)  = isValidType a && isValidType b
 103           isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) &&
 104                                           all isValidType ts
 105 --        isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
 106           isValidType _ = True
 107
 108 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 109 #ifdef DEBUG
 110 dynBreakpoint loc | not (isGoodSrcSpan loc) =
 111                          pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
 112 #endif
 113 dynBreakpoint loc = do
 114     let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
 115                          breakpointAutoTy vanillaIdInfo
 116     dflags <- getDOptsDs
 117     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
 118     return$ L loc (HsVar autoBreakpoint)
 119   where breakpointAutoTy = (ForAllTy alphaTyVar
 120                                 (FunTy (TyVarTy  alphaTyVar)
 121                                  (TyVarTy alphaTyVar)))
 122
 123 -- Records a breakpoint site and returns the site number
 124 recordBkpt :: SrcLoc -> DsM (Int)
 125 recordBkpt loc = do
 126     sites_var <- getBkptSitesDs
 127     sites     <- ioToIOEnv$ readIORef sites_var
 128     let site   = length sites + 1
 129     let coords = (srcLocLine loc, srcLocCol loc)
 130     ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
 131     return site
 132
 133 mkJumpFunc :: Id -> DsM Id
 134 mkJumpFunc bkptFuncId
 135     | idName bkptFuncId == breakpointName
 136     = build breakpointJumpName id
 137     | idName bkptFuncId == breakpointCondName
 138     = build breakpointCondJumpName (FunTy boolTy)
 139     | idName bkptFuncId == breakpointAutoName
 140     = build breakpointAutoJumpName id
 141   where
 142         tyvar = alphaTyVar
 143         basicType extra opaqueTy =
 144                (FunTy (mkTupleType [stringTy, intTy])
 145                  (FunTy (mkTupleType [intTy, mkListTy opaqueTy, 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}