diff options
33 files changed, 218 insertions, 405 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 51bfb1811d..1f6effa6b9 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -7,12 +7,14 @@ 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 @@ -129,9 +131,6 @@ 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) @@ -165,7 +164,6 @@ 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 4875753a1c..99bb463f54 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,6 +64,7 @@ Library transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, + ghci == @ProjectVersionMunged@, hoopl >= 3.10.2 && < 3.11 if os(windows) @@ -73,9 +74,6 @@ 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) @@ -605,16 +603,6 @@ 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 @@ -627,3 +615,10 @@ 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 0e7aea493e..9a5e4141f1 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -66,7 +66,11 @@ 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 f1f6f70e57..43444321de 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -30,7 +30,11 @@ 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 3537a2bff3..ec962c886b 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -34,7 +34,11 @@ 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.hsc index 472251db04..4503034971 100644 --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hsc @@ -46,7 +46,9 @@ module GHCi ) where import GHCi.Message +#ifdef GHCI import GHCi.Run +#endif import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) @@ -71,13 +73,23 @@ 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) #ifdef mingw32_HOST_OS import Foreign.C import GHC.IO.Handle.FD (fdToHandle) +#if !MIN_VERSION_process(1,4,2) +import System.Posix.Internals +import Foreign.Marshal.Array +import Foreign.C.Error +import Foreign.Storable +#endif #else import System.Posix as Posix #endif @@ -148,6 +160,12 @@ 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 @@ -160,8 +178,11 @@ 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] -- @@ -357,7 +378,11 @@ 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 = @@ -512,6 +537,23 @@ runWithPipes createProc prog opts = do return (ph, rh, wh) where mkHandle :: CInt -> IO Handle mkHandle fd = (fdToHandle fd) `onException` (c__close fd) + +#if !MIN_VERSION_process(1,4,2) +-- This #include and the _O_BINARY below are the only reason this is hsc, +-- so we can remove that once we can depend on process 1.4.2 +#include <fcntl.h> + +createPipeFd :: IO (FD, FD) +createPipeFd = do + allocaArray 2 $ \ pfds -> do + throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY) + readfd <- peek pfds + writefd <- peekElemOff pfds 1 + return (readfd, writefd) + +foreign import ccall "io.h _pipe" c__pipe :: + Ptr CInt -> CUInt -> CInt -> IO CInt +#endif #else runWithPipes createProc prog opts = do (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 @@ -603,8 +645,14 @@ 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 7379c46772..6a0483ce1b 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -709,6 +709,16 @@ 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 8cead39c68..d695d8e651 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -48,10 +48,8 @@ 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 {- ************************************************************************ @@ -2047,24 +2045,13 @@ 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 ea0c6eded1..133bdde283 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -2054,11 +2054,7 @@ 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 aee5edce85..6ecf8ca9a9 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -124,9 +124,7 @@ module DynFlags ( -- * Compiler configuration suitable for display to the user compilerInfo, -#ifdef GHCI rtsIsProfiled, -#endif dynamicGhc, #include "GHCConstantsHaskellExports.hs" @@ -3613,12 +3611,6 @@ 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 @@ -4155,7 +4147,6 @@ 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 @@ -4164,10 +4155,6 @@ 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 }) @@ -4200,24 +4187,8 @@ 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 cf066d0ea7..59e42f9c75 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -91,7 +91,6 @@ module GHC ( -- * Interactive evaluation -#ifdef GHCI -- ** Executing statements execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, @@ -103,11 +102,10 @@ module GHC ( parseImportDecl, setContext, getContext, setGHCiMonad, getGHCiMonad, -#endif + -- ** Inspecting the current context getBindings, getInsts, getPrintUnqual, findModule, lookupModule, -#ifdef GHCI isModuleTrusted, moduleTrustReqs, getNamesInScope, getRdrNamesInScope, @@ -123,9 +121,8 @@ module GHC ( -- ** Looking up a Name parseName, -#endif lookupName, -#ifdef GHCI + -- ** Compiling expressions HValue, parseExpr, compileParsedExpr, InteractiveEval.compileExpr, dynCompileExpr, @@ -154,7 +151,6 @@ module GHC ( RunResult(..), runStmt, runStmtWithLocation, resume, -#endif -- * Abstract syntax elements @@ -290,14 +286,12 @@ 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 @@ -469,9 +463,7 @@ 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. @@ -889,10 +881,8 @@ 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 -#ifdef GHCI - ,minf_modBreaks = emptyModBreaks -#endif + minf_safe = safe, + minf_modBreaks = emptyModBreaks }} -- | Desugar a typechecked module. @@ -1080,10 +1070,8 @@ data ModuleInfo = ModuleInfo { minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode -#ifdef GHCI - ,minf_modBreaks :: ModBreaks -#endif + minf_safe :: SafeHaskellMode, + minf_modBreaks :: ModBreaks } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -1106,7 +1094,6 @@ 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 @@ -1125,11 +1112,6 @@ 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 = @@ -1145,9 +1127,7 @@ 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 @@ -1196,10 +1176,8 @@ modInfoIface = minf_iface modInfoSafe :: ModuleInfo -> SafeHaskellMode modInfoSafe = minf_safe -#ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks -#endif isDictonaryId :: Id -> Bool isDictonaryId id @@ -1219,11 +1197,9 @@ 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 -- ----------------------------------------------------------------------------- @@ -1422,7 +1398,6 @@ 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 @@ -1464,7 +1439,6 @@ 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 6b103c9e1b..be6510bcb2 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -31,9 +31,7 @@ module GhcMake( #include "HsVersions.h" -#ifdef GHCI import qualified Linker ( unload ) -#endif import DriverPhases import DriverPipeline @@ -563,13 +561,7 @@ 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 8d706d8fa5..eefdde4b88 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -15,18 +15,14 @@ module Hooks ( Hooks , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook -#ifdef GHCI , hscCompileCoreExprHook -#endif , ghcPrimIfaceHook , runPhaseHook , runMetaHook , linkHook , runRnSpliceHook -#ifdef GHCI , getValueSafelyHook , createIservProcessHook -#endif ) where import DynFlags @@ -42,12 +38,10 @@ 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 @@ -70,18 +64,14 @@ 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 @@ -89,18 +79,14 @@ 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 9a64794b77..7d809126bf 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -59,7 +59,6 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo -#ifdef GHCI , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls @@ -71,7 +70,6 @@ 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' @@ -83,7 +81,6 @@ module HscMain , showModuleIndex ) where -#ifdef GHCI import Id import GHCi.RemoteTypes ( ForeignHValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) @@ -96,7 +93,6 @@ import VarEnv ( emptyTidyEnv ) import Panic import ConLike import Control.Concurrent -#endif import Module import Packages @@ -178,9 +174,7 @@ 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 = [] @@ -190,9 +184,7 @@ newHscEnv dflags = do , hsc_NC = nc_var , hsc_FC = fc_var , hsc_type_env_var = Nothing -#ifdef GHCI , hsc_iserv = iserv_mvar -#endif } -- ----------------------------------------------------------------------------- @@ -262,13 +254,11 @@ 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 @@ -284,7 +274,6 @@ 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 @@ -300,7 +289,6 @@ 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 @@ -1073,7 +1061,6 @@ 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 @@ -1081,9 +1068,6 @@ 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 @@ -1320,7 +1304,6 @@ 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. @@ -1347,9 +1330,6 @@ 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 ------------------------------ @@ -1472,7 +1452,6 @@ 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 @@ -1676,7 +1655,6 @@ hscParseStmtWithLocation source linenumber stmt = hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType -#endif hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = @@ -1713,7 +1691,6 @@ 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 @@ -1742,7 +1719,6 @@ 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 e5f824f2e4..5b3c058d35 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -14,9 +14,7 @@ module HscTypes ( Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), -#ifdef GHCI IServ(..), -#endif -- * Hsc monad Hsc(..), runHsc, runInteractiveHsc, @@ -137,12 +135,10 @@ module HscTypes ( #include "HsVersions.h" -#ifdef GHCI import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes -#endif import UniqFM import HsSyn @@ -202,10 +198,8 @@ import Data.IORef import Data.Time import Exception import System.FilePath -#ifdef GHCI import Control.Concurrent import System.Process ( ProcessHandle ) -#endif -- ----------------------------------------------------------------------------- -- Compilation state @@ -403,11 +397,9 @@ 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] @@ -453,14 +445,12 @@ 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 @@ -1490,10 +1480,8 @@ 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 @@ -1531,9 +1519,7 @@ 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 @@ -2950,25 +2936,11 @@ 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 a421c72baf..3cb1856725 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -10,7 +10,6 @@ -- ----------------------------------------------------------------------------- module InteractiveEval ( -#ifdef GHCI Resume(..), History(..), execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, runDecls, runDeclsWithLocation, @@ -40,17 +39,14 @@ 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.Run +import GHCi.Message import GHCi.RemoteTypes import GhcMonad import HscMain @@ -979,4 +975,3 @@ 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 34ae2ccaa0..cb0121950f 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -9,15 +9,11 @@ -- ----------------------------------------------------------------------------- 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 @@ -29,7 +25,11 @@ 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,4 +91,3 @@ data History historyBreakInfo :: BreakInfo, historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } -#endif diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index f8969a8e13..97718f88d2 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -341,16 +341,12 @@ 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 0c41ed30b6..ccfd00257b 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -5,9 +5,7 @@ module RnSplice ( rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, rnBracket, checkThLocalName -#ifdef GHCI , traceSplice, SpliceInfo(..) -#endif ) where #include "HsVersions.h" @@ -35,7 +33,6 @@ import {-# SOURCE #-} RnExpr ( rnLExpr ) import TcEnv ( checkWellStaged ) import THNames ( liftName ) -#ifdef GHCI import DynFlags import FastString import ErrUtils ( dumpIfSet_dyn_printer ) @@ -57,7 +54,6 @@ import {-# SOURCE #-} TcSplice import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) -#endif import qualified GHC.LanguageExtensions as LangExt @@ -201,23 +197,6 @@ 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 {- ********************************************************* @@ -760,7 +739,6 @@ 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 03c990a83d..ea94d9b20e 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -49,16 +49,12 @@ 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 @@ -94,10 +90,8 @@ import Control.Applicative ( Alternative(..) ) import Prelude hiding ( read ) -#ifdef GHCI import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) import qualified Language.Haskell.TH as TH -#endif {- ************************************************************************ @@ -812,7 +806,6 @@ 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 @@ -823,4 +816,3 @@ 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 60632255d8..2f2087cd2e 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -13,10 +13,8 @@ ToDo [Oct 2013] {-# LANGUAGE CPP #-} module SpecConstr( - specConstrProgram -#ifdef GHCI - , SpecConstrAnnotation(..) -#endif + specConstrProgram, + SpecConstrAnnotation(..) ) where #include "HsVersions.h" @@ -61,12 +59,9 @@ import PrelNames ( specTyConName ) import Module -- See Note [Forcing specialisation] -#ifndef GHCI -type SpecConstrAnnotation = () -#else + import TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) -#endif {- ----------------------------------------------------- @@ -954,11 +949,6 @@ 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 @@ -969,7 +959,6 @@ 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 @@ -984,9 +973,7 @@ 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 33eb83b401..7b3cc65dd1 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -10,14 +10,10 @@ 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 @@ -26,21 +22,7 @@ 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 @@ -63,7 +45,6 @@ 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 0aa2924966..ad49ca0601 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -14,7 +14,6 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE ScopedTypeVariables #-} module TcRnDriver ( -#ifdef GHCI tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, tcRnImportDecls, tcRnLookupRdrName, @@ -22,7 +21,6 @@ module TcRnDriver ( tcRnDeclsi, isGHCiMonad, runTcInteractive, -- Used by GHC API clients (Trac #8878) -#endif tcRnLookupName, tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, @@ -42,7 +40,6 @@ module TcRnDriver ( missingBootThing, ) where -#ifdef GHCI import {-# SOURCE #-} TcSplice ( finishTH ) import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import IfaceEnv( externaliseName ) @@ -54,6 +51,7 @@ import RnExpr import MkId import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) +#ifdef GHCI import DynamicLoading ( loadPlugins ) import Plugins ( tcPlugin ) #endif @@ -392,14 +390,12 @@ 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 @@ -436,12 +432,9 @@ 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) @@ -467,7 +460,6 @@ 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) @@ -482,7 +474,6 @@ 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 -- @@ -515,7 +506,6 @@ 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 $ @@ -526,12 +516,6 @@ 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 @@ -545,7 +529,6 @@ tc_rn_src_decls ds tc_rn_src_decls (spliced_decls ++ rest_ds) } } -#endif /* GHCI */ } {- @@ -1758,7 +1741,6 @@ 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. -- @@ -2260,7 +2242,6 @@ externaliseAndTidyId this_mod id = do { name' <- externaliseName this_mod (idName id) ; return (globaliseAndTidyId (setIdName id name')) } -#endif /* GHCi */ {- ************************************************************************ @@ -2270,7 +2251,6 @@ 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 @@ -2294,7 +2274,6 @@ 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 a77541cf3a..8c117f0936 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -177,10 +177,8 @@ 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 {- ************************************************************************ @@ -218,13 +216,11 @@ 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 ; @@ -234,13 +230,11 @@ 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 = @@ -1084,13 +1078,8 @@ 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 @@ -1611,7 +1600,6 @@ 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 () @@ -1621,10 +1609,6 @@ 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 ef94fb6310..6d902b32e0 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -181,7 +181,6 @@ 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 ) @@ -189,7 +188,6 @@ 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 @@ -587,7 +585,6 @@ data TcGblEnv tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile -#ifdef GHCI tcg_th_topdecls :: TcRef [LHsDecl RdrName], -- ^ Top-level declarations from addTopDecls @@ -603,7 +600,6 @@ 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 @@ -869,7 +865,6 @@ 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]. @@ -884,9 +879,6 @@ 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 1e35eec144..9942107c45 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -17,21 +17,15 @@ 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" @@ -51,7 +45,6 @@ import TcEnv import Control.Monad -#ifdef GHCI import GHCi.Message import GHCi.RemoteTypes import GHCi @@ -130,7 +123,6 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) import GHC.Exts ( unsafeCoerce# ) -#endif {- ************************************************************************ @@ -238,16 +230,6 @@ 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) {- @@ -2015,5 +1997,3 @@ 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 14e479a04e..db75436d4d 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -8,12 +8,10 @@ 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 @@ -29,7 +27,6 @@ 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) @@ -41,4 +38,3 @@ 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 +PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot hoopl transformers template-haskell ghci ifeq "$(Windows_Host)" "NO" PACKAGES_STAGE0 += terminfo endif @@ -589,6 +589,9 @@ 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 311bbd6c5e..bece43bdb9 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -19,14 +19,17 @@ 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 @@ -112,3 +115,6 @@ 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 e4deb3b6ff..8a9dfc2fa0 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -6,9 +6,11 @@ -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( mkConInfoTable - , peekItbl, StgInfoTable(..) + ( peekItbl, StgInfoTable(..) , conInfoPtr +#ifdef GHCI + , mkConInfoTable +#endif ) where #if !defined(TABLES_NEXT_TO_CODE) @@ -20,6 +22,66 @@ 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 @@ -52,8 +114,6 @@ 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) @@ -280,9 +340,6 @@ 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 @@ -302,30 +359,11 @@ 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 @@ -364,26 +402,6 @@ 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 @@ -408,13 +426,6 @@ 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 @@ -443,10 +454,4 @@ rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 cONSTR :: Int -- Defined in ClosureTypes.h cONSTR = (#const CONSTR) - -ghciTablesNextToCode :: Bool -#ifdef TABLES_NEXT_TO_CODE -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif +#endif /* GHCI */ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 4d0417e2da..fe4e95eb9e 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} +{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, + CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -14,6 +15,7 @@ module GHCi.Message , QResult(..) , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , SerializableException(..) + , toSerializableException, fromSerializableException , THResult(..), THResultType(..) , ResumeContext(..) , QState(..) @@ -40,7 +42,11 @@ 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 @@ -352,7 +358,28 @@ data SerializableException | EOtherException String deriving (Generic, Show) -instance Binary ExitCode +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 SerializableException data THResult a diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index fefbdc32c1..858b247f65 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -10,7 +10,6 @@ -- module GHCi.Run ( run, redirectInterrupts - , toSerializableException, fromSerializableException ) where import GHCi.CreateBCO @@ -36,7 +35,6 @@ 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 @@ -223,17 +221,6 @@ 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 9b622e1107..87b2c4e2fd 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -17,6 +17,11 @@ 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 @@ -41,24 +46,28 @@ 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.10.*, + base >= 4.8 && < 4.11, binary == 0.8.*, bytestring == 0.10.*, containers == 0.5.*, |