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