, mkBreakpointExpr
) where
-import IOEnv ( ioToIOEnv )
-import TysPrim ( alphaTyVar )
-import TysWiredIn ( intTy, stringTy, mkTupleTy, mkListTy, boolTy )
+import IOEnv
+import TysPrim
+import TysWiredIn
import PrelNames
-import Module ( moduleName, moduleNameFS, modulePackageId )
-import PackageConfig ( packageIdFS)
-import SrcLoc ( SrcLoc, Located(..), SrcSpan, srcSpanFile,
- noLoc, noSrcLoc, isGoodSrcSpan,
- srcLocLine, srcLocCol, srcSpanStart )
-
-import TyCon ( isUnLiftedTyCon, tyConDataCons )
-import TypeRep ( Type(..) )
+import Module
+import PackageConfig
+import SrcLoc
+import TyCon
+import TypeRep
import DataCon
import Type
-import MkId ( unsafeCoerceId, lazyId )
-import Name ( Name, mkInternalName )
-import Var ( mkTyVar )
-import Id ( Id, idType, mkGlobalId, idName )
+import MkId
+import Name
+import Var
+import Id
-import IdInfo ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) )
-import BasicTypes ( Boxity(Boxed) )
-import OccName ( mkOccName, tvName )
+import IdInfo
+import BasicTypes
+import OccName
import TcRnMonad
import HsSyn
-import HsLit ( HsLit(HsString, HsInt) )
-import CoreSyn ( CoreExpr, Expr (App) )
-import CoreUtils ( exprType )
+import HsLit
+import CoreSyn
+import CoreUtils
import Outputable
-import ErrUtils ( debugTraceMsg )
-import FastString ( mkFastString, unpackFS )
-import DynFlags ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) )
+import ErrUtils
+import FastString
+import DynFlags
import DsMonad
import {-#SOURCE#-}DsExpr ( dsLExpr )
import Control.Monad
import Data.IORef
-import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
-import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
+import Foreign.StablePtr
+import GHC.Exts
-#if defined(GHCI)
+#ifdef GHCI
mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
mkBreakpointExpr loc bkptFuncId = do
scope' <- getLocalBindsDs
srcSpanLit :: SrcSpan -> HsExpr Id
srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
instrumenting = idName bkptFuncId == breakpointAutoName
+#else
+mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
+#endif
debug_enabled :: DsM Bool
+#if defined(GHCI) && defined(DEBUGGER)
debug_enabled = do
debugging <- doptDs Opt_Debugging
b_enabled <- breakpoints_enabled
return (debugging && b_enabled)
-
-breakpoints_enabled :: DsM Bool
-breakpoints_enabled = do
- ghcMode <- getGhcModeDs
- currentModule <- getModuleDs
- ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
- return ( not ignore_breakpoints
- && ghcMode == Interactive
- && currentModule /= iNTERACTIVE )
+#else
+debug_enabled = return False
+#endif
maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
--maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
-maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
- instrumenting <- isInstrumentationSpot lhsexpr
- if instrumenting
- then do L _ dynBkpt <- dynBreakpoint loc
--- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
- return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
- else return lhsexpr
- where l = L loc
-
-dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
-dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
- coreExpr <- dsLExpr expr
- instrumenting <- isInstrumentationSpot expr
- if instrumenting
- then do L _ dynBkpt<- dynBreakpoint loc
- bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
- return (bkptCore `App` coreExpr)
- else return coreExpr
- where l = L loc
isInstrumentationSpot (L loc e) = do
ghcmode <- getGhcModeDs
dynBreakpoint loc | not (isGoodSrcSpan loc) =
pprPanic "dynBreakpoint" (ppr loc)
dynBreakpoint loc = do
- let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
+ let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
breakpointAutoTy vanillaIdInfo
dflags <- getDOptsDs
ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
(TyVarTy tyvar))))))))
build name extra = do
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
- return$ mkGlobalId VanillaGlobal name
+ return$ Id.mkGlobalId VanillaGlobal name
(basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
mkTupleType tys = mkTupleTy Boxed (length tys) tys
+breakpoints_enabled :: DsM Bool
+dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
+
+#ifdef GHCI
+maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
+ instrumenting <- isInstrumentationSpot lhsexpr
+ if instrumenting
+ then do L _ dynBkpt <- dynBreakpoint loc
+-- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
+ return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
+ else return lhsexpr
+ where l = L loc
+
+dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
+ coreExpr <- dsLExpr expr
+ instrumenting <- isInstrumentationSpot expr
+ if instrumenting
+ then do L _ dynBkpt<- dynBreakpoint loc
+ bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
+ return (bkptCore `App` coreExpr)
+ else return coreExpr
+ where l = L loc
+
+breakpoints_enabled = do
+ ghcMode <- getGhcModeDs
+ currentModule <- getModuleDs
+ ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
+ return ( not ignore_breakpoints
+ && ghcMode == Interactive
+ && currentModule /= iNTERACTIVE )
#else
maybeInsertBreakpoint expr _ = return expr
dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
-breakpoints_enabled = False
+breakpoints_enabled = return False
#endif
\end{code}