summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/Annotations.hs14
-rw-r--r--compiler/main/DriverPipeline.hs9
-rw-r--r--compiler/main/DynFlags.hs77
-rw-r--r--compiler/main/DynamicLoading.hs5
-rw-r--r--compiler/main/GHC.hs51
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/main/GhcPlugins.hs4
-rw-r--r--compiler/main/Hooks.hs33
-rw-r--r--compiler/main/HscMain.hs55
-rw-r--r--compiler/main/HscTypes.hs29
-rw-r--r--compiler/main/InteractiveEval.hs332
-rw-r--r--compiler/main/InteractiveEvalTypes.hs26
-rw-r--r--compiler/main/SysTools.hs10
13 files changed, 294 insertions, 353 deletions
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs
index a81ae80614..052b0615e7 100644
--- a/compiler/main/Annotations.hs
+++ b/compiler/main/Annotations.hs
@@ -12,7 +12,8 @@ module Annotations (
-- * AnnEnv for collecting and querying Annotations
AnnEnv,
- mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns,
+ mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,
+ findAnns, findAnnsByTypeRep,
deserializeAnns
) where
@@ -20,7 +21,7 @@ import Binary
import Module ( Module )
import Name
import Outputable
-import Serialized
+import GHC.Serialized
import UniqFM
import Unique
@@ -115,10 +116,17 @@ findAnns deserialize (MkAnnEnv ann_env)
= (mapMaybe (fromSerialized deserialize))
. (lookupWithDefaultUFM ann_env [])
+-- | Find the annotations attached to the given target as 'Typeable'
+-- values of your choice. If no deserializer is specified,
+-- only transient annotations will be returned.
+findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
+findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep
+ = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target
+ , tyrep' == tyrep ]
+
-- | Deserialize all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
deserializeAnns deserialize (MkAnnEnv ann_env)
= mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
-
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 4692b21520..c37cc6536e 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -237,7 +237,7 @@ compileOne' m_tc_result mHscMessage
needsLinker = needsTH || needsQQ
isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0)
-
+ internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
src_flavour = ms_hsc_src summary
mod_name = ms_mod_name summary
@@ -245,9 +245,10 @@ compileOne' m_tc_result mHscMessage
object_filename = ml_obj_file location
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
- -- the linker can correctly load the object files.
-
- dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
+ -- the linker can correctly load the object files. This isn't necessary
+ -- when using -fexternal-interpreter.
+ dflags1 = if needsLinker && dynamicGhc && internalInterpreter &&
+ not isDynWay && not isProfWay
then gopt_set dflags0 Opt_BuildDynamicToo
else dflags0
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e443926d0f..03eb39846c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -72,8 +72,8 @@ module DynFlags (
versionedAppDir,
extraGccViaCFlags, systemPackageConfig,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
- pgm_windres, pgm_libtool, pgm_lo, pgm_lc,
- opt_L, opt_P, opt_F, opt_c, opt_a, opt_l,
+ pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i,
+ opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
opt_windres, opt_lo, opt_lc,
@@ -428,6 +428,7 @@ data GeneralFlag
| Opt_RelativeDynlibPaths
| Opt_Hpc
| Opt_FlatCache
+ | Opt_ExternalInterpreter
-- PreInlining is on by default. The option is there just to see how
-- bad things get if you turn it off!
@@ -884,6 +885,7 @@ data Settings = Settings {
sPgm_libtool :: String,
sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser
sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler
+ sPgm_i :: String,
-- options for particular phases
sOpt_L :: [String],
sOpt_P :: [String],
@@ -894,6 +896,7 @@ data Settings = Settings {
sOpt_windres :: [String],
sOpt_lo :: [String], -- LLVM: llvm optimiser
sOpt_lc :: [String], -- LLVM: llc static compiler
+ sOpt_i :: [String], -- iserv options
sPlatformConstants :: PlatformConstants
}
@@ -944,6 +947,8 @@ pgm_lo :: DynFlags -> (String,[Option])
pgm_lo dflags = sPgm_lo (settings dflags)
pgm_lc :: DynFlags -> (String,[Option])
pgm_lc dflags = sPgm_lc (settings dflags)
+pgm_i :: DynFlags -> String
+pgm_i dflags = sPgm_i (settings dflags)
opt_L :: DynFlags -> [String]
opt_L dflags = sOpt_L (settings dflags)
opt_P :: DynFlags -> [String]
@@ -965,6 +970,8 @@ opt_lo :: DynFlags -> [String]
opt_lo dflags = sOpt_lo (settings dflags)
opt_lc :: DynFlags -> [String]
opt_lc dflags = sOpt_lc (settings dflags)
+opt_i :: DynFlags -> [String]
+opt_i dflags = sOpt_i (settings dflags)
-- | The directory for this version of ghc in the user's app directory
-- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
@@ -2188,6 +2195,8 @@ dynamic_flags = [
(hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])})))
, defFlag "pgmlc"
(hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])})))
+ , defFlag "pgmi"
+ (hasArg (\f -> alterSettings (\s -> s { sPgm_i = f})))
, defFlag "pgmL"
(hasArg (\f -> alterSettings (\s -> s { sPgm_L = f})))
, defFlag "pgmP"
@@ -2214,6 +2223,8 @@ dynamic_flags = [
(hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s})))
, defFlag "optlc"
(hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s})))
+ , defFlag "opti"
+ (hasArg (\f -> alterSettings (\s -> s { sOpt_i = f : sOpt_i s})))
, defFlag "optL"
(hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s})))
, defFlag "optP"
@@ -2904,6 +2915,7 @@ fFlags = [
flagSpec "error-spans" Opt_ErrorSpans,
flagSpec "excess-precision" Opt_ExcessPrecision,
flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings,
+ flagSpec "external-interpreter" Opt_ExternalInterpreter,
flagSpec "flat-cache" Opt_FlatCache,
flagSpec "float-in" Opt_FloatIn,
flagSpec "force-recomp" Opt_ForceRecomp,
@@ -4158,6 +4170,33 @@ tARGET_MAX_WORD dflags
8 -> toInteger (maxBound :: Word64)
w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w)
+
+{- -----------------------------------------------------------------------------
+Note [DynFlags consistency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a number of number of DynFlags configurations which either
+do not make sense or lead to unimplemented or buggy codepaths in the
+compiler. makeDynFlagsConsistent is responsible for verifying the validity
+of a set of DynFlags, fixing any issues, and reporting them back to the
+caller.
+
+GHCi and -O
+---------------
+
+When using optimization, the compiler can introduce several things
+(such as unboxed tuples) into the intermediate code, which GHCi later
+chokes on since the bytecode interpreter can't handle this (and while
+this is arguably a bug these aren't handled, there are no plans to fix
+it.)
+
+While the driver pipeline always checks for this particular erroneous
+combination when parsing flags, we also need to check when we update
+the flags; this is because API clients may parse flags but update the
+DynFlags afterwords, before finally running code inside a session (see
+T10052 and #10052).
+-}
+
-- | Resolve any internal inconsistencies in a set of 'DynFlags'.
-- Returns the consistent 'DynFlags' as well as a list of warnings
-- to report to the user.
@@ -4171,6 +4210,13 @@ makeDynFlagsConsistent dflags
= let dflags' = gopt_unset dflags Opt_BuildDynamicToo
warn = "-dynamic-too is not supported on Windows"
in loop dflags' warn
+ -- Disalbe -fexternal-interpreter on Windows. This is a temporary measure;
+ -- all that is missing is the implementation of the interprocess communication
+ -- which uses pipes on POSIX systems. (#11100)
+ | os == OSMinGW32 && gopt Opt_ExternalInterpreter dflags
+ = let dflags' = gopt_unset dflags Opt_ExternalInterpreter
+ warn = "-fexternal-interpreter is currently not supported on Windows"
+ in loop dflags' warn
| hscTarget dflags == HscC &&
not (platformUnregisterised (targetPlatform dflags))
= if cGhcWithNativeCodeGen == "YES"
@@ -4211,6 +4257,7 @@ makeDynFlagsConsistent dflags
= loop (updOptLevel 0 dflags) err
| LinkInMemory <- ghcLink dflags
+ , not (gopt Opt_ExternalInterpreter dflags)
, rtsIsProfiled
, isObjectTarget (hscTarget dflags)
, WayProf `notElem` ways dflags
@@ -4226,32 +4273,6 @@ makeDynFlagsConsistent dflags
arch = platformArch platform
os = platformOS platform
-{-
-Note [DynFlags consistency]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-There are a number of number of DynFlags configurations which either
-do not make sense or lead to unimplemented or buggy codepaths in the
-compiler. makeDynFlagsConsistent is responsible for verifying the validity
-of a set of DynFlags, fixing any issues, and reporting them back to the
-caller.
-
-GHCi and -O
----------------
-
-When using optimization, the compiler can introduce several things
-(such as unboxed tuples) into the intermediate code, which GHCi later
-chokes on since the bytecode interpreter can't handle this (and while
-this is arguably a bug these aren't handled, there are no plans to fix
-it.)
-
-While the driver pipeline always checks for this particular erroneous
-combination when parsing flags, we also need to check when we update
-the flags; this is because API clients may parse flags but update the
-DynFlags afterwords, before finally running code inside a session (see
-T10052 and #10052).
-
--}
--------------------------------------------------------------------------
-- Do not use unsafeGlobalDynFlags!
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 0d4b84252f..bbaf12978b 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -24,6 +24,7 @@ module DynamicLoading (
#ifdef GHCI
import Linker ( linkModule, getHValue )
+import GHCi ( wormhole )
import SrcLoc ( noSrcSpan )
import Finder ( findImportedModule, cannotFindModule )
import TcRnMonad ( initTcInteractive, initIfaceTcRn )
@@ -38,7 +39,7 @@ import Plugins ( Plugin, FrontendPlugin, CommandLineOption )
import PrelNames ( pluginTyConName, frontendPluginTyConName )
import HscTypes
-import BasicTypes ( HValue )
+import GHCi.RemoteTypes ( HValue )
import Type ( Type, eqType, mkTyConTy, pprTyThingCategory )
import TyCon ( TyCon )
import Name ( Name, nameModule_maybe )
@@ -170,7 +171,7 @@ getHValueSafely hsc_env val_name expected_type = do
return ()
Nothing -> return ()
-- Find the value that we just linked in and cast it given that we have proved it's type
- hval <- getHValue hsc_env val_name
+ hval <- getHValue hsc_env val_name >>= wormhole dflags
return (Just hval)
else return Nothing
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 74860a1c03..4bf9a5845f 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -127,6 +127,8 @@ module GHC (
-- ** Compiling expressions
HValue, parseExpr, compileParsedExpr,
InteractiveEval.compileExpr, dynCompileExpr,
+ ForeignHValue,
+ compileExprRemote, compileParsedExprRemote,
-- ** Other
runTcInteractive, -- Desired by some clients (Trac #8878)
@@ -134,7 +136,7 @@ module GHC (
-- ** The debugger
SingleStep(..),
- Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+ Resume(resumeStmt, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
@@ -287,10 +289,12 @@ module GHC (
#include "HsVersions.h"
#ifdef GHCI
-import ByteCodeInstr
+import ByteCodeTypes
import BreakArray
import InteractiveEval
import TcRnDriver ( runTcInteractive )
+import GHCi
+import GHCi.RemoteTypes
#endif
import PprTyThing ( pprFamInst )
@@ -405,22 +409,12 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
) $
inner
--- | Install a default cleanup handler to remove temporary files deposited by
--- a GHC run. This is separate from 'defaultErrorHandler', because you might
--- want to override the error handling, but still get the ordinary cleanup
--- behaviour.
-defaultCleanupHandler :: (ExceptionMonad m) =>
- DynFlags -> m a -> m a
-defaultCleanupHandler dflags inner =
- -- make sure we clean up after ourselves
- inner `gfinally`
- (liftIO $ do
- cleanTempFiles dflags
- cleanTempDirs dflags
- )
- -- exceptions will be blocked while we clean the temporary files,
- -- so there shouldn't be any difficulty if we receive further
- -- signals.
+-- | This function is no longer necessary, cleanup is now done by
+-- runGhc/runGhcT.
+{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
+defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
+defaultCleanupHandler _ m = m
+ where _warning_suppression = m `gonException` undefined
-- %************************************************************************
@@ -446,7 +440,8 @@ runGhc mb_top_dir ghc = do
let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
- ghc
+ withCleanupSession ghc
+
-- XXX: unregister interrupt handlers here?
-- | Run function for 'GhcT' monad transformer.
@@ -469,7 +464,23 @@ runGhcT mb_top_dir ghct = do
let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
- ghct
+ withCleanupSession ghct
+
+withCleanupSession :: GhcMonad m => m a -> m a
+withCleanupSession ghc = ghc `gfinally` cleanup
+ where
+ cleanup = do
+ hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ 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.
-- | Initialise a GHC session.
--
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index f0dc3005f1..41d4f1c592 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -532,7 +532,7 @@ 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_dflags hsc_env) stable_linkables
+ LinkInMemory -> Linker.unload hsc_env stable_linkables
#else
LinkInMemory -> panic "unload: no interpreter"
-- urgh. avoid warnings:
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
index c60b41ec50..2aef9b3510 100644
--- a/compiler/main/GhcPlugins.hs
+++ b/compiler/main/GhcPlugins.hs
@@ -18,7 +18,7 @@ module GhcPlugins(
module TysWiredIn, module HscTypes, module BasicTypes,
module VarSet, module VarEnv, module NameSet, module NameEnv,
module UniqSet, module UniqFM, module FiniteMap,
- module Util, module Serialized, module SrcLoc, module Outputable,
+ module Util, module GHC.Serialized, module SrcLoc, module Outputable,
module UniqSupply, module Unique, module FastString
) where
@@ -75,7 +75,7 @@ import FiniteMap
-- Common utilities
import Util
-import Serialized
+import GHC.Serialized
import SrcLoc
import Outputable
import UniqSupply
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index f75214b4f4..0b75bc599d 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -5,6 +5,7 @@
-- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES
-- stuff in compiler/ghc.mk makes DynFlags link to too much stuff
+{-# LANGUAGE CPP #-}
module Hooks ( Hooks
, emptyHooks
, lookupHook
@@ -14,13 +15,17 @@ module Hooks ( Hooks
, tcForeignImportsHook
, tcForeignExportsHook
, hscFrontendHook
+#ifdef GHCI
, hscCompileCoreExprHook
+#endif
, ghcPrimIfaceHook
, runPhaseHook
, runMetaHook
, linkHook
, runRnSpliceHook
+#ifdef GHCI
, getValueSafelyHook
+#endif
) where
import DynFlags
@@ -36,6 +41,9 @@ import TcRnTypes
import Bag
import RdrName
import CoreSyn
+#ifdef GHCI
+import GHCi.RemoteTypes
+#endif
import BasicTypes
import Type
import SrcLoc
@@ -55,21 +63,40 @@ import Data.Maybe
-- uses the default built-in behaviour
emptyHooks :: Hooks
-emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing
- Nothing Nothing Nothing Nothing Nothing Nothing
+emptyHooks = Hooks
+ { dsForeignsHook = Nothing
+ , 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
+#endif
+ }
data Hooks = Hooks
{ dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
, 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)
- , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
+#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))
+#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 0b60596123..558341aebc 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -90,7 +90,7 @@ module HscMain
#ifdef GHCI
import Id
-import BasicTypes ( HValue )
+import GHCi.RemoteTypes ( ForeignHValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
@@ -101,8 +101,6 @@ import VarEnv ( emptyTidyEnv )
import THNames ( templateHaskellNames )
import Panic
import ConLike
-
-import GHC.Exts
#endif
import Module
@@ -162,6 +160,7 @@ import Stream (Stream)
import Util
import Data.List
+import Control.Concurrent
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
@@ -183,15 +182,20 @@ newHscEnv dflags = do
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us allKnownKeyNames)
fc_var <- newIORef emptyModuleEnv
- return HscEnv { hsc_dflags = dflags,
- hsc_targets = [],
- hsc_mod_graph = [],
- hsc_IC = emptyInteractiveContext dflags,
- hsc_HPT = emptyHomePackageTable,
- hsc_EPS = eps_var,
- hsc_NC = nc_var,
- hsc_FC = fc_var,
- hsc_type_env_var = Nothing }
+ iserv_mvar <- newMVar Nothing
+ return HscEnv { hsc_dflags = dflags
+ , hsc_targets = []
+ , hsc_mod_graph = []
+ , hsc_IC = emptyInteractiveContext dflags
+ , hsc_HPT = emptyHomePackageTable
+ , hsc_EPS = eps_var
+ , hsc_NC = nc_var
+ , hsc_FC = fc_var
+ , hsc_type_env_var = Nothing
+#ifdef GHCI
+ , hsc_iserv = iserv_mvar
+#endif
+ }
allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
@@ -1303,7 +1307,7 @@ hscInteractive hsc_env cgguts mod_summary = do
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm hsc_env location core_binds data_tycons
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
+ comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
------------------ Create f-x-dynamic C-side stuff ---
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
@@ -1434,7 +1438,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
-- | Compile a stmt all the way to an HValue, but don't run it
@@ -1445,7 +1449,9 @@ hscStmtWithLocation :: HscEnv
-> String -- ^ The statement
-> String -- ^ The source
-> Int -- ^ Starting line
- -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+ -> IO ( Maybe ([Id]
+ , ForeignHValue {- IO [HValue] -}
+ , FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
@@ -1458,7 +1464,9 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
hscParsedStmt :: HscEnv
-> GhciLStmt RdrName -- ^ The parsed statement
- -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+ -> IO ( Maybe ([Id]
+ , ForeignHValue {- IO [HValue] -}
+ , FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
-- Rename and typecheck it
(ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
@@ -1474,9 +1482,8 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
-- Whereas the linker already knows to ignore 'interactive'
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
- let hvals_io = unsafeCoerce# hval :: IO [HValue]
- return $ Just (ids, hvals_io, fix_env)
+ return $ Just (ids, hval, fix_env)
-- | Compile a decls
hscDecls :: HscEnv
@@ -1518,8 +1525,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
{- Tidy -}
(tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
- let dflags = hsc_dflags hsc_env
- !CgGuts{ cg_module = this_mod,
+ let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_modBreaks = mod_breaks } = tidy_cg
@@ -1536,7 +1542,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
{- Generate byte code -}
- cbc <- liftIO $ byteCodeGen dflags this_mod
+ cbc <- liftIO $ byteCodeGen hsc_env this_mod
prepd_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
@@ -1715,11 +1721,11 @@ mkModGuts mod safe binds =
%********************************************************************* -}
#ifdef GHCI
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr hsc_env =
lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
= do { let dflags = hsc_dflags hsc_env
@@ -1736,7 +1742,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
{- Convert to BCOs -}
- ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+ ; bcos <- coreExprToBCOs hsc_env
+ (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
{- link it -}
; hval <- linkExpr hsc_env srcspan bcos
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 40c99f6436..3766b57df1 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -14,6 +14,9 @@ module HscTypes (
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
HscStatus(..),
+#ifdef GHCI
+ IServ(..),
+#endif
-- * Hsc monad
Hsc(..), runHsc, runInteractiveHsc,
@@ -130,8 +133,10 @@ module HscTypes (
#include "HsVersions.h"
#ifdef GHCI
-import ByteCodeAsm ( CompiledByteCode )
+import ByteCodeTypes ( CompiledByteCode )
import InteractiveEvalTypes ( Resume )
+import GHCi.Message ( Pipe )
+import GHCi.RemoteTypes ( HValueRef )
#endif
import HsSyn
@@ -184,16 +189,19 @@ import Binary
import ErrUtils
import Platform
import Util
-import Serialized ( Serialized )
+import GHC.Serialized ( Serialized )
import Control.Monad ( guard, liftM, when, ap )
+import Control.Concurrent
import Data.Array ( Array, array )
import Data.IORef
import Data.Time
import Data.Word
import Data.Typeable ( Typeable )
import Exception
+import Foreign
import System.FilePath
+import System.Process ( ProcessHandle )
-- -----------------------------------------------------------------------------
-- Compilation state
@@ -333,7 +341,7 @@ handleFlagWarnings dflags warns
************************************************************************
-}
--- | Hscenv is like 'Session', except that some of the fields are immutable.
+-- | HscEnv is like 'Session', except that some of the fields are immutable.
-- An HscEnv is used to compile a single module from plain Haskell source
-- code (after preprocessing) to either C, assembly or C--. Things like
-- the module graph don't change during a single compilation.
@@ -394,12 +402,27 @@ data HscEnv
-- ^ Used for one-shot compilation only, to initialise
-- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for
-- 'TcRunTypes.TcGblEnv'
+
+#ifdef GHCI
+ , hsc_iserv :: MVar (Maybe IServ)
+ -- ^ interactive server process. Created the first
+ -- time it is needed.
+#endif
}
instance ContainsDynFlags HscEnv where
extractDynFlags env = hsc_dflags env
replaceDynFlags env dflags = env {hsc_dflags = dflags}
+#ifdef GHCI
+data IServ = IServ
+ { iservPipe :: Pipe
+ , iservProcess :: ProcessHandle
+ , iservLookupSymbolCache :: IORef (UniqFM (Ptr ()))
+ , iservPendingFrees :: [HValueRef]
+ }
+#endif
+
-- | Retrieve the ExternalPackageState cache.
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ac53382a78..2f819e4a60 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -11,7 +11,7 @@
module InteractiveEval (
#ifdef GHCI
- Status(..), Resume(..), History(..),
+ Resume(..), History(..),
execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
runDecls, runDeclsWithLocation,
isStmt, isImport, isDecl,
@@ -36,6 +36,7 @@ module InteractiveEval (
isModuleInterpreted,
parseExpr, compileParsedExpr,
compileExpr, dynCompileExpr,
+ compileExprRemote, compileParsedExprRemote,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
-- * Depcreated API (remove in GHC 7.14)
RunResult(..), runStmt, runStmtWithLocation,
@@ -48,11 +49,13 @@ module InteractiveEval (
import InteractiveEvalTypes
+import GHCi
+import GHCi.Run
+import GHCi.RemoteTypes
import GhcMonad
import HscMain
import HsSyn
import HscTypes
-import BasicTypes ( HValue )
import InstEnv
import IfaceEnv ( newInteractiveBinder )
import FamInstEnv ( FamInst, orphNamesOfFamInst )
@@ -67,7 +70,7 @@ import Avail
import RdrName
import VarSet
import VarEnv
-import ByteCodeInstr
+import ByteCodeTypes
import Linker
import DynFlags
import Unique
@@ -88,25 +91,16 @@ import Bag
import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
import qualified Parser (parseStmt, parseModule, parseDeclaration)
-import System.Mem.Weak
import System.Directory
import Data.Dynamic
import Data.Either
import Data.List (find)
import StringBuffer (stringToStringBuffer)
import Control.Monad
-#if __GLASGOW_HASKELL__ >= 709
-import Foreign
-#else
-import Foreign.Safe
-#endif
-import Foreign.C
import GHC.Exts
import Data.Array
import Exception
import Control.Concurrent
-import System.IO.Unsafe
-import GHC.Conc ( setAllocationCounter, getAllocationCounter )
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -114,7 +108,7 @@ import GHC.Conc ( setAllocationCounter, getAllocationCounter )
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
-mkHistory :: HscEnv -> HValue -> BreakInfo -> History
+mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
decls = findEnclosingDecls hsc_env bi
in History hval bi decls
@@ -166,6 +160,7 @@ execOptions = ExecOptions
{ execSingleStep = RunToCompletion
, execSourceFile = "<interactive>"
, execLineNumber = 1
+ , execWrap = EvalThis -- just run the statement, don't wrap it in anything
}
-- | Run a statement in the current interactive context.
@@ -177,12 +172,7 @@ execStmt
execStmt stmt ExecOptions{..} = do
hsc_env <- getSession
- -- wait on this when we hit a breakpoint
- breakMVar <- liftIO $ newEmptyMVar
- -- wait on this when a computation is running
- statusMVar <- liftIO $ newEmptyMVar
-
- -- Turn off -Wunused-local-binds when running a statement, to hide
+ -- Turn off -fwarn-unused-local-binds when running a statement, to hide
-- warnings about the implicit bindings we introduce.
let ic = hsc_IC hsc_env -- use the interactive dflags
idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
@@ -201,9 +191,8 @@ execStmt stmt ExecOptions{..} = do
status <-
withVirtualCWD $
- withBreakAction (isStep execSingleStep) idflags'
- breakMVar statusMVar $ do
- liftIO $ sandboxIO idflags' statusMVar hval
+ liftIO $
+ evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_rn_gbl_env ic)
@@ -211,7 +200,7 @@ execStmt stmt ExecOptions{..} = do
size = ghciHistSize idflags'
handleRunStatus execSingleStep stmt bindings ids
- breakMVar statusMVar status (emptyHistory size)
+ status (emptyHistory size)
-- | The type returned by the deprecated 'runStmt' and
-- 'runStmtWithLocation' API
@@ -226,7 +215,7 @@ execResultToRunResult r =
case r of
ExecComplete{ execResult = Left ex } -> RunException ex
ExecComplete{ execResult = Right names } -> RunOk names
- ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo
+ ExecBreak{..} -> RunBreak (error "no breakThreadId") breakNames breakInfo
-- Remove in GHC 7.14
{-# DEPRECATED runStmt "use execStmt" #-}
@@ -249,7 +238,8 @@ runStmtWithLocation source linenumber expr step = do
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1
-runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation
+ :: GhcMonad m => String -> Int -> String -> m [Name]
runDeclsWithLocation source linenumber expr =
do
hsc_env <- getSession
@@ -265,8 +255,12 @@ runDeclsWithLocation source linenumber expr =
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
hsc_env <- getSession
- let ic = hsc_IC hsc_env
+ -- a virtual CWD is only necessary when we're running interpreted code in
+ -- the same process as the compiler.
+ if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
+
+ let ic = hsc_IC hsc_env
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
case ic_cwd ic of
@@ -291,68 +285,67 @@ emptyHistory size = nilBL size
handleRunStatus :: GhcMonad m
=> SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
- -> MVar () -> MVar Status -> Status -> BoundedList History
+ -> EvalStatus [ForeignHValue] -> BoundedList History
-> m ExecResult
-handleRunStatus step expr bindings final_ids
- breakMVar statusMVar status history
+handleRunStatus step expr bindings final_ids status history
| RunAndLogSteps <- step = tracing
| otherwise = not_tracing
where
tracing
- | Break is_exception apStack info tid <- status
+ | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
, not is_exception
= do
hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ info_hv <- liftIO $ wormholeRef dflags info_ref
+ let info = unsafeCoerce# info_hv :: BreakInfo
b <- liftIO $ isBreakEnabled hsc_env info
if b
then not_tracing
-- This breakpoint is explicitly enabled; we want to stop
-- instead of just logging it.
else do
- let history' = mkHistory hsc_env apStack info `consBL` history
+ apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+ let history' = mkHistory hsc_env apStack_fhv info `consBL` history
-- probably better make history strict here, otherwise
-- our BoundedList will be pointless.
_ <- liftIO $ evaluate history'
- status <- withBreakAction True (hsc_dflags hsc_env)
- breakMVar statusMVar $ do
- liftIO $ mask_ $ do
- putMVar breakMVar () -- awaken the stopped thread
- redirectInterrupts tid $
- takeMVar statusMVar -- and wait for the result
+ fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+ status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
handleRunStatus RunAndLogSteps expr bindings final_ids
- breakMVar statusMVar status history'
+ status history'
| otherwise
= not_tracing
not_tracing
-- Hit a breakpoint
- | Break is_exception apStack info tid <- status
+ | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
= do
hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+ info_hv <- liftIO $ wormholeRef dflags info_ref
+ let info = unsafeCoerce# info_hv :: BreakInfo
+ resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+ apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
let mb_info | is_exception = Nothing
| otherwise = Just info
(hsc_env1, names, span) <- liftIO $
- bindLocalsAtBreakpoint hsc_env apStack mb_info
+ bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info
let
resume = Resume
- { resumeStmt = expr, resumeThreadId = tid
- , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+ { resumeStmt = expr, resumeContext = resume_ctxt_fhv
, resumeBindings = bindings, resumeFinalIds = final_ids
- , resumeApStack = apStack, resumeBreakInfo = mb_info
+ , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info
, resumeSpan = span, resumeHistory = toListBL history
, resumeHistoryIx = 0 }
hsc_env2 = pushResume hsc_env1 resume
modifySession (\_ -> hsc_env2)
- return (ExecBreak tid names mb_info)
-
- -- Completed with an exception
- | Complete (Left e) alloc <- status
- = return (ExecComplete (Left e) alloc)
+ return (ExecBreak names mb_info)
-- Completed successfully
- | Complete (Right hvals) allocs <- status
+ | EvalComplete allocs (EvalSuccess hvals) <- status
= do hsc_env <- getSession
let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
final_names = map getName final_ids
@@ -361,8 +354,12 @@ handleRunStatus step expr bindings final_ids
modifySession (\_ -> hsc_env')
return (ExecComplete (Right final_names) allocs)
+ -- Completed with an exception
+ | EvalComplete alloc (EvalException e) <- status
+ = return (ExecComplete (Left (fromSerializableException e)) alloc)
+
| otherwise
- = panic "handleRunStatus" -- The above cases are in fact exhaustive
+ = panic "not_tracing" -- actually exhaustive, but GHC can't tell
isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
isBreakEnabled hsc_env inf =
@@ -376,148 +373,6 @@ isBreakEnabled hsc_env inf =
return False
-foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
-foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
-
-setStepFlag :: IO ()
-setStepFlag = poke stepFlag 1
-resetStepFlag :: IO ()
-resetStepFlag = poke stepFlag 0
-
--- this points to the IO action that is executed when a breakpoint is hit
-foreign import ccall "&rts_breakpoint_io_action"
- breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
-
--- When running a computation, we redirect ^C exceptions to the running
--- thread. ToDo: we might want a way to continue even if the target
--- thread doesn't die when it receives the exception... "this thread
--- is not responding".
---
--- Careful here: there may be ^C exceptions flying around, so we start the new
--- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
--- only while we execute the user's code. We can't afford to lose the final
--- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
-sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
-sandboxIO dflags statusMVar thing =
- mask $ \restore -> -- fork starts blocked
- let runIt =
- liftM (uncurry Complete) $
- measureAlloc $
- try $ restore $ rethrow dflags $ thing
- in if gopt Opt_GhciSandbox dflags
- then do tid <- forkIO $ do res <- runIt
- putMVar statusMVar res -- empty: can't block
- redirectInterrupts tid $
- takeMVar statusMVar
-
- else -- GLUT on OS X needs to run on the main thread. If you
- -- try to use it from another thread then you just get a
- -- white rectangle rendered. For this, or anything else
- -- with such restrictions, you can turn the GHCi sandbox off
- -- and things will be run in the main thread.
- --
- -- BUT, note that the debugging features (breakpoints,
- -- tracing, etc.) need the expression to be running in a
- -- separate thread, so debugging is only enabled when
- -- using the sandbox.
- runIt
-
---
--- While we're waiting for the sandbox thread to return a result, if
--- the current thread receives an asynchronous exception we re-throw
--- it at the sandbox thread and continue to wait.
---
--- This is for two reasons:
---
--- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
--- computation to run its exception handlers before returning the
--- exception result to the caller of runStmt.
---
--- * clients of the GHC API can terminate a runStmt in progress
--- without knowing the ThreadId of the sandbox thread (#1381)
---
--- NB. use a weak pointer to the thread, so that the thread can still
--- be considered deadlocked by the RTS and sent a BlockedIndefinitely
--- exception. A symptom of getting this wrong is that conc033(ghci)
--- will hang.
---
-redirectInterrupts :: ThreadId -> IO a -> IO a
-redirectInterrupts target wait
- = do wtid <- mkWeakThreadId target
- wait `catch` \e -> do
- m <- deRefWeak wtid
- case m of
- Nothing -> wait
- Just target -> do throwTo target (e :: SomeException); wait
-
-measureAlloc :: IO a -> IO (a,Word64)
-measureAlloc io = do
- setAllocationCounter maxBound
- a <- io
- allocs <- getAllocationCounter
- return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs)
-
--- We want to turn ^C into a break when -fbreak-on-exception is on,
--- but it's an async exception and we only break for sync exceptions.
--- Idea: if we catch and re-throw it, then the re-throw will trigger
--- a break. Great - but we don't want to re-throw all exceptions, because
--- then we'll get a double break for ordinary sync exceptions (you'd have
--- to :continue twice, which looks strange). So if the exception is
--- not "Interrupted", we unset the exception flag before throwing.
---
-rethrow :: DynFlags -> IO a -> IO a
-rethrow dflags io = Exception.catch io $ \se -> do
- -- If -fbreak-on-error, we break unconditionally,
- -- but with care of not breaking twice
- if gopt Opt_BreakOnError dflags &&
- not (gopt Opt_BreakOnException dflags)
- then poke exceptionFlag 1
- else case fromException se of
- -- If it is a "UserInterrupt" exception, we allow
- -- a possible break by way of -fbreak-on-exception
- Just UserInterrupt -> return ()
- -- In any other case, we don't want to break
- _ -> poke exceptionFlag 0
-
- Exception.throwIO se
-
--- 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
--- evaluation should generate breakpoints.
-withBreakAction :: (ExceptionMonad m) =>
- Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
-withBreakAction step dflags breakMVar statusMVar act
- = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
- where
- setBreakAction = do
- stablePtr <- newStablePtr onBreak
- poke breakPointIOAction stablePtr
- when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
- when step $ setStepFlag
- return stablePtr
- -- Breaking on exceptions is not enabled by default, since it
- -- might be a bit surprising. The exception flag is turned off
- -- as soon as it is hit, or in resetBreakAction below.
-
- onBreak is_exception info apStack = do
- tid <- myThreadId
- putMVar statusMVar (Break is_exception apStack info tid)
- takeMVar breakMVar
-
- resetBreakAction stablePtr = do
- poke breakPointIOAction noBreakStablePtr
- poke exceptionFlag 0
- resetStepFlag
- freeStablePtr stablePtr
-
-noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
-noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
-
-noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
-noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction True _ _ = return () -- exception: just continue
-
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step
@@ -547,22 +402,14 @@ resumeExec canLogSpan step
(ic_tythings ic))
liftIO $ Linker.deleteFromLinkEnv new_names
- when (isStep step) $ liftIO setStepFlag
case r of
- Resume { resumeStmt = expr, resumeThreadId = tid
- , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+ Resume { resumeStmt = expr, resumeContext = fhv
, resumeBindings = bindings, resumeFinalIds = final_ids
- , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
+ , resumeApStack = apStack, resumeBreakInfo = info
+ , resumeSpan = span
, resumeHistory = hist } -> do
withVirtualCWD $ do
- withBreakAction (isStep step) (hsc_dflags hsc_env)
- breakMVar statusMVar $ do
- status <- liftIO $ mask_ $ do
- putMVar breakMVar ()
- -- this awakens the stopped thread...
- redirectInterrupts tid $
- takeMVar statusMVar
- -- and wait for the result
+ status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
let prevHistoryLst = fromListBL 50 hist
hist' = case info of
Nothing -> prevHistoryLst
@@ -570,8 +417,7 @@ resumeExec canLogSpan step
| not $canLogSpan span -> prevHistoryLst
| otherwise -> mkHistory hsc_env apStack i `consBL`
fromListBL 50 hist
- handleRunStatus step expr bindings final_ids
- breakMVar statusMVar status hist'
+ handleRunStatus step expr bindings final_ids status hist'
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
@@ -626,7 +472,7 @@ result_fs = fsLit "_result"
bindLocalsAtBreakpoint
:: HscEnv
- -> HValue
+ -> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan)
@@ -648,13 +494,12 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
--
- Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
+ Linker.extendLinkEnv [(exn_name, apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
-
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
let
mod_name = moduleName (breakInfo_module info)
hmi = expectJust "bindLocalsAtBreakpoint" $
@@ -682,12 +527,12 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
-- has been accidentally evaluated, or something else has gone wrong.
-- So that we don't fall over in a heap when this happens, just don't
-- bind any free variables instead, and we emit a warning.
+ apStack <- wormhole (hsc_dflags hsc_env) apStack_fhv
mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
-
us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
let tv_subst = newTyVars us free_tvs
filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
@@ -706,8 +551,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
names = map idName new_ids
- Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
- when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+ fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkHValueRef)
+ (catMaybes mb_hValues)
+ Linker.extendLinkEnv (zip names fhvs)
+ when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span)
where
@@ -791,7 +638,7 @@ abandon = do
[] -> return False
r:rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
- liftIO $ abandon_ r
+ liftIO $ abandonStmt hsc_env (resumeContext r)
return True
abandonAll :: GhcMonad m => m Bool
@@ -803,28 +650,9 @@ abandonAll = do
[] -> return False
rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
- liftIO $ mapM_ abandon_ rs
+ liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
return True
--- when abandoning a computation we have to
--- (a) kill the thread with an async exception, so that the
--- computation itself is stopped, and
--- (b) fill in the MVar. This step is necessary because any
--- thunks that were under evaluation will now be updated
--- with the partial computation, which still ends in takeMVar,
--- so any attempt to evaluate one of these thunks will block
--- unless we fill in the MVar.
--- (c) wait for the thread to terminate by taking its status MVar. This
--- step is necessary to prevent race conditions with
--- -fbreak-on-exception (see #5975).
--- See test break010.
-abandon_ :: Resume -> IO ()
-abandon_ r = do
- killThread (resumeThreadId r)
- putMVar (resumeBreakMVar r) ()
- _ <- takeMVar (resumeStatMVar r)
- return ()
-
-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons
@@ -1058,10 +886,16 @@ compileExpr expr = do
parsed_expr <- parseExpr expr
compileParsedExpr parsed_expr
+-- | Compile an expression, run it and deliver the resulting HValue.
+compileExprRemote :: GhcMonad m => String -> m ForeignHValue
+compileExprRemote expr = do
+ parsed_expr <- parseExpr expr
+ compileParsedExprRemote parsed_expr
+
-- | Compile an parsed expression (before renaming), run it and deliver
-- the resulting HValue.
-compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
-compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
+compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue
+compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
-- > let _compileParsedExpr = expr
-- Create let stmt from expr to make hscParsedStmt happy.
-- We will ignore the returned [Id], namely [expr_id], and not really
@@ -1071,13 +905,21 @@ compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
let_stmt = L loc . LetStmt . L loc . HsValBinds $
ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
- Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
+ Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
updateFixityEnv fix_env
- hvals <- liftIO hvals_io
- case (ids, hvals) of
- ([_expr_id], [hval]) -> return hval
+ status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
+ case status of
+ EvalComplete _ (EvalSuccess [hval]) -> return hval
+ EvalComplete _ (EvalException e) ->
+ liftIO $ throwIO (fromSerializableException e)
_ -> panic "compileParsedExpr"
+compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
+compileParsedExpr expr = do
+ fhv <- compileParsedExprRemote expr
+ dflags <- getDynFlags
+ liftIO $ wormhole dflags fhv
+
-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
@@ -1116,14 +958,16 @@ obtainTermFromVal hsc_env bound force ty x =
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
- hv <- Linker.getHValue hsc_env (varName id)
- cvObtainTerm hsc_env bound force (idType id) hv
+ let dflags = hsc_dflags hsc_env
+ hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+ cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
- hv <- Linker.getHValue hsc_env (varName id)
- cvReconstructType hsc_env bound (idType id) hv
+ let dflags = hsc_dflags hsc_env
+ hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+ cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index 7e6e837bea..98090bbaed 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -10,22 +10,22 @@
module InteractiveEvalTypes (
#ifdef GHCI
- Status(..), Resume(..), History(..), ExecResult(..),
+ Resume(..), History(..), ExecResult(..),
SingleStep(..), isStep, ExecOptions(..)
#endif
) where
#ifdef GHCI
+import GHCi.RemoteTypes (ForeignHValue)
+import GHCi.Message (EvalExpr)
import Id
-import BasicTypes
import Name
import RdrName
import Type
-import ByteCodeInstr
+import ByteCodeTypes
import SrcLoc
import Exception
-import Control.Concurrent
import Data.Word
@@ -34,6 +34,7 @@ data ExecOptions
{ execSingleStep :: SingleStep -- ^ stepping mode
, execSourceFile :: String -- ^ filename (for errors)
, execLineNumber :: Int -- ^ line number (for errors)
+ , execWrap :: ForeignHValue -> EvalExpr ForeignHValue
}
data SingleStep
@@ -51,26 +52,17 @@ data ExecResult
, execAllocation :: Word64
}
| ExecBreak
- { breakThreadId :: ThreadId
- , breakNames :: [Name]
+ { breakNames :: [Name]
, breakInfo :: Maybe BreakInfo
}
-data Status
- = Break Bool HValue BreakInfo ThreadId
- -- ^ the computation hit a breakpoint (Bool <=> was an exception)
- | Complete (Either SomeException [HValue]) Word64
- -- ^ the computation completed with either an exception or a value
-
data Resume
= Resume {
resumeStmt :: String, -- the original statement
- resumeThreadId :: ThreadId, -- thread running the computation
- resumeBreakMVar :: MVar (),
- resumeStatMVar :: MVar Status,
+ resumeContext :: ForeignHValue, -- thread running the computation
resumeBindings :: ([TyThing], GlobalRdrEnv),
resumeFinalIds :: [Id], -- [Id] to bind on completion
- resumeApStack :: HValue, -- The object from which we can get
+ resumeApStack :: ForeignHValue, -- The object from which we can get
-- value of the free variables.
resumeBreakInfo :: Maybe BreakInfo,
-- the breakpoint we stopped at
@@ -84,7 +76,7 @@ data Resume
data History
= History {
- historyApStack :: HValue,
+ historyApStack :: ForeignHValue,
historyBreakInfo :: BreakInfo,
historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
}
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index ad717a8a88..c7ca4a6481 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -187,6 +187,8 @@ initSysTools mbMinusB
platformConstantsFile = top_dir </> "platformConstants"
installed :: FilePath -> FilePath
installed file = top_dir </> file
+ libexec :: FilePath -> FilePath
+ libexec file = top_dir </> "bin" </> file
settingsStr <- readFile settingsFile
platformConstantsStr <- readFile platformConstantsFile
@@ -265,10 +267,10 @@ initSysTools mbMinusB
-- For all systems, unlit, split, mangle are GHC utilities
-- architecture-specific stuff is done when building Config.hs
- unlit_path = installed cGHC_UNLIT_PGM
+ unlit_path = libexec cGHC_UNLIT_PGM
-- split is a Perl script
- split_script = installed cGHC_SPLIT_PGM
+ split_script = libexec cGHC_SPLIT_PGM
windres_path <- getSetting "windres command"
libtool_path <- getSetting "libtool command"
@@ -305,6 +307,8 @@ initSysTools mbMinusB
lc_prog <- getSetting "LLVM llc command"
lo_prog <- getSetting "LLVM opt command"
+ let iserv_prog = libexec "ghc-iserv"
+
let platform = Platform {
platformArch = targetArch,
platformOS = targetOS,
@@ -344,6 +348,7 @@ initSysTools mbMinusB
sPgm_libtool = libtool_path,
sPgm_lo = (lo_prog,[]),
sPgm_lc = (lc_prog,[]),
+ sPgm_i = iserv_prog,
sOpt_L = [],
sOpt_P = [],
sOpt_F = [],
@@ -353,6 +358,7 @@ initSysTools mbMinusB
sOpt_windres = [],
sOpt_lo = [],
sOpt_lc = [],
+ sOpt_i = [],
sPlatformConstants = platformConstants
}
View Lorry Controller Status