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     dflags             <- getDOptsDs
 170     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
 171     return ( not ignore_breakpoints
 172           && hscTarget dflags == HscInterpreted
 173           && currentModule /= iNTERACTIVE )
 174
 175 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
 176   instrumenting <- isInstrumentationSpot lhsexpr
 177   scope         <- getScope
 178   if instrumenting && not(isUnLiftedType ty) &&
 179      not(isEnabledNullScopeCoalescing && null scope)
 180          then do L _ dynBkpt <- dynBreakpoint loc
 181                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
 182          else return lhsexpr
 183   where l = L loc
 184 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
 185   coreExpr      <- dsLExpr expr
 186   instrumenting <- isInstrumentationSpot expr
 187   scope         <- getScope
 188   let ty = exprType coreExpr
 189   if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
 190      not(isEnabledNullScopeCoalescing && null scope)
 191          then do L _ dynBkpt<- dynBreakpoint loc
 192                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
 193                  return (bkptCore `App` coreExpr)
 194          else return coreExpr
 195   where l = L loc
 196 #else
 197 maybeInsertBreakpoint expr _ = return expr
 198 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
 199 breakpoints_enabled = return False
 200 debug_enabled = return False
 201 #endif
 202
 203
 204 isInstrumentationSpot (L loc e) = do
 205   ghcmode   <- getGhcModeDs
 206   instrumenting <- debug_enabled
 207   return$ instrumenting
 208           && isGoodSrcSpan loc          -- Avoids 'derived' code
 209           && (not$ isRedundant e)
 210
 211 isEnabledNullScopeCoalescing = True
 212 isRedundant HsLet  {} = True
 213 isRedundant HsDo   {} = True
 214 isRedundant HsCase {} = False
 215 isRedundant     _     = False
 216
 217 \end{code}