-fignore-breakpoints can be used to ignore breakpoints.
ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
# Yes, include the interepreter, readline, and Template Haskell extensions
-SRC_HC_OPTS += -DGHCI -package template-haskell
+SRC_HC_OPTS += -DGHCI -DBREAKPOINT -package template-haskell
PKG_DEPENDS += template-haskell
# Use threaded RTS with GHCi, so threads don't get blocked at the prompt.
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
- pAT_ERROR_ID, eRROR_ID
+ pAT_ERROR_ID, eRROR_ID,
+
+ unsafeCoerceName
) where
#include "HsVersions.h"
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
#include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
+import GHC.Exts ( Ptr(..), Int(..), addr2Int# )
+import IOEnv ( ioToIOEnv )
+import PrelNames ( breakpointJumpName )
+import TysWiredIn ( unitTy )
+import TypeRep ( Type(..) )
+#endif
import Match ( matchWrapper, matchSinglePat, matchEquations )
import MatchLit ( dsLit, dsOverLit )
= matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
+#if defined(GHCI) && defined(BREAKPOINT)
+dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
+ | HsVar funId <- fun
+ , idName funId == breakpointJumpName
+ , ids <- filter (not.hasTyVar.idType) (extractIds arg)
+ = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+ stablePtr <- ioToIOEnv $ newStablePtr ids
+ -- Yes, I know... I'm gonna burn in hell.
+ let Ptr addr# = castStablePtrToPtr stablePtr
+ funCore <- dsLExpr realFun
+ argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
+ hvalCore <- dsLExpr (L loc (extractHVals ids))
+ return ((funCore `App` argCore) `App` hvalCore)
+ where extractIds :: HsExpr Id -> [Id]
+ extractIds (HsApp fn arg)
+ | HsVar argId <- unLoc arg
+ = argId:extractIds (unLoc fn)
+ | TyApp arg' ts <- unLoc arg
+ , HsVar argId <- unLoc arg'
+ = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+ extractIds x = []
+ extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
+ hasTyVar (TyVarTy _) = True
+ hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
+ hasTyVar (NoteTy _ t) = hasTyVar t
+ hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
+ hasTyVar (TyConApp _ ts) = any hasTyVar ts
+ hasTyVar _ = False
+#endif
+
dsExpr expr@(HsApp fun arg)
= dsLExpr fun `thenDs` \ core_fun ->
dsLExpr arg `thenDs` \ core_arg ->
#include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
+import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
+import System.IO.Unsafe ( unsafePerformIO )
+import Var ( Id, globaliseId, idName, idType )
+import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
+ , extendTypeEnvWithIds )
+import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
+import NameEnv ( delListFromNameEnv )
+import TcType ( tidyTopType )
+import qualified Id ( setIdType )
+import IdInfo ( GlobalIdDetails(..) )
+import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
+import PrelNames ( breakpointJumpName )
+#endif
+
-- The GHC interface
import qualified GHC
import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
" (eg. -v2, -fglasgow-exts, etc.)\n"
+#if defined(GHCI) && defined(BREAKPOINT)
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+ = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
+
+
+printScopeMsg :: Session -> String -> [Id] -> IO ()
+printScopeMsg session location ids
+ = GHC.getPrintUnqual session >>= \unqual ->
+ printForUser stdout unqual $
+ text "Local bindings in scope:" $$
+ nest 2 (pprWithCommas showId ids)
+ where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
+jumpFunction session@(Session ref) (I# idsPtr) hValues location b
+ = unsafePerformIO $
+ do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+ let names = map idName ids
+ ASSERT (length names == length hValues) return ()
+ printScopeMsg session location ids
+ hsc_env <- readIORef ref
+
+ let ictxt = hsc_IC hsc_env
+ global_ids = map globaliseAndTidy ids
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName global_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ withExtendedLinkEnv (zip names hValues) $
+ startGHCi (runGHCi [] Nothing)
+ GHCiState{ progname = "<interactive>",
+ args = [],
+ prompt = location++"> ",
+ session = session,
+ options = [] }
+ writeIORef ref hsc_env
+ putStrLn $ "Returning to normal execution..."
+ return b
+#endif
+
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
-
+#if defined(GHCI) && defined(BREAKPOINT)
+ initDynLinker =<< GHC.getSessionDynFlags session
+ extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
+#endif
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
setContextAfterLoad session graph'
modulesLoadedMsg ok (map GHC.ms_mod graph')
+#if defined(GHCI) && defined(BREAKPOINT)
+ io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
+#endif
setContextAfterLoad session [] = do
io (GHC.setContext session [] [prelude_mod])
{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
module Linker ( HValue, showLinkerState,
- linkExpr, unload, extendLinkEnv,
+ linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
extendLoadedPkgs,
- linkPackages,
+ linkPackages,initDynLinker
) where
#include "HsVersions.h"
import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
import System.Directory ( doesFileExist )
-import Control.Exception ( block, throwDyn )
+import Control.Exception ( block, throwDyn, bracket )
import Maybe ( isJust, fromJust )
#if __GLASGOW_HASKELL__ >= 503
new_pls = pls { closure_env = new_closure_env }
writeIORef v_PersistentLinkerState new_pls
+withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+withExtendedLinkEnv new_env action
+ = bracket set_new_env
+ reset_old_env
+ (const action)
+ where set_new_env = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_env
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+ return pls
+ reset_old_env pls = writeIORef v_PersistentLinkerState pls
+
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;
-- Note that this removes all *local* (i.e. non-isExternal) names too
| Opt_OmitInterfacePragmas
| Opt_DoLambdaEtaExpansion
| Opt_IgnoreAsserts
+ | Opt_IgnoreBreakpoints
| Opt_DoEtaReduction
| Opt_CaseMerge
| Opt_UnboxStrictFields
( "omit-interface-pragmas", Opt_OmitInterfacePragmas ),
( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ),
( "ignore-asserts", Opt_IgnoreAsserts ),
+ ( "ignore-breakpoints", Opt_IgnoreBreakpoints),
( "do-eta-reduction", Opt_DoEtaReduction ),
( "case-merge", Opt_CaseMerge ),
( "unbox-strict-fields", Opt_UnboxStrictFields ),
-- Others
otherwiseIdName,
plusIntegerName, timesIntegerName,
- eqStringName, assertName, assertErrorName, runSTRepName,
+ eqStringName, assertName, breakpointName, assertErrorName,
+ runSTRepName,
printName, fstName, sndName,
-- MonadFix
failMName = methName monadClassName FSLIT("fail") failMClassOpKey
-- Random PrelBase functions
-otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey
-foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey
-buildName = varQual pREL_BASE FSLIT("build") buildIdKey
-augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey
-appendName = varQual pREL_BASE FSLIT("++") appendIdKey
-andName = varQual pREL_BASE FSLIT("&&") andIdKey
-orName = varQual pREL_BASE FSLIT("||") orIdKey
-assertName = varQual pREL_BASE FSLIT("assert") assertIdKey
+otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey
+foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey
+buildName = varQual pREL_BASE FSLIT("build") buildIdKey
+augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey
+appendName = varQual pREL_BASE FSLIT("++") appendIdKey
+andName = varQual pREL_BASE FSLIT("&&") andIdKey
+orName = varQual pREL_BASE FSLIT("||") orIdKey
+assertName = varQual pREL_BASE FSLIT("assert") assertIdKey
+breakpointName = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey
+breakpointJumpName
+ = mkInternalName
+ breakpointJumpIdKey
+ (mkOccNameFS varName FSLIT("breakpointJump"))
+ noSrcLoc
-- PrelTup
fstName = varQual pREL_TUP FSLIT("fst") fstIdKey
lazyIdKey = mkPreludeMiscIdUnique 60
assertErrorIdKey = mkPreludeMiscIdUnique 61
+breakpointIdKey = mkPreludeMiscIdUnique 62
+breakpointJumpIdKey = mkPreludeMiscIdUnique 63
+
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 80
lengthPIdKey = mkPreludeMiscIdUnique 81
import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName )
+#if defined(GHCI) && defined(BREAKPOINT)
+import PrelNames ( breakpointJumpName, undefined_RDR, breakpointIdKey )
+import UniqFM ( eltsUFM )
+import DynFlags ( GhcMode(..) )
+import SrcLoc ( srcSpanFile, srcSpanStartLine )
+import Name ( isTyVarName )
+#endif
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
rnExpr (HsVar v)
- = lookupOccRn v `thenM` \ name ->
- doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
- if name `hasKey` assertIdKey && not ignore_asserts then
- -- We expand it to (GHC.Err.assertError location_string)
- mkAssertErrorExpr `thenM` \ (e, fvs) ->
- returnM (e, fvs `addOneFV` name)
- -- Keep 'assert' as a free var, to ensure it's not reported as unused!
- else
- -- The normal case. Even if the Id was 'assert', if we are
- -- ignoring assertions we leave it as GHC.Base.assert;
- -- this function just ignores its first arg.
- returnM (HsVar name, unitFV name)
+ = do name <- lookupOccRn v
+ localRdrEnv <- getLocalRdrEnv
+ lclEnv <- getLclEnv
+ ignore_asserts <- doptM Opt_IgnoreAsserts
+ ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
+ let conds = [ (name `hasKey` assertIdKey
+ && not ignore_asserts,
+ do (e, fvs) <- mkAssertErrorExpr
+ return (e, fvs `addOneFV` name))
+#if defined(GHCI) && defined(BREAKPOINT)
+ , (name `hasKey` breakpointIdKey
+ && not ignore_breakpoints,
+ do ghcMode <- getGhcMode
+ case ghcMode of
+ Interactive
+ -> do let isWantedName = not.isTyVarName
+ (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv))
+ return (e, fvs `addOneFV` name)
+ _ -> return (HsVar name, unitFV name)
+ )
+#endif
+ ]
+ case lookup True conds of
+ Just action -> action
+ Nothing -> return (HsVar name, unitFV name)
rnExpr (HsIPVar v)
= newIPNameRn v `thenM` \ name ->
%************************************************************************
%* *
+\subsubsection{breakpoint utils}
+%* *
+%************************************************************************
+
+\begin{code}
+#if defined(GHCI) && defined(BREAKPOINT)
+mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakPointExpr scope
+ = do sloc <- getSrcSpanM
+ undef <- lookupOccRn undefined_RDR
+ let inLoc = L sloc
+ lHsApp x y = inLoc (HsApp x y)
+ mkExpr fnName args = mkExpr' fnName (reverse args)
+ mkExpr' fnName [] = inLoc (HsVar fnName)
+ mkExpr' fnName (arg:args)
+ = lHsApp (mkExpr' fnName args) (inLoc arg)
+ expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg]
+ mkScopeArg args
+ = unLoc $ mkExpr undef (map HsVar args)
+ msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))
+ return (expr, emptyFVs)
+#endif
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection{Assertion utils}
%* *
%************************************************************************
import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
import OccName ( mkVarOccFS )
import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
- mkExternalName )
+ mkExternalName, isInternalName )
import NameSet
import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
let name = gre_name gre,
+ not (isInternalName name),
isTcOcc (nameOccName name), -- Types and classes only
unQualOK gre ] -- In scope unqualified
doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
+#if defined(GHCI) && defined(BREAKPOINT)
+import TypeRep ( Type(..), liftedTypeKind, TyThing(..) )
+import Var ( mkTyVar, mkGlobalId )
+import IdInfo ( GlobalIdDetails(..), vanillaIdInfo )
+import OccName ( mkOccName, tvName )
+import SrcLoc ( noSrcLoc )
+import TysWiredIn ( intTy, stringTy, mkListTy, unitTy )
+import PrelNames ( breakpointJumpName )
+import NameEnv ( mkNameEnv )
+#endif
+
import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
keep_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
dfun_n_var <- newIORef 1 ;
-
let {
gbl_env = TcGblEnv {
tcg_mod = mod,
-- OK, here's the business end!
maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
- do { r <- tryM do_this
- ; case r of
- Right res -> return (Just res)
- Left _ -> return Nothing } ;
+ do {
+#if defined(GHCI) && defined(BREAKPOINT)
+ unique <- newUnique ;
+ let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
+ tyvar = mkTyVar var liftedTypeKind;
+ breakpointJumpType = mkGlobalId
+ (VanillaGlobal)
+ (breakpointJumpName)
+ (FunTy intTy
+ (FunTy (mkListTy unitTy)
+ (FunTy stringTy
+ (ForAllTy tyvar
+ (FunTy (TyVarTy tyvar)
+ (TyVarTy tyvar))))))
+ (vanillaIdInfo);
+ new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+ };
+ r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
+#else
+ r <- tryM do_this
+#endif
+ ; case r of
+ Right res -> return (Just res)
+ Left _ -> return Nothing } ;
-- Collect any error messages
msgs <- readIORef errs_var ;
projects / ghc-hetmet.git / commitdiff