From 31751ccacc24ebe5d15a0af84b10dc612d455440 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Thu, 6 Apr 2006 17:57:53 +0000 Subject: [PATCH] GHC.Base.breakpoint isn't vaporware anymore. -fignore-breakpoints can be used to ignore breakpoints. --- ghc/compiler/Makefile | 2 +- ghc/compiler/basicTypes/MkId.lhs | 4 +- ghc/compiler/deSugar/DsExpr.lhs | 38 ++++++++++++++++ ghc/compiler/ghci/InteractiveUI.hs | 79 ++++++++++++++++++++++++++++++++- ghc/compiler/ghci/Linker.lhs | 18 ++++++-- ghc/compiler/main/DynFlags.hs | 2 + ghc/compiler/prelude/PrelNames.lhs | 28 ++++++++---- ghc/compiler/rename/RnExpr.lhs | 70 ++++++++++++++++++++++++----- ghc/compiler/typecheck/TcRnDriver.lhs | 3 +- ghc/compiler/typecheck/TcRnMonad.lhs | 40 ++++++++++++++--- 10 files changed, 251 insertions(+), 33 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index c1819f2..b17df47 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -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. diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 9d93a67..84b3546 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -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" diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 406d793..e8e9e7b 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -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 -> diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 0424f6a..9e9c262 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -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 = "", + 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]) diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 44efac8..3a5ecf8 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -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 diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs index 8f6ac1f..78acb98 100644 --- a/ghc/compiler/main/DynFlags.hs +++ b/ghc/compiler/main/DynFlags.hs @@ -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 ), diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 23b5dfe..d656fbf 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 557e1e4..716a85a 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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 -> @@ -915,6 +935,32 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ %* * +\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} %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 4ca79d9..5f4b487 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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") diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 91ede2d..ff1979b 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -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 ; -- 1.7.10.4