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 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 debug_enabled = do
 108     debugging      <- doptDs Opt_Debugging
 109     b_enabled      <- breakpoints_enabled
 110     return (debugging && b_enabled)
 111
 112 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 113 --maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
 114
 115 isInstrumentationSpot (L loc e) = do
 116   ghcmode   <- getGhcModeDs
 117   instrumenting <- debug_enabled
 118   return$ instrumenting
 119           && isGoodSrcSpan loc          -- Avoids 'derived' code
 120           && (not$ isRedundant e)
 121
 122 isRedundant HsLet  {} = True
 123 isRedundant HsDo   {} = True
 124 isRedundant HsCase {} = True
 125 isRedundant     _     = False
 126
 127 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 128 dynBreakpoint loc | not (isGoodSrcSpan loc) =
 129                          pprPanic "dynBreakpoint" (ppr loc)
 130 dynBreakpoint loc = do
 131     let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
 132                          breakpointAutoTy vanillaIdInfo
 133     dflags <- getDOptsDs
 134     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
 135     return$ L loc (HsVar autoBreakpoint)
 136   where breakpointAutoTy = (ForAllTy alphaTyVar
 137                                 (FunTy (TyVarTy  alphaTyVar)
 138                                  (TyVarTy alphaTyVar)))
 139
 140 -- Records a breakpoint site and returns the site number
 141 recordBkpt :: SrcLoc -> DsM (Int)
 142 --recordBkpt | trace "recordBkpt" False = undefined
 143 recordBkpt loc = do
 144     sites_var <- getBkptSitesDs
 145     sites     <- ioToIOEnv$ readIORef sites_var
 146     let site   = length sites + 1
 147     let coords = (srcLocLine loc, srcLocCol loc)
 148     ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
 149     return site
 150
 151 mkJumpFunc :: Id -> DsM Id
 152 mkJumpFunc bkptFuncId
 153     | idName bkptFuncId == breakpointName
 154     = build breakpointJumpName id
 155     | idName bkptFuncId == breakpointCondName
 156     = build breakpointCondJumpName (FunTy boolTy)
 157     | idName bkptFuncId == breakpointAutoName
 158     = build breakpointAutoJumpName id
 159   where
 160         tyvar = alphaTyVar
 161         basicType extra opaqueTy =
 162                            (FunTy intTy
 163                             (FunTy (mkListTy opaqueTy)
 164                              (FunTy (mkTupleType [stringTy, stringTy, intTy])
 165                               (FunTy stringTy
 166                           (ForAllTy tyvar
 167                                (extra
 168                                 (FunTy (TyVarTy tyvar)
 169                                  (TyVarTy tyvar))))))))
 170         build name extra  = do
 171             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
 172             return$ mkGlobalId VanillaGlobal name
 173                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
 174         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 175
 176 breakpoints_enabled :: DsM Bool
 177 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
 178
 179 #ifdef GHCI
 180 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
 181   instrumenting <- isInstrumentationSpot lhsexpr
 182   if instrumenting
 183          then do L _ dynBkpt <- dynBreakpoint loc
 184 --                 return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
 185                  return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
 186          else return lhsexpr
 187   where l = L loc
 188
 189 dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
 190   coreExpr  <- dsLExpr expr
 191   instrumenting <- isInstrumentationSpot expr
 192   if instrumenting
 193          then do L _ dynBkpt<- dynBreakpoint loc
 194                  bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
 195                  return (bkptCore `App` coreExpr)
 196          else return coreExpr
 197   where l = L loc
 198
 199 breakpoints_enabled = do
 200     ghcMode            <- getGhcModeDs
 201     currentModule      <- getModuleDs
 202     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
 203     return ( not ignore_breakpoints
 204           && ghcMode == Interactive
 205           && currentModule /= iNTERACTIVE )
 206 #else
 207 maybeInsertBreakpoint expr _ = return expr
 208 dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
 209 breakpoints_enabled = return False
 210 #endif
 211 \end{code}