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