diff options
author | Tamar Christina <tamar@zhox.com> | 2016-12-19 19:09:18 +0000 |
---|---|---|
committer | Tamar Christina <tamar@zhox.com> | 2016-12-19 19:09:18 +0000 |
commit | f1dfce1cb2a823696d6d3a9ea41c2bc73d949f12 (patch) | |
tree | b14692ca8e33e8f925a1fa47542eb3499fc79f0e | |
parent | bb74bc79daf8b91b21a1b68b0a406828d188ed92 (diff) | |
download | haskell-f1dfce1cb2a823696d6d3a9ea41c2bc73d949f12.tar.gz |
Revert "Allow use of the external interpreter in stage1."
This reverts commit 52ba9470a7e85d025dc84a6789aa809cdd68b566.
33 files changed, 405 insertions, 195 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 1f6effa6b9..51bfb1811d 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -7,14 +7,12 @@ module Coverage (addTicksToBinds, hpcInitCode) where +#ifdef GHCI import qualified GHCi import GHCi.RemoteTypes import Data.Array import ByteCodeTypes -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS #endif import Type import HsSyn @@ -131,6 +129,9 @@ guessSourceFile binds orig_file = mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks +#ifndef GHCI +mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks +#else mkModBreaks hsc_env mod count entries | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do breakArray <- GHCi.newBreakArray hsc_env (length entries) @@ -164,6 +165,7 @@ mkCCSArray hsc_env modul count entries = do mk_one (srcspan, decl_path, _, _) = (name, src) where name = concat (intersperse "." decl_path) src = showSDoc dflags (ppr srcspan) +#endif writeMixEntries diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 99bb463f54..4875753a1c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,7 +64,6 @@ Library transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, - ghci == @ProjectVersionMunged@, hoopl >= 3.10.2 && < 3.11 if os(windows) @@ -74,6 +73,9 @@ Library Build-Depends: terminfo == 0.4.* Build-Depends: unix == 2.7.* + if flag(ghci) + Build-Depends: ghci == @ProjectVersionMunged@ + GHC-Options: -Wall -fno-warn-name-shadowing if flag(ghci) @@ -603,6 +605,16 @@ Library Dwarf Dwarf.Types Dwarf.Constants + + if !flag(stage1) + -- ghc:Serialized moved to ghc-boot:GHC.Serialized. So for + -- compatibility with GHC 7.10 and earlier, we reexport it + -- under the old name. + reexported-modules: + ghc-boot:GHC.Serialized as Serialized + + if flag(ghci) + Exposed-Modules: Convert ByteCodeTypes ByteCodeAsm @@ -615,10 +627,3 @@ Library RtClosureInspect DebuggerUtils GHCi - - if !flag(stage1) - -- ghc:Serialized moved to ghc-boot:GHC.Serialized. So for - -- compatibility with GHC 7.10 and earlier, we reexport it - -- under the old name. - reexported-modules: - ghc-boot:GHC.Serialized as Serialized diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 9a5e4141f1..0e7aea493e 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -66,11 +66,7 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified FiniteMap as Map import Data.Ord -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 43444321de..f1f6f70e57 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -30,11 +30,7 @@ import PrimOp import SMRep import Data.Word -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS (CostCentre) -#else -import GHC.Stack (CostCentre) -#endif -- ---------------------------------------------------------------------------- -- Bytecode instructions diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index ec962c886b..3537a2bff3 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -34,11 +34,7 @@ import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif -- ----------------------------------------------------------------------------- -- Compiled Byte Code diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs index a5667c361e..472251db04 100644 --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hs @@ -46,9 +46,7 @@ module GHCi ) where import GHCi.Message -#ifdef GHCI import GHCi.Run -#endif import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) @@ -73,11 +71,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.IORef import Foreign hiding (void) -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS (CostCentre,CostCentreStack) -#else -import GHC.Stack (CostCentre,CostCentreStack) -#endif import System.Exit import Data.Maybe import GHC.IO.Handle.Types (Handle) @@ -154,12 +148,6 @@ Other Notes on Remote GHCi * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} -#ifndef GHCI -needExtInt :: IO a -needExtInt = throwIO - (InstallationError "this operation requires -fexternal-interpreter") -#endif - -- | Run a command in the interpreter's context. With -- @-fexternal-interpreter@, the command is serialized and sent to an -- external iserv process, and the response is deserialized (hence the @@ -172,11 +160,8 @@ iservCmd hsc_env@HscEnv{..} msg uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] iservCall iserv msg | otherwise = -- Just run it directly -#ifdef GHCI run msg -#else - needExtInt -#endif + -- Note [uninterruptibleMask_ and iservCmd] -- @@ -372,11 +357,7 @@ lookupSymbol hsc_env@HscEnv{..} str writeIORef iservLookupSymbolCache $! addToUFM cache str p return (Just p) | otherwise = -#ifdef GHCI fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -#else - needExtInt -#endif lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) lookupClosure hsc_env str = @@ -622,14 +603,8 @@ wormholeRef dflags r | gopt Opt_ExternalInterpreter dflags = throwIO (InstallationError "this operation requires -fno-external-interpreter") -#ifdef GHCI | otherwise = localRef r -#else - | otherwise - = throwIO (InstallationError - "can't wormhole a value in a stage1 compiler") -#endif -- ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 6a0483ce1b..7379c46772 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -709,16 +709,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) adjust_ul _ l@(BCOs {}) = return l -#if !MIN_VERSION_filepath(1,4,1) - stripExtension :: String -> FilePath -> Maybe FilePath - stripExtension [] path = Just path - stripExtension ext@(x:_) path = stripSuffix dotExt path - where dotExt = if isExtSeparator x then ext else '.':ext - - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif - {- ********************************************************************** diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index d695d8e651..8cead39c68 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -48,8 +48,10 @@ import Data.Data hiding (Fixity(..)) import qualified Data.Data as Data (Fixity(..)) import Data.Maybe (isNothing) +#ifdef GHCI import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) +#endif {- ************************************************************************ @@ -2045,13 +2047,24 @@ isTypedSplice _ = False -- Quasi-quotes are untyped splices -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how -- this is used. -- +#ifdef GHCI newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] +#else +data ThModFinalizers = ThModFinalizers +#endif -- A Data instance which ignores the argument of 'ThModFinalizers'. +#ifdef GHCI instance Data ThModFinalizers where gunfold _ z _ = z $ ThModFinalizers [] toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +#else +instance Data ThModFinalizers where + gunfold _ z _ = z ThModFinalizers + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +#endif -- | Haskell Spliced Thing -- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 133bdde283..ea0c6eded1 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -2054,7 +2054,11 @@ doCpp dflags raw input_fn output_fn = do backend_defs <- getBackendDefs dflags +#ifdef GHCI let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] +#else + let th_defs = [ "-D__GLASGOW_HASKELL_TH__=0" ] +#endif -- Default CPP defines in Haskell source ghcVersionH <- getGhcVersionPathName dflags let hsSourceCppOpts = [ "-include", ghcVersionH ] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6ecf8ca9a9..aee5edce85 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -124,7 +124,9 @@ module DynFlags ( -- * Compiler configuration suitable for display to the user compilerInfo, +#ifdef GHCI rtsIsProfiled, +#endif dynamicGhc, #include "GHCConstantsHaskellExports.hs" @@ -3611,6 +3613,12 @@ supportedExtensions :: [String] supportedExtensions = concatMap toFlagSpecNamePair xFlags where toFlagSpecNamePair flg +#ifndef GHCI + -- make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell" when it's known to be unsupported. See also + -- GHC #11102 for rationale + | flagSpecFlag flg == LangExt.TemplateHaskell = [noName] +#endif | otherwise = [name, noName] where noName = "No" ++ name @@ -4147,6 +4155,7 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt rtsIsProfiled :: Bool rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 +#ifdef GHCI -- Consult the RTS to find whether GHC itself has been built with -- dynamic linking. This can't be statically known at compile-time, -- because we build both the static and dynamic versions together with @@ -4155,6 +4164,10 @@ foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt dynamicGhc :: Bool dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 +#else +dynamicGhc :: Bool +dynamicGhc = False +#endif setWarnSafe :: Bool -> DynP () setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) @@ -4187,8 +4200,24 @@ setIncoherentInsts True = do upd (\d -> d { incoherentOnLoc = l }) checkTemplateHaskellOk :: TurnOnFlag -> DynP () +#ifdef GHCI checkTemplateHaskellOk _turn_on = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) +#else +-- In stage 1, Template Haskell is simply illegal, except with -M +-- We don't bleat with -M because there's no problem with TH there, +-- and in fact GHC's build system does ghc -M of the DPH libraries +-- with a stage1 compiler +checkTemplateHaskellOk turn_on + | turn_on = do dfs <- liftEwM getCmdLineState + case ghcMode dfs of + MkDepend -> return () + _ -> addErr msg + | otherwise = return () + where + msg = "Template Haskell requires GHC with interpreter support\n " ++ + "Perhaps you are using a stage-1 compiler?" +#endif {- ********************************************************************** %* * diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 59e42f9c75..cf066d0ea7 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -91,6 +91,7 @@ module GHC ( -- * Interactive evaluation +#ifdef GHCI -- ** Executing statements execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, @@ -102,10 +103,11 @@ module GHC ( parseImportDecl, setContext, getContext, setGHCiMonad, getGHCiMonad, - +#endif -- ** Inspecting the current context getBindings, getInsts, getPrintUnqual, findModule, lookupModule, +#ifdef GHCI isModuleTrusted, moduleTrustReqs, getNamesInScope, getRdrNamesInScope, @@ -121,8 +123,9 @@ module GHC ( -- ** Looking up a Name parseName, +#endif lookupName, - +#ifdef GHCI -- ** Compiling expressions HValue, parseExpr, compileParsedExpr, InteractiveEval.compileExpr, dynCompileExpr, @@ -151,6 +154,7 @@ module GHC ( RunResult(..), runStmt, runStmtWithLocation, resume, +#endif -- * Abstract syntax elements @@ -286,12 +290,14 @@ module GHC ( #include "HsVersions.h" +#ifdef GHCI import ByteCodeTypes import InteractiveEval import InteractiveEvalTypes import TcRnDriver ( runTcInteractive ) import GHCi import GHCi.RemoteTypes +#endif import PprTyThing ( pprFamInst ) import HscMain @@ -463,7 +469,9 @@ withCleanupSession ghc = ghc `gfinally` cleanup liftIO $ do cleanTempFiles dflags cleanTempDirs dflags +#ifdef GHCI stopIServ hsc_env -- shut down the IServ +#endif -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. @@ -881,8 +889,10 @@ typecheckModule pmod = do minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_instances = fixSafeInstances safe $ md_insts details, minf_iface = Nothing, - minf_safe = safe, - minf_modBreaks = emptyModBreaks + minf_safe = safe +#ifdef GHCI + ,minf_modBreaks = emptyModBreaks +#endif }} -- | Desugar a typechecked module. @@ -1070,8 +1080,10 @@ data ModuleInfo = ModuleInfo { minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks + minf_safe :: SafeHaskellMode +#ifdef GHCI + ,minf_modBreaks :: ModBreaks +#endif } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -1094,6 +1106,7 @@ getModuleInfo mdl = withSession $ \hsc_env -> do -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +#ifdef GHCI getPackageModuleInfo hsc_env mdl = do eps <- hscEPS hsc_env iface <- hscGetModuleInterface hsc_env mdl @@ -1112,6 +1125,11 @@ getPackageModuleInfo hsc_env mdl minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) +#else +-- bogusly different for non-GHCI (ToDo) +getPackageModuleInfo _hsc_env _mdl = do + return Nothing +#endif getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = @@ -1127,7 +1145,9 @@ getHomeModuleInfo hsc_env mdl = minf_instances = md_insts details, minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface +#ifdef GHCI ,minf_modBreaks = getModBreaks hmi +#endif })) -- | The list of top-level entities defined in a module @@ -1176,8 +1196,10 @@ modInfoIface = minf_iface modInfoSafe :: ModuleInfo -> SafeHaskellMode modInfoSafe = minf_safe +#ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks +#endif isDictonaryId :: Id -> Bool isDictonaryId id @@ -1197,9 +1219,11 @@ findGlobalAnns deserialize target = withSession $ \hsc_env -> do ann_env <- liftIO $ prepareAnnotations hsc_env Nothing return (findAnns deserialize ann_env target) +#ifdef GHCI -- | get the GlobalRdrEnv for a session getGRE :: GhcMonad m => m GlobalRdrEnv getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +#endif -- ----------------------------------------------------------------------------- @@ -1398,6 +1422,7 @@ lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing +#ifdef GHCI -- | Check that a module is safe to import (according to Safe Haskell). -- -- We return True to indicate the import is safe and False otherwise @@ -1439,6 +1464,7 @@ obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term obtainTermFromId bound force id = withSession $ \hsc_env -> liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id +#endif -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any -- entity known to GHC, including 'Name's defined using 'runStmt'. diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index be6510bcb2..6b103c9e1b 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -31,7 +31,9 @@ module GhcMake( #include "HsVersions.h" +#ifdef GHCI import qualified Linker ( unload ) +#endif import DriverPhases import DriverPipeline @@ -561,7 +563,13 @@ findPartiallyCompletedCycles modsDone theGraph unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI LinkInMemory -> Linker.unload hsc_env stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif _other -> return () -- ----------------------------------------------------------------------------- diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index eefdde4b88..8d706d8fa5 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -15,14 +15,18 @@ module Hooks ( Hooks , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook +#ifdef GHCI , hscCompileCoreExprHook +#endif , ghcPrimIfaceHook , runPhaseHook , runMetaHook , linkHook , runRnSpliceHook +#ifdef GHCI , getValueSafelyHook , createIservProcessHook +#endif ) where import DynFlags @@ -38,10 +42,12 @@ import TcRnTypes import Bag import RdrName import CoreSyn +#ifdef GHCI import GHCi.RemoteTypes import SrcLoc import Type import System.Process +#endif import BasicTypes import Data.Maybe @@ -64,14 +70,18 @@ emptyHooks = Hooks , tcForeignImportsHook = Nothing , tcForeignExportsHook = Nothing , hscFrontendHook = Nothing +#ifdef GHCI , hscCompileCoreExprHook = Nothing +#endif , ghcPrimIfaceHook = Nothing , runPhaseHook = Nothing , runMetaHook = Nothing , linkHook = Nothing , runRnSpliceHook = Nothing +#ifdef GHCI , getValueSafelyHook = Nothing , createIservProcessHook = Nothing +#endif } data Hooks = Hooks @@ -79,14 +89,18 @@ data Hooks = Hooks , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) +#ifdef GHCI , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) +#endif , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) , runMetaHook :: Maybe (MetaHook TcM) , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) , runRnSpliceHook :: Maybe (HsSplice Name -> RnM (HsSplice Name)) +#ifdef GHCI , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) +#endif } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 7d809126bf..9a64794b77 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -59,6 +59,7 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo +#ifdef GHCI , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls @@ -70,6 +71,7 @@ module HscMain , hscCompileCoreExpr -- * Low-level exports for hooks , hscCompileCoreExpr' +#endif -- We want to make sure that we export enough to be able to redefine -- hscFileFrontEnd in client code , hscParse', hscSimplify', hscDesugar', tcRnModule' @@ -81,6 +83,7 @@ module HscMain , showModuleIndex ) where +#ifdef GHCI import Id import GHCi.RemoteTypes ( ForeignHValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) @@ -93,6 +96,7 @@ import VarEnv ( emptyTidyEnv ) import Panic import ConLike import Control.Concurrent +#endif import Module import Packages @@ -174,7 +178,9 @@ newHscEnv dflags = do us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv +#ifdef GHCI iserv_mvar <- newMVar Nothing +#endif return HscEnv { hsc_dflags = dflags , hsc_targets = [] , hsc_mod_graph = [] @@ -184,7 +190,9 @@ newHscEnv dflags = do , hsc_NC = nc_var , hsc_FC = fc_var , hsc_type_env_var = Nothing +#ifdef GHCI , hsc_iserv = iserv_mvar +#endif } -- ----------------------------------------------------------------------------- @@ -254,11 +262,13 @@ ioMsgMaybe' ioA = do -- ----------------------------------------------------------------------------- -- | Lookup things in the compiler's environment +#ifdef GHCI hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } +#endif hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do @@ -274,6 +284,7 @@ hscTcRnGetInfo hsc_env0 name do { hsc_env <- getHscEnv ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } +#ifdef GHCI hscIsGHCiMonad :: HscEnv -> String -> IO Name hscIsGHCiMonad hsc_env name = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name @@ -289,6 +300,7 @@ hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +#endif -- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax @@ -1061,6 +1073,7 @@ hscCheckSafe' dflags m l = do let pkgIfaceT = eps_PIT hsc_eps homePkgT = hsc_HPT hsc_env iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m +#ifdef GHCI -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk @@ -1068,6 +1081,9 @@ hscCheckSafe' dflags m l = do Just _ -> return iface Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) return iface' +#else + return iface +#endif isHomePkg :: Module -> Bool @@ -1304,6 +1320,7 @@ hscInteractive :: HscEnv -> CgGuts -> ModSummary -> IO (Maybe FilePath, CompiledByteCode) +#ifdef GHCI hscInteractive hsc_env cgguts mod_summary = do let dflags = hsc_dflags hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1330,6 +1347,9 @@ hscInteractive hsc_env cgguts mod_summary = do (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs return (istub_c_exists, comp_bc) +#else +hscInteractive _ _ = panic "GHC not compiled with interpreter" +#endif ------------------------------ @@ -1452,6 +1472,7 @@ A naked expression returns a singleton Name [it]. The stmt is lifted into the IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes -} +#ifdef GHCI -- | Compile a stmt all the way to an HValue, but don't run it -- -- We return Nothing to indicate an empty statement (or comment only), not a @@ -1655,6 +1676,7 @@ hscParseStmtWithLocation source linenumber stmt = hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType +#endif hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = @@ -1691,6 +1713,7 @@ hscParseThingWithLocation source linenumber parser str %* * %********************************************************************* -} +#ifdef GHCI hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr hsc_env = lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env @@ -1719,6 +1742,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr ; hval <- linkExpr hsc_env srcspan bcos ; return hval } +#endif {- ********************************************************************** diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 5b3c058d35..e5f824f2e4 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -14,7 +14,9 @@ module HscTypes ( Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), +#ifdef GHCI IServ(..), +#endif -- * Hsc monad Hsc(..), runHsc, runInteractiveHsc, @@ -135,10 +137,12 @@ module HscTypes ( #include "HsVersions.h" +#ifdef GHCI import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes +#endif import UniqFM import HsSyn @@ -198,8 +202,10 @@ import Data.IORef import Data.Time import Exception import System.FilePath +#ifdef GHCI import Control.Concurrent import System.Process ( ProcessHandle ) +#endif -- ----------------------------------------------------------------------------- -- Compilation state @@ -397,9 +403,11 @@ data HscEnv -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] +#ifdef GHCI , hsc_iserv :: MVar (Maybe IServ) -- ^ interactive server process. Created the first -- time it is needed. +#endif } -- Note [hsc_type_env_var hack] @@ -445,12 +453,14 @@ data HscEnv -- another day. +#ifdef GHCI data IServ = IServ { iservPipe :: Pipe , iservProcess :: ProcessHandle , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) , iservPendingFrees :: [HValueRef] } +#endif -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState @@ -1480,8 +1490,10 @@ data InteractiveContext ic_default :: Maybe [Type], -- ^ The current default types, set by a 'default' declaration +#ifdef GHCI ic_resume :: [Resume], -- ^ The stack of breakpoint contexts +#endif ic_monad :: Name, -- ^ The monad that GHCi is executing in @@ -1519,7 +1531,9 @@ emptyInteractiveContext dflags ic_monad = ioTyConName, -- IO monad by default ic_int_print = printName, -- System.IO.print by default ic_default = Nothing, +#ifdef GHCI ic_resume = [], +#endif ic_cwd = Nothing } icInteractiveModule :: InteractiveContext -> Module @@ -2936,11 +2950,25 @@ data Unlinked | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) | BCOs CompiledByteCode -- ^ A byte-code object, lives only in memory +#ifndef GHCI +data CompiledByteCode = CompiledByteCodeUndefined +_unusedCompiledByteCode :: CompiledByteCode +_unusedCompiledByteCode = CompiledByteCodeUndefined + +data ModBreaks = ModBreaksUndefined +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaksUndefined +#endif + instance Outputable Unlinked where ppr (DotO path) = text "DotO" <+> text path ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path +#ifdef GHCI ppr (BCOs bcos) = text "BCOs" <+> ppr bcos +#else + ppr (BCOs _) = text "No byte code" +#endif -- | Is this an actual file on disk we can link in somehow? isObject :: Unlinked -> Bool diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 3cb1856725..a421c72baf 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -10,6 +10,7 @@ -- ----------------------------------------------------------------------------- module InteractiveEval ( +#ifdef GHCI Resume(..), History(..), execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, runDecls, runDeclsWithLocation, @@ -39,14 +40,17 @@ module InteractiveEval ( Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, -- * Depcreated API (remove in GHC 7.14) RunResult(..), runStmt, runStmtWithLocation, +#endif ) where +#ifdef GHCI + #include "HsVersions.h" import InteractiveEvalTypes import GHCi -import GHCi.Message +import GHCi.Run import GHCi.RemoteTypes import GhcMonad import HscMain @@ -975,3 +979,4 @@ reconstructType hsc_env bound id = do mkRuntimeUnkTyVar :: Name -> Kind -> TyVar mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk +#endif /* GHCI */ diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index cb0121950f..34ae2ccaa0 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -9,11 +9,15 @@ -- ----------------------------------------------------------------------------- module InteractiveEvalTypes ( +#ifdef GHCI Resume(..), History(..), ExecResult(..), SingleStep(..), isStep, ExecOptions(..), BreakInfo(..) +#endif ) where +#ifdef GHCI + import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) import Id @@ -25,11 +29,7 @@ import SrcLoc import Exception import Data.Word -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif data ExecOptions = ExecOptions @@ -91,3 +91,4 @@ data History historyBreakInfo :: BreakInfo, historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } +#endif diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 97718f88d2..f8969a8e13 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -341,12 +341,16 @@ lookupExactOcc_either name ; if name `inLocalRdrEnvScope` lcl_env then return (Right name) else +#ifdef GHCI do { th_topnames_var <- fmap tcg_th_topnames getGblEnv ; th_topnames <- readTcRef th_topnames_var ; if name `elemNameSet` th_topnames then return (Right name) else return (Left exact_nm_err) } +#else /* !GHCI */ + return (Left exact_nm_err) +#endif /* !GHCI */ } gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] } diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index ccfd00257b..0c41ed30b6 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -5,7 +5,9 @@ module RnSplice ( rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, rnBracket, checkThLocalName +#ifdef GHCI , traceSplice, SpliceInfo(..) +#endif ) where #include "HsVersions.h" @@ -33,6 +35,7 @@ import {-# SOURCE #-} RnExpr ( rnLExpr ) import TcEnv ( checkWellStaged ) import THNames ( liftName ) +#ifdef GHCI import DynFlags import FastString import ErrUtils ( dumpIfSet_dyn_printer ) @@ -54,6 +57,7 @@ import {-# SOURCE #-} TcSplice import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) +#endif import qualified GHC.LanguageExtensions as LangExt @@ -197,6 +201,23 @@ quotedNameStageErr br = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br , text "must be used at the same stage at which is is bound" ] +#ifndef GHCI +rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls e = failTH e "Template Haskell top splice" + +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) +rnSpliceType e _ = failTH e "Template Haskell type splice" + +rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr e = failTH e "Template Haskell splice" + +rnSplicePat :: HsSplice RdrName -> RnM (Either (Pat RdrName) (Pat Name), FreeVars) +rnSplicePat e = failTH e "Template Haskell pattern splice" + +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl e = failTH e "Template Haskell declaration splice" +#else {- ********************************************************* @@ -739,6 +760,7 @@ illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" -- = vcat [ hang (text "In the splice:") -- 2 (char '$' <> pprParendExpr expr) -- , text "To see what the splice expanded to, use -ddump-splices" ] +#endif checkThLocalName :: Name -> RnM () checkThLocalName name diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index ea94d9b20e..03c990a83d 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -49,12 +49,16 @@ module CoreMonad ( debugTraceMsg, debugTraceMsgS, dumpIfSet_dyn, +#ifdef GHCI -- * Getting 'Name's thNameToGhcName +#endif ) where +#ifdef GHCI import Name( Name ) import TcRnMonad ( initTcForLookup ) +#endif import CoreSyn import HscTypes import Module @@ -90,8 +94,10 @@ import Control.Applicative ( Alternative(..) ) import Prelude hiding ( read ) +#ifdef GHCI import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) import qualified Language.Haskell.TH as TH +#endif {- ************************************************************************ @@ -806,6 +812,7 @@ instance MonadThings CoreM where ************************************************************************ -} +#ifdef GHCI -- | Attempt to convert a Template Haskell name to one that GHC can -- understand. Original TH names such as those you get when you use -- the @'foo@ syntax will be translated to their equivalent GHC name @@ -816,3 +823,4 @@ thNameToGhcName :: TH.Name -> CoreM (Maybe Name) thNameToGhcName th_name = do hsc_env <- getHscEnv liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name) +#endif diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 2f2087cd2e..60632255d8 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -13,8 +13,10 @@ ToDo [Oct 2013] {-# LANGUAGE CPP #-} module SpecConstr( - specConstrProgram, - SpecConstrAnnotation(..) + specConstrProgram +#ifdef GHCI + , SpecConstrAnnotation(..) +#endif ) where #include "HsVersions.h" @@ -59,9 +61,12 @@ import PrelNames ( specTyConName ) import Module -- See Note [Forcing specialisation] - +#ifndef GHCI +type SpecConstrAnnotation = () +#else import TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) +#endif {- ----------------------------------------------------- @@ -949,6 +954,11 @@ ignoreType :: ScEnv -> Type -> Bool ignoreDataCon :: ScEnv -> DataCon -> Bool forceSpecBndr :: ScEnv -> Var -> Bool +#ifndef GHCI +ignoreType _ _ = False +ignoreDataCon _ _ = False +#else /* GHCI */ + ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) ignoreType env ty @@ -959,6 +969,7 @@ ignoreType env ty ignoreTyCon :: ScEnv -> TyCon -> Bool ignoreTyCon env tycon = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr +#endif /* GHCI */ forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var @@ -973,7 +984,9 @@ forceSpecArgTy env ty | Just (tycon, tys) <- splitTyConApp_maybe ty , tycon /= funTyCon = tyConName tycon == specTyConName +#ifdef GHCI || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr +#endif || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 7b3cc65dd1..33eb83b401 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -10,10 +10,14 @@ module TcAnnotations ( tcAnnotations, annCtxt ) where +#ifdef GHCI import {-# SOURCE #-} TcSplice ( runAnnotation ) import Module import DynFlags import Control.Monad ( when ) +#else +import DynFlags ( WarnReason(NoReason) ) +#endif import HsSyn import Annotations @@ -22,7 +26,21 @@ import TcRnMonad import SrcLoc import Outputable +#ifndef GHCI + +tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +-- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268 +tcAnnotations [] = return [] +tcAnnotations anns@(L loc _ : _) + = do { setSrcSpan loc $ addWarnTc NoReason $ + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler or doesn't support GHCi") + ; return [] } + +#else + tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +-- GHCI exists, typecheck the annotations tcAnnotations anns = mapM tcAnnotation anns tcAnnotation :: LAnnDecl Name -> TcM Annotation @@ -45,6 +63,7 @@ annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod +#endif annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc annCtxt ann diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index ad49ca0601..0aa2924966 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -14,6 +14,7 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE ScopedTypeVariables #-} module TcRnDriver ( +#ifdef GHCI tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, tcRnImportDecls, tcRnLookupRdrName, @@ -21,6 +22,7 @@ module TcRnDriver ( tcRnDeclsi, isGHCiMonad, runTcInteractive, -- Used by GHC API clients (Trac #8878) +#endif tcRnLookupName, tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, @@ -40,6 +42,7 @@ module TcRnDriver ( missingBootThing, ) where +#ifdef GHCI import {-# SOURCE #-} TcSplice ( finishTH ) import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import IfaceEnv( externaliseName ) @@ -51,7 +54,6 @@ import RnExpr import MkId import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) -#ifdef GHCI import DynamicLoading ( loadPlugins ) import Plugins ( tcPlugin ) #endif @@ -390,12 +392,14 @@ tcRnSrcDecls explicit_mod_hdr decls ; new_ev_binds <- {-# SCC "simplifyTop" #-} simplifyTop lie +#ifdef GHCI -- Finalizers must run after constraints are simplified, or some types -- might not be complete when using reify (see #12777). ; (tcg_env, tcl_env) <- run_th_modfinalizers ; setEnvs (tcg_env, tcl_env) $ do { ; finishTH +#endif /* GHCI */ ; traceTc "Tc9" empty @@ -432,9 +436,12 @@ tcRnSrcDecls explicit_mod_hdr decls ; setGlobalTypeEnv tcg_env' final_type_env +#ifdef GHCI } +#endif /* GHCI */ } } +#ifdef GHCI -- | Runs TH finalizers and renames and typechecks the top-level declarations -- that they could introduce. run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) @@ -460,6 +467,7 @@ run_th_modfinalizers = do ) -- addTopDecls can add declarations which add new finalizers. run_th_modfinalizers +#endif /* GHCI */ tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -474,6 +482,7 @@ tc_rn_src_decls ds ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group -- rnTopSrcDecls fails if there are any errors +#ifdef GHCI -- Get TH-generated top-level declarations and make sure they don't -- contain any splices since we don't handle that at the moment -- @@ -506,6 +515,7 @@ tc_rn_src_decls ds ; return (tcg_env, appendGroups rn_decls th_rn_decls) } +#endif /* GHCI */ -- Type check all declarations ; (tcg_env, tcl_env) <- setGblEnv tcg_env $ @@ -516,6 +526,12 @@ tc_rn_src_decls ds case group_tail of { Nothing -> return (tcg_env, tcl_env) +#ifndef GHCI + -- There shouldn't be a splice + ; Just (SpliceDecl {}, _) -> + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") + } +#else -- If there's a splice, we must carry on ; Just (SpliceDecl (L loc splice) _, rest_ds) -> do { recordTopLevelSpliceLoc loc @@ -529,6 +545,7 @@ tc_rn_src_decls ds tc_rn_src_decls (spliced_decls ++ rest_ds) } } +#endif /* GHCI */ } {- @@ -1741,6 +1758,7 @@ lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). We don't bother with the tcl_th_bndrs environment either. -} +#ifdef GHCI -- | The returned [Id] is the list of new Ids bound by this statement. It can -- be used to extend the InteractiveContext via extendInteractiveContext. -- @@ -2242,6 +2260,7 @@ externaliseAndTidyId this_mod id = do { name' <- externaliseName this_mod (idName id) ; return (globaliseAndTidyId (setIdName id name')) } +#endif /* GHCi */ {- ************************************************************************ @@ -2251,6 +2270,7 @@ externaliseAndTidyId this_mod id ************************************************************************ -} +#ifdef GHCI -- | ASSUMES that the module is either in the 'HomePackageTable' or is -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface @@ -2274,6 +2294,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) ; let names = concat names_s ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } +#endif tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 8c117f0936..a77541cf3a 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -177,8 +177,10 @@ import Control.Monad import Data.Set ( Set ) import qualified Data.Set as Set +#ifdef GHCI import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) import qualified Data.Map as Map +#endif {- ************************************************************************ @@ -216,11 +218,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this dependent_files_var <- newIORef [] ; static_wc_var <- newIORef emptyWC ; +#ifdef GHCI th_topdecls_var <- newIORef [] ; th_topnames_var <- newIORef emptyNameSet ; th_modfinalizers_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; +#endif /* GHCI */ let { dflags = hsc_dflags hsc_env ; @@ -230,11 +234,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this | otherwise = Nothing ; gbl_env = TcGblEnv { +#ifdef GHCI tcg_th_topdecls = th_topdecls_var, tcg_th_topnames = th_topnames_var, tcg_th_modfinalizers = th_modfinalizers_var, tcg_th_state = th_state_var, tcg_th_remote_state = th_remote_state_var, +#endif /* GHCI */ tcg_mod = mod, tcg_semantic_mod = @@ -1078,8 +1084,13 @@ failIfErrsM :: TcRn () -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) +#ifdef GHCI checkTH :: a -> String -> TcRn () checkTH _ _ = return () -- OK +#else +checkTH :: Outputable a => a -> String -> TcRn () +checkTH e what = failTH e what -- Raise an error in a stage-1 compiler +#endif failTH :: Outputable a => a -> String -> TcRn x failTH e what -- Raise an error in a stage-1 compiler @@ -1600,6 +1611,7 @@ getStageAndBindLevel name setStage :: ThStage -> TcM a -> TcRn a setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) +#ifdef GHCI -- | Adds the given modFinalizers to the global environment and set them to use -- the current local environment. addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () @@ -1609,6 +1621,10 @@ addModFinalizersWithLclEnv mod_finalizers updTcRef th_modfinalizers_var $ \fins -> setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers) : fins +#else +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv ThModFinalizers = return () +#endif {- ************************************************************************ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 6d902b32e0..ef94fb6310 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -181,6 +181,7 @@ import qualified Control.Monad.Fail as MonadFail #endif import Data.Set ( Set ) +#ifdef GHCI import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) import Data.Typeable ( TypeRep ) @@ -188,6 +189,7 @@ import GHCi.Message import GHCi.RemoteTypes import qualified Language.Haskell.TH as TH +#endif -- | A 'NameShape' is a substitution on 'Name's that can be used -- to refine the identities of a hole while we are renaming interfaces @@ -585,6 +587,7 @@ data TcGblEnv tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile +#ifdef GHCI tcg_th_topdecls :: TcRef [LHsDecl RdrName], -- ^ Top-level declarations from addTopDecls @@ -600,6 +603,7 @@ data TcGblEnv tcg_th_state :: TcRef (Map TypeRep Dynamic), tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), -- ^ Template Haskell state +#endif /* GHCI */ tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings @@ -865,6 +869,7 @@ data ThStage -- See Note [Template Haskell state diagram] in TcSplice -- the result replaces the splice -- Binding level = 0 +#ifdef GHCI | RunSplice (TcRef [ForeignRef (TH.Q ())]) -- Set when running a splice, i.e. NOT when renaming or typechecking the -- Haskell code for the splice. See Note [RunSplice ThLevel]. @@ -879,6 +884,9 @@ data ThStage -- See Note [Template Haskell state diagram] in TcSplice -- inserts them in the list of finalizers in the global environment. -- -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". +#else + | RunSplice () +#endif | Comp -- Ordinary Haskell code -- Binding level = 1 diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 9942107c45..1e35eec144 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -17,15 +17,21 @@ TcSplice: Template Haskell splices {-# OPTIONS_GHC -fno-warn-orphans #-} module TcSplice( + -- These functions are defined in stage1 and stage2 + -- The raise civilised errors in stage1 tcSpliceExpr, tcTypedBracket, tcUntypedBracket, -- runQuasiQuoteExpr, runQuasiQuotePat, -- runQuasiQuoteDecl, runQuasiQuoteType, runAnnotation, +#ifdef GHCI + -- These ones are defined only in stage2, and are + -- called only in stage2 (ie GHCI is on) runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, finishTH +#endif ) where #include "HsVersions.h" @@ -45,6 +51,7 @@ import TcEnv import Control.Monad +#ifdef GHCI import GHCi.Message import GHCi.RemoteTypes import GHCi @@ -123,6 +130,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) import GHC.Exts ( unsafeCoerce# ) +#endif {- ************************************************************************ @@ -230,6 +238,16 @@ quotationCtxtDoc br_body 2 (ppr br_body) +#ifndef GHCI +tcSpliceExpr e _ = failTH e "Template Haskell splice" + +-- runQuasiQuoteExpr q = failTH q "quasiquote" +-- runQuasiQuotePat q = failTH q "pattern quasiquote" +-- runQuasiQuoteType q = failTH q "type quasiquote" +-- runQuasiQuoteDecl q = failTH q "declaration quasiquote" +runAnnotation _ q = failTH q "annotation" + +#else -- The whole of the rest of the file is the else-branch (ie stage2 only) {- @@ -1997,3 +2015,5 @@ such fields defined in the module (see the test case overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to the TH AST to make it able to represent duplicate record fields. -} + +#endif /* GHCI */ diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index db75436d4d..14e479a04e 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -8,10 +8,12 @@ import TcRnTypes( TcM, TcId ) import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) +#ifdef GHCI import HsSyn ( LHsType, LPat, LHsDecl, ThModFinalizers ) import RdrName ( RdrName ) import TcRnTypes ( SpliceType ) import qualified Language.Haskell.TH as TH +#endif tcSpliceExpr :: HsSplice Name -> ExpRhoType @@ -27,6 +29,7 @@ tcTypedBracket :: HsBracket Name runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +#ifdef GHCI tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId) runMetaE :: LHsExpr TcId -> TcM (LHsExpr RdrName) @@ -38,3 +41,4 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () +#endif @@ -430,7 +430,7 @@ else # CLEANING # programs such as GHC and ghc-pkg, that we do not assume the stage0 # compiler already has installed (or up-to-date enough). -PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot hoopl transformers template-haskell ghci +PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot hoopl transformers template-haskell ifeq "$(Windows_Host)" "NO" PACKAGES_STAGE0 += terminfo endif @@ -589,9 +589,6 @@ ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-inst endif BOOT_LIBS = $(foreach lib,$(PACKAGES_STAGE0),$(libraries/$(lib)_dist-boot_v_LIB)) -# Only build internal interpreter support for the stage2 ghci lib -libraries/ghci_dist-install_CONFIGURE_OPTS += --flags=ghci - # ---------------------------------------- # Special magic for the ghc-prim package diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index bece43bdb9..311bbd6c5e 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -19,17 +19,14 @@ module GHCi.BreakArray ( BreakArray -#ifdef GHCI (BA) -- constructor is exported only for ByteCodeGen , newBreakArray , getBreak , setBreakOn , setBreakOff , showBreakArray -#endif ) where -#ifdef GHCI import Control.Monad import Data.Word import GHC.Word @@ -115,6 +112,3 @@ readBA# array i = IO $ \s -> readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i -#else -data BreakArray -#endif diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index 8a9dfc2fa0..e4deb3b6ff 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -6,11 +6,9 @@ -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( peekItbl, StgInfoTable(..) + ( mkConInfoTable + , peekItbl, StgInfoTable(..) , conInfoPtr -#ifdef GHCI - , mkConInfoTable -#endif ) where #if !defined(TABLES_NEXT_TO_CODE) @@ -22,66 +20,6 @@ import GHC.Ptr import GHC.Exts import System.IO.Unsafe -type ItblCodes = Either [Word8] [Word32] - --- Get definitions for the structs, constants & config etc. -#include "Rts.h" - --- Ultra-minimalist version specially for constructors -#if SIZEOF_VOID_P == 8 -type HalfWord = Word32 -#elif SIZEOF_VOID_P == 4 -type HalfWord = Word16 -#else -#error Uknown SIZEOF_VOID_P -#endif - -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) - -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: HalfWord, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } - -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do -#if defined(TABLES_NEXT_TO_CODE) - let entry' = Nothing -#else - entry' <- Just <$> (#peek StgInfoTable, entry) a0 -#endif - ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 - nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 - tipe' <- (#peek StgInfoTable, type) a0 - srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = tipe' - , srtlen = srtlen' - , code = Nothing - } - --- | Convert a pointer to an StgConInfo into an info pointer that can be --- used in the header of a closure. -conInfoPtr :: Ptr () -> Ptr () -conInfoPtr ptr - | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) - | otherwise = ptr - -ghciTablesNextToCode :: Bool -#ifdef TABLES_NEXT_TO_CODE -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif - -#ifdef GHCI /* To end */ mkConInfoTable :: Int -- ptr words -> Int -- non-ptr words @@ -114,6 +52,8 @@ mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = -- ----------------------------------------------------------------------------- -- Building machine code fragments for a constructor's entry code +type ItblCodes = Either [Word8] [Word32] + funPtrToInt :: FunPtr a -> Int funPtrToInt (FunPtr a) = I## (addr2Int## a) @@ -340,6 +280,9 @@ byte7 w = fromIntegral (w `shiftR` 56) -- ----------------------------------------------------------------------------- -- read & write intfo tables +-- Get definitions for the structs, constants & config etc. +#include "Rts.h" + -- entry point for direct returns for created constr itbls foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr @@ -359,11 +302,30 @@ interpConstrEntry = [ error "pointer tag 0" , stg_interp_constr6_entry , stg_interp_constr7_entry ] +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord = Word32 +#elif SIZEOF_VOID_P == 4 +type HalfWord = Word16 +#else +#error Uknown SIZEOF_VOID_P +#endif + data StgConInfoTable = StgConInfoTable { conDesc :: Ptr Word8, infoTable :: StgInfoTable } +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: HalfWord, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + } pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable @@ -402,6 +364,26 @@ pokeItbl a0 itbl = do Just (Right xs) -> pokeArray code_offset xs #endif +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if defined(TABLES_NEXT_TO_CODE) + let entry' = Nothing +#else + entry' <- Just <$> (#peek StgInfoTable, entry) a0 +#endif + ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 + nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 + tipe' <- (#peek StgInfoTable, type) a0 + srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = tipe' + , srtlen = srtlen' + , code = Nothing + } + newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do @@ -426,6 +408,13 @@ foreign import ccall unsafe "allocateExec" foreign import ccall unsafe "flushExec" _flushExec :: CUInt -> Ptr a -> IO () +-- | Convert a pointer to an StgConInfo into an info pointer that can be +-- used in the header of a closure. +conInfoPtr :: Ptr () -> Ptr () +conInfoPtr ptr + | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) + | otherwise = ptr + -- ----------------------------------------------------------------------------- -- Constants and config @@ -454,4 +443,10 @@ rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 cONSTR :: Int -- Defined in ClosureTypes.h cONSTR = (#const CONSTR) -#endif /* GHCI */ + +ghciTablesNextToCode :: Bool +#ifdef TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index fe4e95eb9e..4d0417e2da 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, - CPP #-} +{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -15,7 +14,6 @@ module GHCi.Message , QResult(..) , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , SerializableException(..) - , toSerializableException, fromSerializableException , THResult(..), THResultType(..) , ResumeContext(..) , QState(..) @@ -42,11 +40,7 @@ import Data.Dynamic import Data.IORef import Data.Map (Map) import GHC.Generics -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import System.Exit @@ -358,28 +352,7 @@ data SerializableException | EOtherException String deriving (Generic, Show) -toSerializableException :: SomeException -> SerializableException -toSerializableException ex - | Just UserInterrupt <- fromException ex = EUserInterrupt - | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) - | otherwise = EOtherException (show (ex :: SomeException)) - -fromSerializableException :: SerializableException -> SomeException -fromSerializableException EUserInterrupt = toException UserInterrupt -fromSerializableException (EExitCode c) = toException c -fromSerializableException (EOtherException str) = toException (ErrorCall str) - --- NB: Replace this with a derived instance once we depend on GHC 8.0 --- as the minimum -instance Binary ExitCode where - put ExitSuccess = putWord8 0 - put (ExitFailure ec) = putWord8 1 `mappend` put ec - get = do - w <- getWord8 - case w of - 0 -> pure ExitSuccess - _ -> ExitFailure <$> get - +instance Binary ExitCode instance Binary SerializableException data THResult a diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index 858b247f65..fefbdc32c1 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -10,6 +10,7 @@ -- module GHCi.Run ( run, redirectInterrupts + , toSerializableException, fromSerializableException ) where import GHCi.CreateBCO @@ -35,6 +36,7 @@ import Foreign import Foreign.C import GHC.Conc.Sync import GHC.IO hiding ( bracket ) +import System.Exit import System.Mem.Weak ( deRefWeak ) import Unsafe.Coerce @@ -221,6 +223,17 @@ tryEval io = do Left ex -> return (EvalException (toSerializableException ex)) Right a -> return (EvalSuccess a) +toSerializableException :: SomeException -> SerializableException +toSerializableException ex + | Just UserInterrupt <- fromException ex = EUserInterrupt + | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) + | otherwise = EOtherException (show (ex :: SomeException)) + +fromSerializableException :: SerializableException -> SomeException +fromSerializableException EUserInterrupt = toException UserInterrupt +fromSerializableException (EExitCode c) = toException c +fromSerializableException (EOtherException str) = toException (ErrorCall str) + -- This function sets up the interpreter for catching breakpoints, and -- resets everything when the computation has stopped running. This -- is a not-very-good way to ensure that only the interactive diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index 87b2c4e2fd..9b622e1107 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -17,11 +17,6 @@ cabal-version: >=1.10 build-type: Simple extra-source-files: changelog.md -Flag ghci - Description: Build GHCi support. - Default: False - Manual: True - source-repository head type: git location: http://git.haskell.org/ghc.git @@ -46,28 +41,24 @@ library TupleSections UnboxedTuples - if flag(ghci) - CPP-Options: -DGHCI - exposed-modules: - GHCi.Run - GHCi.CreateBCO - GHCi.ObjLink - GHCi.Signals - GHCi.TH - exposed-modules: GHCi.BreakArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes + GHCi.ObjLink + GHCi.CreateBCO GHCi.FFI GHCi.InfoTable + GHCi.Run + GHCi.Signals + GHCi.TH GHCi.TH.Binary SizedSeq Build-Depends: array == 0.5.*, - base >= 4.8 && < 4.11, + base == 4.10.*, binary == 0.8.*, bytestring == 0.10.*, containers == 0.5.*, |