, mkBreakpointExpr
) where
-import IOEnv
import TysPrim
import TysWiredIn
import PrelNames
import TypeRep
import DataCon
import Type
-import MkId
-import Name
-import Var
import Id
import IdInfo
import ErrUtils
import FastString
import DynFlags
+import MkId
import DsMonad
import {-#SOURCE#-}DsExpr ( dsLExpr )
import Data.IORef
import Foreign.StablePtr
import GHC.Exts
-
#ifdef GHCI
-mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
-mkBreakpointExpr loc bkptFuncId = do
+mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
+mkBreakpointExpr loc bkptFuncId ty = do
scope <- getScope
mod <- getModuleDs
+ u <- newUnique
let mod_name = moduleNameFS$ moduleName mod
+ valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc
when (not instrumenting) $
warnDs (text "Extracted ids:" <+> (ppr scope $$
ppr (map idType scope)))
- stablePtr <- ioToIOEnv $ newStablePtr scope
- site <- if instrumenting
- then recordBkpt (srcSpanStart loc)
- else return 0
+ stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
+ site <- if instrumenting
+ then recordBkpt (srcSpanStart loc)
+ else return 0
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
- jumpFuncId <- mkJumpFunc bkptFuncId
+ jumpFuncId <- mkJumpFunc bkptFuncId
let [opaqueDataCon] = tyConDataCons opaqueTyCon
opaqueId = dataConWrapId opaqueDataCon
opaqueTy = mkTyConApp opaqueTyCon []
(l(HsVar id)))
-- Yes, I know... I'm gonna burn in hell.
Ptr addr# = castStablePtrToPtr stablePtr
- hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
+ locals = ExplicitList opaqueTy (map wrapInOpaque scope)
locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
, HsLit (HsString mod_name)
, HsLit (HsInt (fromIntegral site))]
funE = l$ HsVar jumpFuncId
ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
- hvalE = l hvals
+ locsE = l (HsApp (l(HsWrap (WpTyApp (mkListTy opaqueTy)) (HsVar lazyId)))
+ (l locals))
locE = l locInfo
msgE = l (srcSpanLit loc)
return $
- l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
+ l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE)
where l = L loc
nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
--- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
srcSpanLit :: SrcSpan -> HsExpr Id
srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
instrumenting = idName bkptFuncId == breakpointAutoName
isValidType (AppTy a b) = isValidType a && isValidType b
isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) &&
all isValidType ts
+-- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
isValidType _ = True
-debug_enabled :: DsM Bool
-#if defined(GHCI) && defined(DEBUGGER)
-debug_enabled = do
- debugging <- doptDs Opt_Debugging
- b_enabled <- breakpoints_enabled
- return (debugging && b_enabled)
-#else
-debug_enabled = return False
-#endif
-
-isInstrumentationSpot (L loc e) = do
- ghcmode <- getGhcModeDs
- instrumenting <- debug_enabled
- return$ instrumenting
- && isGoodSrcSpan loc -- Avoids 'derived' code
- && (not$ isRedundant e)
-
-isEnabledNullScopeCoalescing = True
-isRedundant HsLet {} = True
-isRedundant HsDo {} = True
-isRedundant HsCase {} = False
-isRedundant _ = False
-
dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
#ifdef DEBUG
dynBreakpoint loc | not (isGoodSrcSpan loc) =
(basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
mkTupleType tys = mkTupleTy Boxed (length tys) tys
-breakpoints_enabled :: DsM Bool
+debug_enabled, breakpoints_enabled :: DsM Bool
dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
-#ifdef GHCI
+#if defined(GHCI) && defined(DEBUGGER)
+debug_enabled = do
+ debugging <- doptDs Opt_Debugging
+ b_enabled <- breakpoints_enabled
+ return (debugging && b_enabled)
+
+breakpoints_enabled = do
+ ghcMode <- getGhcModeDs
+ currentModule <- getModuleDs
+ ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
+ return ( not ignore_breakpoints
+ && ghcMode == Interactive
+ && currentModule /= iNTERACTIVE )
+
maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
instrumenting <- isInstrumentationSpot lhsexpr
scope <- getScope
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 = return False
+debug_enabled = return False
#endif
+
+
+isInstrumentationSpot (L loc e) = do
+ ghcmode <- getGhcModeDs
+ instrumenting <- debug_enabled
+ return$ instrumenting
+ && isGoodSrcSpan loc -- Avoids 'derived' code
+ && (not$ isRedundant e)
+
+isEnabledNullScopeCoalescing = True
+isRedundant HsLet {} = True
+isRedundant HsDo {} = True
+isRedundant HsCase {} = False
+isRedundant _ = False
+
\end{code}