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