summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTamar Christina <tamar@zhox.com>2016-12-19 19:09:18 +0000
committerTamar Christina <tamar@zhox.com>2016-12-19 19:09:18 +0000
commitf1dfce1cb2a823696d6d3a9ea41c2bc73d949f12 (patch)
treeb14692ca8e33e8f925a1fa47542eb3499fc79f0e
parentbb74bc79daf8b91b21a1b68b0a406828d188ed92 (diff)
downloadhaskell-f1dfce1cb2a823696d6d3a9ea41c2bc73d949f12.tar.gz
Revert "Allow use of the external interpreter in stage1."
This reverts commit 52ba9470a7e85d025dc84a6789aa809cdd68b566.
-rw-r--r--compiler/deSugar/Coverage.hs8
-rw-r--r--compiler/ghc.cabal.in21
-rw-r--r--compiler/ghci/ByteCodeGen.hs4
-rw-r--r--compiler/ghci/ByteCodeInstr.hs4
-rw-r--r--compiler/ghci/ByteCodeTypes.hs6
-rw-r--r--compiler/ghci/GHCi.hs27
-rw-r--r--compiler/ghci/Linker.hs10
-rw-r--r--compiler/hsSyn/HsExpr.hs13
-rw-r--r--compiler/main/DriverPipeline.hs4
-rw-r--r--compiler/main/DynFlags.hs29
-rw-r--r--compiler/main/GHC.hs38
-rw-r--r--compiler/main/GhcMake.hs8
-rw-r--r--compiler/main/Hooks.hs14
-rw-r--r--compiler/main/HscMain.hs24
-rw-r--r--compiler/main/HscTypes.hs28
-rw-r--r--compiler/main/InteractiveEval.hs7
-rw-r--r--compiler/main/InteractiveEvalTypes.hs9
-rw-r--r--compiler/rename/RnEnv.hs4
-rw-r--r--compiler/rename/RnSplice.hs22
-rw-r--r--compiler/simplCore/CoreMonad.hs8
-rw-r--r--compiler/specialise/SpecConstr.hs19
-rw-r--r--compiler/typecheck/TcAnnotations.hs19
-rw-r--r--compiler/typecheck/TcRnDriver.hs23
-rw-r--r--compiler/typecheck/TcRnMonad.hs16
-rw-r--r--compiler/typecheck/TcRnTypes.hs8
-rw-r--r--compiler/typecheck/TcSplice.hs20
-rw-r--r--compiler/typecheck/TcSplice.hs-boot4
-rw-r--r--ghc.mk5
-rw-r--r--libraries/ghci/GHCi/BreakArray.hs6
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc125
-rw-r--r--libraries/ghci/GHCi/Message.hs33
-rw-r--r--libraries/ghci/GHCi/Run.hs13
-rw-r--r--libraries/ghci/ghci.cabal.in21
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
diff --git a/ghc.mk b/ghc.mk
index e52c4c4091..a06c4a7fae 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -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.*,