diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-02-17 18:12:30 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-29 05:09:25 -0500 |
commit | 18757cab04c5c5c48eaceea19469d4811c5d0371 (patch) | |
tree | 5437de47247b8fe69f8b83db6a66524cabddee3f | |
parent | b5fb58fd1a4a24b9273d9d2de65b6347e1654e98 (diff) | |
download | haskell-18757cab04c5c5c48eaceea19469d4811c5d0371.tar.gz |
Refactor runtime interpreter code
In #14335 we want to be able to use both the internal interpreter (for
the plugins) and the external interpreter (for TH and GHCi) at the same
time.
This patch performs some preliminary refactoring: the `hsc_interp` field
of HscEnv replaces `hsc_iserv` and is now used to indicate which
interpreter (internal, external) to use to execute TH and GHCi.
Opt_ExternalInterpreter flag and iserv options in DynFlags are now
queried only when we set the session DynFlags. It should help making GHC
multi-target in the future by selecting an interpreter according to the
selected target.
-rw-r--r-- | compiler/GHC.hs | 42 | ||||
-rw-r--r-- | compiler/GHC/CoreToByteCode.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Types.hs | 48 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 61 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 285 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter/Types.hs | 63 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 20 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
-rw-r--r-- | compiler/typecheck/TcAnnotations.hs | 24 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.hs | 84 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 16 |
13 files changed, 409 insertions, 259 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index af0fb5885a..fb1ac703a2 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -299,11 +299,13 @@ import GHC.ByteCode.Types import GHC.Runtime.Eval import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes import GHC.Core.Ppr.TyThing ( pprFamInst ) import GHC.Driver.Main import GHC.Driver.Make +import GHC.Driver.Hooks import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) @@ -373,6 +375,8 @@ import System.Exit ( exitWith, ExitCode(..) ) import Exception import Data.IORef import System.FilePath +import Control.Concurrent +import Control.Applicative ((<|>)) import Maybes import System.IO.Error ( isDoesNotExistError ) @@ -486,7 +490,7 @@ withCleanupSession ghc = ghc `gfinally` cleanup liftIO $ do cleanTempFiles dflags cleanTempDirs dflags - stopIServ hsc_env -- shut down the IServ + stopInterp hsc_env -- shut down the IServ -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. @@ -594,8 +598,42 @@ setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags dflags'' <- liftIO $ interpretPackageEnv dflags' (dflags''', preload) <- liftIO $ initPackages dflags'' + + -- Interpreter + interp <- if gopt Opt_ExternalInterpreter dflags + then do + let + prog = pgm_i dflags ++ flavour + flavour + | WayProf `elem` ways dflags = "-prof" + | WayDyn `elem` ways dflags = "-dyn" + | otherwise = "" + msg = text "Starting " <> text prog + tr <- if verbosity dflags >= 3 + then return (logInfo dflags (defaultDumpStyle dflags) msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = getOpts dflags opt_i + , iservConfHook = createIservProcessHook (hooks dflags) + , iservConfTrace = tr + } + s <- liftIO $ newMVar (IServPending conf) + return (Just (ExternalInterp (IServ s))) + else +#if defined(HAVE_INTERNAL_INTERPRETER) + return (Just InternalInterp) +#else + return Nothing +#endif + modifySession $ \h -> h{ hsc_dflags = dflags''' - , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } } + , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } + , hsc_interp = hsc_interp h <|> interp + -- we only update the interpreter if there wasn't + -- already one set up + } invalidateModSummaryCache return preload diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 6b5a40f4a8..a9c3ce3711 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -19,6 +19,7 @@ import GHC.ByteCode.Asm import GHC.ByteCode.Types import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types import GHCi.FFI import GHCi.RemoteTypes import BasicTypes @@ -991,9 +992,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = do dflags <- getDynFlags + hsc_env <- getHscEnv let profiling - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | Just (ExternalInterp _) <- hsc_interp hsc_env = gopt Opt_SccProfilingOn dflags | otherwise = rtsIsProfiled -- Top of stack is the return itbl, as usual. diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 0e4c5addb9..00eff081ee 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -99,7 +99,6 @@ import GHC.Core.Lint ( lintInteractiveExpr ) import VarEnv ( emptyTidyEnv ) import Panic import ConLike -import Control.Concurrent import ApiAnnotation import Module @@ -197,7 +196,6 @@ newHscEnv dflags = do us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv - iserv_mvar <- newMVar Nothing emptyDynLinker <- uninitializedLinker return HscEnv { hsc_dflags = dflags , hsc_targets = [] @@ -208,7 +206,7 @@ newHscEnv dflags = do , hsc_NC = nc_var , hsc_FC = fc_var , hsc_type_env_var = Nothing - , hsc_iserv = iserv_mvar + , hsc_interp = Nothing , hsc_dynLinker = emptyDynLinker } diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 9e7b175a1c..58fe239900 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -22,7 +22,6 @@ module GHC.Driver.Types ( FinderCache, FindResult(..), InstalledFindResult(..), Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, HscStatus(..), - IServ(..), -- * ModuleGraph ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, @@ -157,8 +156,7 @@ import GhcPrelude import GHC.ByteCode.Types import GHC.Runtime.Eval.Types ( Resume ) -import GHCi.Message ( Pipe ) -import GHCi.RemoteTypes +import GHC.Runtime.Interpreter.Types (Interp) import GHC.ForeignSrcLang import UniqFM @@ -221,8 +219,6 @@ import Data.IORef import Data.Time import Exception import System.FilePath -import Control.Concurrent -import System.Process ( ProcessHandle ) import Control.DeepSeq import Control.Monad.Trans.Reader import Control.Monad.Trans.Class @@ -473,15 +469,43 @@ data HscEnv -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] - , hsc_iserv :: MVar (Maybe IServ) - -- ^ interactive server process. Created the first - -- time it is needed. + , hsc_interp :: Maybe Interp + -- ^ target code interpreter (if any) to use for TH and GHCi. + -- See Note [Target code interpreter] , hsc_dynLinker :: DynLinker -- ^ dynamic linker. } +{- + +Note [Target code interpreter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Template Haskell and GHCi use an interpreter to execute code that is built for +the compiler target platform (= code host platform) on the compiler host +platform (= code build platform). + +The internal interpreter can be used when both platforms are the same and when +the built code is compatible with the compiler itself (same way, etc.). This +interpreter is not always available: for instance stage1 compiler doesn't have +it because there might be an ABI mismatch between the code objects (built by +stage1 compiler) and the stage1 compiler itself (built by stage0 compiler). + +In most cases, an external interpreter can be used instead: it runs in a +separate process and it communicates with the compiler via a two-way message +passing channel. The process is lazily spawned to avoid overhead when it is not +used. + +The target code interpreter to use can be selected per session via the +`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in +which case Template Haskell and GHCi will fail to run. The interpreter to use is +configured via command-line flags (in `GHC.setSessionDynFlags`). + + +-} + -- Note [hsc_type_env_var hack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- hsc_type_env_var is used to initialize tcg_type_env_var, and @@ -524,14 +548,6 @@ data HscEnv -- should not populate the EPS. But that's a refactor for -- another day. - -data IServ = IServ - { iservPipe :: Pipe - , iservProcess :: ProcessHandle - , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) - , iservPendingFrees :: [HValueRef] - } - -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 8890192d92..7b5962e6bf 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, - RecordWildCards, BangPatterns #-} +{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -51,6 +51,7 @@ import GhcPrelude import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHC.Driver.Monad @@ -278,24 +279,25 @@ withVirtualCWD m = do -- 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 - Just dir -> liftIO $ setCurrentDirectory dir - Nothing -> return () - return dir - - reset_cwd orig_dir = do - virt_dir <- liftIO $ getCurrentDirectory - hsc_env <- getSession - let old_IC = hsc_IC hsc_env - setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } - liftIO $ setCurrentDirectory orig_dir - - gbracket set_cwd reset_cwd $ \_ -> m + case hsc_interp hsc_env of + Just (ExternalInterp _) -> m + _ -> do + let ic = hsc_IC hsc_env + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr @@ -1213,8 +1215,9 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue compileParsedExpr expr = do fhv <- compileParsedExprRemote expr - dflags <- getDynFlags - liftIO $ wormhole dflags fhv + hsc_env <- getSession + liftIO $ withInterp hsc_env $ \interp -> + wormhole interp fhv -- | Compile an expression, run it and return the result as a Dynamic. dynCompileExpr :: GhcMonad m => String -> m Dynamic @@ -1249,12 +1252,14 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> -- RTTI primitives obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x - | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") - | otherwise - = cvObtainTerm hsc_env bound force ty (unsafeCoerce x) +#if defined(HAVE_INTERNAL_INTERPRETER) +obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case + InternalInterp -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x) +#else +obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case +#endif + ExternalInterp _ -> throwIO (InstallationError + "this operation requires -fno-external-interpreter") obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 8524e92cdc..3eb9c85a01 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} -- -- | Interacting with the interpreter, whether it is running on an @@ -38,7 +40,8 @@ module GHC.Runtime.Interpreter , findSystemLibrary -- * Lower-level API using messages - , iservCmd, Message(..), withIServ, stopIServ + , iservCmd, Message(..), withIServ, withIServ_ + , withInterp, stopInterp , iservCall, readIServ, writeIServ , purgeLookupSymbolCache , freeHValueRefs @@ -50,6 +53,7 @@ module GHC.Runtime.Interpreter import GhcPrelude +import GHC.Runtime.Interpreter.Types import GHCi.Message #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run @@ -62,13 +66,10 @@ import GHC.Driver.Types import UniqFM import Panic import GHC.Driver.Session -import ErrUtils -import Outputable import Exception import BasicTypes import FastString import Util -import GHC.Driver.Hooks import Control.Concurrent import Control.Monad @@ -157,11 +158,6 @@ Other Notes on Remote GHCi * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} -#if !defined(HAVE_INTERNAL_INTERPRETER) -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 @@ -169,23 +165,28 @@ needExtInt = throwIO -- @Binary@ constraint). With @-fno-external-interpreter@ we execute -- the command directly here. iservCmd :: Binary a => HscEnv -> Message a -> IO a -iservCmd hsc_env@HscEnv{..} msg - | gopt Opt_ExternalInterpreter hsc_dflags = - withIServ hsc_env $ \iserv -> - uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] - iservCall iserv msg - | otherwise = -- Just run it directly +iservCmd hsc_env msg = withInterp hsc_env $ \case #if defined(HAVE_INTERNAL_INTERPRETER) - run msg -#else - needExtInt + InternalInterp -> run msg -- Just run it directly #endif + (ExternalInterp i) -> withIServ_ i $ \iserv -> + uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] + iservCall iserv msg + + +-- | Execute an action with the interpreter +-- +-- Fails if no target code interpreter is available +withInterp :: HscEnv -> (Interp -> IO a) -> IO a +withInterp hsc_env action = case hsc_interp hsc_env of + Nothing -> throwIO (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") + Just i -> action i -- Note [uninterruptibleMask_ and iservCmd] -- -- If we receive an async exception, such as ^C, while communicating -- with the iserv process then we will be out-of-sync and not be able --- to recoever. Thus we use uninterruptibleMask_ during +-- to recover. Thus we use uninterruptibleMask_ during -- communication. A ^C will be delivered to the iserv process (because -- signals get sent to the whole process group) which will interrupt -- the running computation and return an EvalException result. @@ -194,24 +195,37 @@ iservCmd hsc_env@HscEnv{..} msg -- Overloaded because this is used from TcM as well as IO. withIServ :: (MonadIO m, ExceptionMonad m) - => HscEnv -> (IServ -> m a) -> m a -withIServ HscEnv{..} action = + => IServ -> (IServInstance -> m (IServInstance, a)) -> m a +withIServ (IServ mIServState) action = do gmask $ \restore -> do - m <- liftIO $ takeMVar hsc_iserv - -- start the iserv process if we haven't done so yet - iserv <- maybe (liftIO $ startIServ hsc_dflags) return m - `gonException` (liftIO $ putMVar hsc_iserv Nothing) + state <- liftIO $ takeMVar mIServState + + iserv <- case state of + -- start the external iserv process if we haven't done so yet + IServPending conf -> + liftIO (spawnIServ conf) + `gonException` (liftIO $ putMVar mIServState state) + + IServRunning inst -> return inst + + + let iserv' = iserv{ iservPendingFrees = [] } + + (iserv'',a) <- (do -- free any ForeignHValues that have been garbage collected. - let iserv' = iserv{ iservPendingFrees = [] } - a <- (do liftIO $ when (not (null (iservPendingFrees iserv))) $ iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) - -- run the inner action - restore $ action iserv) - `gonException` (liftIO $ putMVar hsc_iserv (Just iserv')) - liftIO $ putMVar hsc_iserv (Just iserv') + -- run the inner action + restore $ action iserv') + `gonException` (liftIO $ putMVar mIServState (IServRunning iserv')) + liftIO $ putMVar mIServState (IServRunning iserv'') return a +withIServ_ + :: (MonadIO m, ExceptionMonad m) + => IServ -> (IServInstance -> m a) -> m a +withIServ_ iserv action = withIServ iserv $ \inst -> + (inst,) <$> action inst -- ----------------------------------------------------------------------------- -- Wrappers around messages @@ -371,41 +385,45 @@ initObjLinker :: HscEnv -> IO () initObjLinker hsc_env = iservCmd hsc_env InitLinker lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) -lookupSymbol hsc_env@HscEnv{..} str - | gopt Opt_ExternalInterpreter hsc_dflags = - -- Profiling of GHCi showed a lot of time and allocation spent - -- making cross-process LookupSymbol calls, so I added a GHC-side - -- cache which sped things up quite a lot. We have to be careful - -- to purge this cache when unloading code though. - withIServ hsc_env $ \iserv@IServ{..} -> do - cache <- readIORef iservLookupSymbolCache - case lookupUFM cache str of - Just p -> return (Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - iservCall iserv (LookupSymbol (unpackFS str)) - case m of - Nothing -> return Nothing - Just r -> do - let p = fromRemotePtr r - writeIORef iservLookupSymbolCache $! addToUFM cache str p - return (Just p) - | otherwise = +lookupSymbol hsc_env str = withInterp hsc_env $ \case #if defined(HAVE_INTERNAL_INTERPRETER) - fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -#else - needExtInt + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #endif + ExternalInterp i -> withIServ i $ \iserv -> do + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + let cache = iservLookupSymbolCache iserv + case lookupUFM cache str of + Just p -> return (iserv, Just p) + Nothing -> do + m <- uninterruptibleMask_ $ + iservCall iserv (LookupSymbol (unpackFS str)) + case m of + Nothing -> return (iserv, Nothing) + Just r -> do + let p = fromRemotePtr r + cache' = addToUFM cache str p + iserv' = iserv {iservLookupSymbolCache = cache'} + return (iserv', Just p) + lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) lookupClosure hsc_env str = iservCmd hsc_env (LookupClosure str) purgeLookupSymbolCache :: HscEnv -> IO () -purgeLookupSymbolCache hsc_env@HscEnv{..} = - when (gopt Opt_ExternalInterpreter hsc_dflags) $ - withIServ hsc_env $ \IServ{..} -> - writeIORef iservLookupSymbolCache emptyUFM +purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp (IServ mstate)) -> + modifyMVar_ mstate $ \state -> pure $ case state of + IServPending {} -> state + IServRunning iserv -> IServRunning + (iserv { iservLookupSymbolCache = emptyUFM }) -- | loadDLL loads a dynamic library using the OS's native linker @@ -460,74 +478,70 @@ findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) -- Raw calls and messages -- | Send a 'Message' and receive the response from the iserv process -iservCall :: Binary a => IServ -> Message a -> IO a -iservCall iserv@IServ{..} msg = - remoteCall iservPipe msg +iservCall :: Binary a => IServInstance -> Message a -> IO a +iservCall iserv msg = + remoteCall (iservPipe iserv) msg `catch` \(e :: SomeException) -> handleIServFailure iserv e -- | Read a value from the iserv process -readIServ :: IServ -> Get a -> IO a -readIServ iserv@IServ{..} get = - readPipe iservPipe get +readIServ :: IServInstance -> Get a -> IO a +readIServ iserv get = + readPipe (iservPipe iserv) get `catch` \(e :: SomeException) -> handleIServFailure iserv e -- | Send a value to the iserv process -writeIServ :: IServ -> Put -> IO () -writeIServ iserv@IServ{..} put = - writePipe iservPipe put +writeIServ :: IServInstance -> Put -> IO () +writeIServ iserv put = + writePipe (iservPipe iserv) put `catch` \(e :: SomeException) -> handleIServFailure iserv e -handleIServFailure :: IServ -> SomeException -> IO a -handleIServFailure IServ{..} e = do - ex <- getProcessExitCode iservProcess +handleIServFailure :: IServInstance -> SomeException -> IO a +handleIServFailure iserv e = do + let proc = iservProcess iserv + ex <- getProcessExitCode proc case ex of Just (ExitFailure n) -> - throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) + throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) _ -> do - terminateProcess iservProcess - _ <- waitForProcess iservProcess + terminateProcess proc + _ <- waitForProcess proc throw e --- ----------------------------------------------------------------------------- --- Starting and stopping the iserv process - -startIServ :: DynFlags -> IO IServ -startIServ dflags = do - let flavour - | WayProf `elem` ways dflags = "-prof" - | WayDyn `elem` ways dflags = "-dyn" - | otherwise = "" - prog = pgm_i dflags ++ flavour - opts = getOpts dflags opt_i - debugTraceMsg dflags 3 $ text "Starting " <> text prog - let createProc = lookupHook createIservProcessHook - (\cp -> do { (_,_,_,ph) <- createProcess cp - ; return ph }) - dflags - (ph, rh, wh) <- runWithPipes createProc prog opts +-- | Spawn an external interpreter +spawnIServ :: IServConfig -> IO IServInstance +spawnIServ conf = do + iservConfTrace conf + let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp + ; return ph }) + (iservConfHook conf) + (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf) + (iservConfOpts conf) lo_ref <- newIORef Nothing - cache_ref <- newIORef emptyUFM - return $ IServ - { iservPipe = Pipe { pipeRead = rh - , pipeWrite = wh - , pipeLeftovers = lo_ref } - , iservProcess = ph - , iservLookupSymbolCache = cache_ref - , iservPendingFrees = [] + return $ IServInstance + { iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + , iservProcess = ph + , iservLookupSymbolCache = emptyUFM + , iservPendingFrees = [] + , iservConfig = conf } -stopIServ :: HscEnv -> IO () -stopIServ HscEnv{..} = - gmask $ \_restore -> do - m <- takeMVar hsc_iserv - maybe (return ()) stop m - putMVar hsc_iserv Nothing - where - stop iserv = do - ex <- getProcessExitCode (iservProcess iserv) - if isJust ex - then return () - else iservCall iserv Shutdown +-- | Stop the interpreter +stopInterp :: HscEnv -> IO () +stopInterp hsc_env = case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp (IServ mstate)) -> + gmask $ \_restore -> modifyMVar_ mstate $ \state -> do + case state of + IServPending {} -> pure state -- already stopped + IServRunning i -> do + ex <- getProcessExitCode (iservProcess i) + if isJust ex + then pure () + else iservCall i Shutdown + pure (IServPending (iservConfig i)) runWithPipes :: (CreateProcess -> IO ProcessHandle) -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) @@ -609,20 +623,23 @@ principle it would probably be ok, but it seems less hairy this way. -- | Creates a 'ForeignRef' that will automatically release the -- 'RemoteRef' when it is no longer referenced. mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) -mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free - where - !external = gopt Opt_ExternalInterpreter hsc_dflags - hvref = toHValueRef rref - - free :: IO () - free - | not external = freeRemoteRef hvref - | otherwise = - modifyMVar_ hsc_iserv $ \mb_iserv -> - case mb_iserv of - Nothing -> return Nothing -- already shut down - Just iserv@IServ{..} -> - return (Just iserv{iservPendingFrees = hvref : iservPendingFrees}) +mkFinalizedHValue hsc_env rref = do + let hvref = toHValueRef rref + + free <- case hsc_interp hsc_env of + Nothing -> return (pure ()) +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> return (freeRemoteRef hvref) +#endif + Just (ExternalInterp (IServ i)) -> return $ modifyMVar_ i $ \state -> + case state of + IServPending {} -> pure state -- already shut down + IServRunning inst -> do + let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst} + pure (IServRunning inst') + + mkForeignRef rref free + freeHValueRefs :: HscEnv -> [HValueRef] -> IO () freeHValueRefs _ [] = return () @@ -631,25 +648,19 @@ freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) -- | Convert a 'ForeignRef' to the value it references directly. This -- only works when the interpreter is running in the same process as -- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormhole :: DynFlags -> ForeignRef a -> IO a -wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) +wormhole :: Interp -> ForeignRef a -> IO a +wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r) -- | Convert an 'RemoteRef' to the value it references directly. This -- only works when the interpreter is running in the same process as -- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormholeRef :: DynFlags -> RemoteRef a -> IO a -wormholeRef dflags _r - | gopt Opt_ExternalInterpreter dflags - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") +wormholeRef :: Interp -> RemoteRef a -> IO a #if defined(HAVE_INTERNAL_INTERPRETER) - | otherwise - = localRef _r -#else - | otherwise - = throwIO (InstallationError - "can't wormhole a value in a stage1 compiler") +wormholeRef InternalInterp _r = localRef _r #endif +wormholeRef (ExternalInterp _) _r + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") -- ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs new file mode 100644 index 0000000000..1c9474c2e5 --- /dev/null +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} + +-- | Types used by the runtime interpreter +module GHC.Runtime.Interpreter.Types + ( Interp(..) + , IServ(..) + , IServInstance(..) + , IServConfig(..) + , IServState(..) + ) +where + +import GhcPrelude + +import GHCi.RemoteTypes +import GHCi.Message ( Pipe ) +import UniqFM +import Foreign + +import Control.Concurrent +import System.Process ( ProcessHandle, CreateProcess ) + +-- | Runtime interpreter +data Interp + = ExternalInterp !IServ -- ^ External interpreter +#if defined(HAVE_INTERNAL_INTERPRETER) + | InternalInterp -- ^ Internal interpreter +#endif + +-- | External interpreter +-- +-- The external interpreter is spawned lazily (on first use) to avoid slowing +-- down sessions that don't require it. The contents of the MVar reflects the +-- state of the interpreter (running or not). +newtype IServ = IServ (MVar IServState) + +-- | State of an external interpreter +data IServState + = IServPending !IServConfig -- ^ Not spawned yet + | IServRunning !IServInstance -- ^ Running + +-- | Configuration needed to spawn an external interpreter +data IServConfig = IServConfig + { iservConfProgram :: !String -- ^ External program to run + , iservConfOpts :: ![String] -- ^ Command-line options + , iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook + , iservConfTrace :: IO () -- ^ Trace action executed after spawn + } + +-- | External interpreter instance +data IServInstance = IServInstance + { iservPipe :: !Pipe + , iservProcess :: !ProcessHandle + , iservLookupSymbolCache :: !(UniqFM (Ptr ())) + , iservPendingFrees :: ![HValueRef] + -- ^ Values that need to be freed before the next command is sent. + -- Threads can append values to this list asynchronously (by modifying the + -- IServ state MVar). + + , iservConfig :: !IServConfig + -- ^ Config used to spawn the external interpreter + } + diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 3dcdce34d1..46e4c9fbd7 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -32,6 +32,7 @@ where import GhcPrelude import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes import GHC.Iface.Load import GHC.ByteCode.Linker @@ -193,12 +194,11 @@ linkDependencies :: HscEnv -> PersistentLinkerState linkDependencies hsc_env pls span needed_mods = do -- initDynLinker (hsc_dflags hsc_env) dl let hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. -- So here we check the build tag: if we're building a non-standard way -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags span + maybe_normal_osuf <- checkNonStdWay hsc_env span -- Find what packages and linkables are required (lnks, pkgs) <- getLinkDeps hsc_env hpt pls @@ -575,9 +575,9 @@ dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) -checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay dflags srcspan - | gopt Opt_ExternalInterpreter dflags = return Nothing +checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay hsc_env srcspan + | Just (ExternalInterp _) <- hsc_interp hsc_env = return Nothing -- with -fexternal-interpreter we load the .o files, whatever way -- they were built. If they were built for a non-std way, then -- we will use the appropriate variant of the iserv binary to load them. @@ -586,12 +586,12 @@ checkNonStdWay dflags srcspan -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) - | objectSuf dflags == normalObjectSuffix && not (null haskellWays) - = failNonStd dflags srcspan + | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null haskellWays) + = failNonStd (hsc_dflags hsc_env) srcspan | otherwise = return (Just (interpTag ++ "o")) where - haskellWays = filter (not . wayRTSOnly) (ways dflags) + haskellWays = filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env)) interpTag = case mkBuildTag interpWays of "" -> "" tag -> tag ++ "_" diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 15d0b7d5dc..c595b53c4e 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -24,9 +24,10 @@ import GhcPrelude import GHC.Driver.Session import GHC.Runtime.Linker ( linkModule, getHValue ) -import GHC.Runtime.Interpreter ( wormhole ) +import GHC.Runtime.Interpreter ( wormhole, withInterp ) +import GHC.Runtime.Interpreter.Types import SrcLoc ( noSrcSpan ) -import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) +import GHC.Driver.Finder( findPluginModule, cannotFindModule ) import TcRnMonad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface ) import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) @@ -52,7 +53,7 @@ import Outputable import Exception import GHC.Driver.Hooks -import Control.Monad ( when, unless ) +import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) @@ -103,12 +104,11 @@ loadFrontendPlugin hsc_env mod_name = do -- #14335 checkExternalInterpreter :: HscEnv -> IO () -checkExternalInterpreter hsc_env = - when (gopt Opt_ExternalInterpreter dflags) $ - throwCmdLineError $ showSDoc dflags $ - text "Plugins require -fno-external-interpreter" - where - dflags = hsc_dflags hsc_env +checkExternalInterpreter hsc_env + | Just (ExternalInterp _) <- hsc_interp hsc_env + = throwIO (InstallationError "Plugins require -fno-external-interpreter") + | otherwise + = pure () loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) loadPlugin' occ_name plugin_name hsc_env mod_name @@ -206,7 +206,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 >>= wormhole dflags + hval <- withInterp hsc_env $ \interp -> getHValue hsc_env val_name >>= wormhole interp return (Just hval) else return Nothing Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a9903b9ded..17b2334e2b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -657,3 +657,4 @@ Library GHC.Runtime.Linker GHC.Runtime.Heap.Inspect GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.Types diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 5b49699eb4..8f5af9743b 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -5,7 +5,6 @@ \section[TcAnnotations]{Typechecking annotations} -} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -24,17 +23,17 @@ import Annotations import TcRnMonad import SrcLoc import Outputable +import GHC.Driver.Types --- Some platforms don't support the external interpreter, and --- compilation on those platforms shouldn't fail just due to --- annotations -#if !defined(HAVE_INTERNAL_INTERPRETER) +-- Some platforms don't support the interpreter, and compilation on those +-- platforms shouldn't fail just due to annotations tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations anns = do - dflags <- getDynFlags - case gopt Opt_ExternalInterpreter dflags of - True -> tcAnnotations' anns - False -> warnAnns anns + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Just _ -> mapM tcAnnotation anns + Nothing -> warnAnns anns + warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] @@ -43,13 +42,6 @@ warnAnns anns@(L loc _ : _) (text "Ignoring ANN annotation" <> plural anns <> comma <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } -#else -tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations = tcAnnotations' -#endif - -tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations' anns = mapM tcAnnotation anns tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ecbf07c36d..a4ea37db72 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -7,6 +7,7 @@ TcSplice: Template Haskell splices -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -58,6 +59,7 @@ import Control.Monad import GHCi.Message import GHCi.RemoteTypes import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types import GHC.Driver.Main -- These imports are the reason that TcSplice -- is very high up the module hierarchy @@ -122,8 +124,11 @@ import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH +#if defined(HAVE_INTERNAL_INTERPRETER) -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler import GHC.Desugar ( AnnotationWrapper(..) ) +import Unsafe.Coerce ( unsafeCoerce ) +#endif import Control.Exception import Data.Binary @@ -135,7 +140,6 @@ import qualified Data.Map as Map import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) -import Unsafe.Coerce ( unsafeCoerce ) {- ************************************************************************ @@ -770,12 +774,12 @@ runAnnotation target expr = do convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) convertAnnotationWrapper fhv = do - dflags <- getDynFlags - if gopt Opt_ExternalInterpreter dflags - then do - Right <$> runTH THAnnWrapper fhv - else do - annotation_wrapper <- liftIO $ wormhole dflags fhv + interp <- tcGetInterp + case interp of + ExternalInterp _ -> Right <$> runTH THAnnWrapper fhv +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + annotation_wrapper <- liftIO $ wormhole InternalInterp fhv return $ Right $ case unsafeCoerce annotation_wrapper of AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> @@ -791,6 +795,7 @@ convertAnnotationWrapper fhv = do seqSerialized :: Serialized -> () seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () +#endif {- ************************************************************************ @@ -805,13 +810,18 @@ runQuasi act = TH.runQ act runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do - dflags <- getDynFlags let withForeignRefs [] f = f [] withForeignRefs (x : xs) f = withForeignRef x $ \r -> withForeignRefs xs $ \rs -> f (r : rs) - if gopt Opt_ExternalInterpreter dflags then do - hsc_env <- env_top <$> getEnv - withIServ hsc_env $ \i -> do + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs +#endif + + ExternalInterp iserv -> withIServ_ iserv $ \i -> do tcg <- getGblEnv th_state <- readTcRef (tcg_th_remote_state tcg) case th_state of @@ -822,9 +832,6 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do writeIServ i (putMessage (RunModFinalizers st qrefs)) () <- runRemoteTH i [] readQResult i - else do - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs runQResult :: (a -> String) @@ -1159,7 +1166,7 @@ instance TH.Quasi TcM where addModFinalizerRef fref qAddCorePlugin plugin = do - hsc_env <- env_top <$> getEnv + hsc_env <- getTopEnv r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) let err = hang (text "addCorePlugin: invalid plugin module " @@ -1206,10 +1213,16 @@ addModFinalizerRef finRef = do -- | Releases the external interpreter state. finishTH :: TcM () finishTH = do - dflags <- getDynFlags - when (gopt Opt_ExternalInterpreter dflags) $ do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp _) -> do + tcg <- getGblEnv + writeTcRef (tcg_th_remote_state tcg) Nothing + runTHExp :: ForeignHValue -> TcM TH.Exp runTHExp = runTH THExp @@ -1225,19 +1238,21 @@ runTHDec = runTH THDec runTH :: Binary a => THResultType -> ForeignHValue -> TcM a runTH ty fhv = do - hsc_env <- env_top <$> getEnv - dflags <- getDynFlags - if not (gopt Opt_ExternalInterpreter dflags) - then do + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do -- Run it in the local TcM - hv <- liftIO $ wormhole dflags fhv + hv <- liftIO $ wormhole InternalInterp fhv r <- runQuasi (unsafeCoerce hv :: TH.Q a) return r - else +#endif + + ExternalInterp iserv -> -- Run it on the server. For an overview of how TH works with -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. - withIServ hsc_env $ \i -> do + withIServ_ iserv $ \i -> do rstate <- getTHState i loc <- TH.qLocation liftIO $ @@ -1252,7 +1267,7 @@ runTH ty fhv = do -- | communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH - :: IServ + :: IServInstance -> [Messages] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do @@ -1281,7 +1296,7 @@ runRemoteTH iserv recovers = do runRemoteTH iserv recovers -- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServ -> TcM a +readQResult :: Binary a => IServInstance -> TcM a readQResult i = do qr <- liftIO $ readIServ i get case qr of @@ -1330,14 +1345,14 @@ Back in GHC, when we receive: -- -- The TH state is stored in tcg_th_remote_state in the TcGblEnv. -- -getTHState :: IServ -> TcM (ForeignRef (IORef QState)) +getTHState :: IServInstance -> TcM (ForeignRef (IORef QState)) getTHState i = do tcg <- getGblEnv th_state <- readTcRef (tcg_th_remote_state tcg) case th_state of Just rhv -> return rhv Nothing -> do - hsc_env <- env_top <$> getEnv + hsc_env <- getTopEnv fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH writeTcRef (tcg_th_remote_state tcg) (Just fhv) return fhv @@ -1366,7 +1381,7 @@ handleTHMessage msg = case msg of AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f AddTempFile s -> wrapTHResult $ TH.qAddTempFile s AddModFinalizer r -> do - hsc_env <- env_top <$> getEnv + hsc_env <- getTopEnv wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs @@ -2361,3 +2376,10 @@ 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. -} + +tcGetInterp :: TcM Interp +tcGetInterp = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") + Just i -> pure i diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 7793b7183a..67903c80bf 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -37,6 +37,7 @@ import GHC.Runtime.Debugger -- The GHC interface import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes import GHCi.BreakArray import GHC.Driver.Session as DynFlags @@ -53,7 +54,7 @@ import GHC.Hs.ImpExp import GHC.Hs import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc, - hsc_dynLinker ) + hsc_dynLinker, hsc_interp ) import Module import Name import GHC.Driver.Packages ( trusted, getPackageDetails, getInstalledPackageDetails, @@ -1559,14 +1560,15 @@ changeDirectory dir = do GHC.workingDirectoryChanged dir' <- expandPath dir liftIO $ setCurrentDirectory dir' - dflags <- getDynFlags -- With -fexternal-interpreter, we have to change the directory of the subprocess too. -- (this gives consistent behaviour with and without -fexternal-interpreter) - when (gopt Opt_ExternalInterpreter dflags) $ do - hsc_env <- GHC.getSession - fhv <- compileGHCiExpr $ - "System.Directory.setCurrentDirectory " ++ show dir' - liftIO $ evalIO hsc_env fhv + hsc_env <- GHC.getSession + case hsc_interp hsc_env of + Just (ExternalInterp {}) -> do + fhv <- compileGHCiExpr $ + "System.Directory.setCurrentDirectory " ++ show dir' + liftIO $ evalIO hsc_env fhv + _ -> pure () trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = |