Commit 31751cca authored by David Himmelstrup's avatar David Himmelstrup

GHC.Base.breakpoint isn't vaporware anymore.

-fignore-breakpoints can be used to ignore breakpoints.
parent 1494f895
......@@ -406,7 +406,7 @@ endif
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.
......
......@@ -30,7 +30,9 @@ module MkId (
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"
......
......@@ -7,6 +7,14 @@
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 )
......@@ -204,6 +212,36 @@ dsExpr expr@(HsLam a_Match)
= 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 ->
......
......@@ -13,6 +13,22 @@ module InteractiveUI (
#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(..),
......@@ -176,9 +192,67 @@ helpText =
" (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
......@@ -756,6 +830,9 @@ afterLoad ok session = do
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])
......
......@@ -16,9 +16,9 @@ necessary.
{-# 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"
......@@ -54,7 +54,7 @@ import Data.List ( partition, nub )
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
......@@ -137,6 +137,18 @@ extendLinkEnv new_bindings
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
......
......@@ -164,6 +164,7 @@ data DynFlag
| Opt_OmitInterfacePragmas
| Opt_DoLambdaEtaExpansion
| Opt_IgnoreAsserts
| Opt_IgnoreBreakpoints
| Opt_DoEtaReduction
| Opt_CaseMerge
| Opt_UnboxStrictFields
......@@ -995,6 +996,7 @@ fFlags = [
( "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 ),
......
......@@ -186,7 +186,8 @@ basicKnownKeyNames
-- Others
otherwiseIdName,
plusIntegerName, timesIntegerName,
eqStringName, assertName, assertErrorName, runSTRepName,
eqStringName, assertName, breakpointName, assertErrorName,
runSTRepName,
printName, fstName, sndName,
-- MonadFix
......@@ -470,14 +471,20 @@ returnMName = methName monadClassName FSLIT("return") returnMClassOpKey
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
......@@ -902,6 +909,9 @@ thenIOIdKey = mkPreludeMiscIdUnique 59
lazyIdKey = mkPreludeMiscIdUnique 60
assertErrorIdKey = mkPreludeMiscIdUnique 61
breakpointIdKey = mkPreludeMiscIdUnique 62
breakpointJumpIdKey = mkPreludeMiscIdUnique 63
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 80
lengthPIdKey = mkPreludeMiscIdUnique 81
......
......@@ -33,6 +33,13 @@ import BasicTypes ( FixityDirection(..) )
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 )
......@@ -87,18 +94,31 @@ rnLExpr = wrapLocFstM rnExpr
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 ->
......@@ -913,6 +933,32 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
-- The ones needed after the RecStmt
\end{code}
%************************************************************************
%* *
\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}
......
......@@ -66,7 +66,7 @@ import Var ( Var )
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 )
......@@ -1253,6 +1253,7 @@ loadUnqualIfaces ictxt
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")
......
......@@ -10,6 +10,17 @@ module TcRnMonad(
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(..),
......@@ -81,7 +92,6 @@ initTc hsc_env hsc_src mod do_this
keep_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
dfun_n_var <- newIORef 1 ;
let {
gbl_env = TcGblEnv {
tcg_mod = mod,
......@@ -124,10 +134,30 @@ initTc hsc_env hsc_src mod do_this
-- 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 ;
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment