From 27f79255634d9789f367273504545c1ebfad90a0 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Tue, 20 Dec 2016 01:19:18 +0000 Subject: Allow use of the external interpreter in stage1. Summary: Now that we have -fexternal-interpreter, we can lose most of the GHCI ifdefs. This was originally added in https://phabricator.haskell.org/D2826 but that led to a compatibility issue with ghc 7.10.x on Windows. That's fixed here and the revert reverted. Reviewers: goldfire, hvr, austin, bgamari, Phyx Reviewed By: Phyx Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D2884 GHC Trac Issues: #13008 --- compiler/ghci/ByteCodeGen.hs | 4 + compiler/ghci/ByteCodeInstr.hs | 4 + compiler/ghci/ByteCodeTypes.hs | 6 +- compiler/ghci/GHCi.hs | 622 -------------------------------------- compiler/ghci/GHCi.hsc | 670 +++++++++++++++++++++++++++++++++++++++++ compiler/ghci/Linker.hs | 10 + 6 files changed, 693 insertions(+), 623 deletions(-) delete mode 100644 compiler/ghci/GHCi.hs create mode 100644 compiler/ghci/GHCi.hsc (limited to 'compiler/ghci') diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 0e7aea493e..9a5e4141f1 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -66,7 +66,11 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified FiniteMap as Map import Data.Ord +#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS +#else +import GHC.Stack as GHC.Stack.CCS +#endif -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index f1f6f70e57..43444321de 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -30,7 +30,11 @@ import PrimOp import SMRep import Data.Word +#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS (CostCentre) +#else +import GHC.Stack (CostCentre) +#endif -- ---------------------------------------------------------------------------- -- Bytecode instructions diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index 3537a2bff3..ec962c886b 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -34,7 +34,11 @@ import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS +#else +import GHC.Stack as GHC.Stack.CCS +#endif -- ----------------------------------------------------------------------------- -- Compiled Byte Code diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs deleted file mode 100644 index 472251db04..0000000000 --- a/compiler/ghci/GHCi.hs +++ /dev/null @@ -1,622 +0,0 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} - --- --- | Interacting with the interpreter, whether it is running on an --- external process or in the current process. --- -module GHCi - ( -- * High-level interface to the interpreter - evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) - , resumeStmt - , abandonStmt - , evalIO - , evalString - , evalStringToIOString - , mallocData - , createBCOs - , mkCostCentres - , costCentreStackInfo - , newBreakArray - , enableBreakpoint - , breakpointStatus - , getBreakpointVar - - -- * The object-code linker - , initObjLinker - , lookupSymbol - , lookupClosure - , loadDLL - , loadArchive - , loadObj - , unloadObj - , addLibrarySearchPath - , removeLibrarySearchPath - , resolveObjs - , findSystemLibrary - - -- * Lower-level API using messages - , iservCmd, Message(..), withIServ, stopIServ - , iservCall, readIServ, writeIServ - , purgeLookupSymbolCache - , freeHValueRefs - , mkFinalizedHValue - , wormhole, wormholeRef - , mkEvalOpts - , fromEvalResult - ) where - -import GHCi.Message -import GHCi.Run -import GHCi.RemoteTypes -import GHCi.ResolvedBCO -import GHCi.BreakArray (BreakArray) -import HscTypes -import UniqFM -import Panic -import DynFlags -import ErrUtils -import Outputable -import Exception -import BasicTypes -import FastString -import Util -import Hooks - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Binary -import Data.Binary.Put -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.IORef -import Foreign hiding (void) -import GHC.Stack.CCS (CostCentre,CostCentreStack) -import System.Exit -import Data.Maybe -import GHC.IO.Handle.Types (Handle) -#ifdef mingw32_HOST_OS -import Foreign.C -import GHC.IO.Handle.FD (fdToHandle) -#else -import System.Posix as Posix -#endif -import System.Directory -import System.Process -import GHC.Conc (getNumProcessors, pseq, par) - -{- Note [Remote GHCi] - -When the flag -fexternal-interpreter is given to GHC, interpreted code -is run in a separate process called iserv, and we communicate with the -external process over a pipe using Binary-encoded messages. - -Motivation -~~~~~~~~~~ - -When the interpreted code is running in a separate process, it can -use a different "way", e.g. profiled or dynamic. This means - -- compiling Template Haskell code with -prof does not require - building the code without -prof first - -- when GHC itself is profiled, it can interpret unprofiled code, - and the same applies to dynamic linking. - -- An unprofiled GHCi can load and run profiled code, which means it - can use the stack-trace functionality provided by profiling without - taking the performance hit on the compiler that profiling would - entail. - -For other reasons see RemoteGHCi on the wiki. - -Implementation Overview -~~~~~~~~~~~~~~~~~~~~~~~ - -The main pieces are: - -- libraries/ghci, containing: - - types for talking about remote values (GHCi.RemoteTypes) - - the message protocol (GHCi.Message), - - implementation of the messages (GHCi.Run) - - implementation of Template Haskell (GHCi.TH) - - a few other things needed to run interpreted code - -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality - is provided by modules in libraries/ghci. - -- This module (GHCi) which provides the interface to the server used - by the rest of GHC. - -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, -interpreted code is run in the same process as GHC. - -Things that do not work with -fexternal-interpreter -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error -message if it is used with -fexternal-interpreter. - -Other Notes on Remote GHCi -~~~~~~~~~~~~~~~~~~~~~~~~~~ - * This wiki page has an implementation overview: - https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter - * Note [External GHCi pointers] in compiler/ghci/GHCi.hs - * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs --} - --- | Run a command in the interpreter's context. With --- @-fexternal-interpreter@, the command is serialized and sent to an --- external iserv process, and the response is deserialized (hence the --- @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 - run msg - - --- 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 --- 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. - --- | Grab a lock on the 'IServ' and do something with it. --- 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 = - 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) - -- 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') - return a - - --- ----------------------------------------------------------------------------- --- Wrappers around messages - --- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for --- each of the results. -evalStmt - :: HscEnv -> Bool -> EvalExpr ForeignHValue - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -evalStmt hsc_env step foreign_expr = do - let dflags = hsc_dflags hsc_env - status <- withExpr foreign_expr $ \expr -> - iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) - handleEvalStatus hsc_env status - where - withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a - withExpr (EvalThis fhv) cont = - withForeignRef fhv $ \hvref -> cont (EvalThis hvref) - withExpr (EvalApp fl fr) cont = - withExpr fl $ \fl' -> - withExpr fr $ \fr' -> - cont (EvalApp fl' fr') - -resumeStmt - :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -resumeStmt hsc_env step resume_ctxt = do - let dflags = hsc_dflags hsc_env - status <- withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) - handleEvalStatus hsc_env status - -abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () -abandonStmt hsc_env resume_ctxt = do - withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (AbandonStmt rhv) - -handleEvalStatus - :: HscEnv -> EvalStatus [HValueRef] - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -handleEvalStatus hsc_env status = - case status of - EvalBreak a b c d e f -> return (EvalBreak a b c d e f) - EvalComplete alloc res -> - EvalComplete alloc <$> addFinalizer res - where - addFinalizer (EvalException e) = return (EvalException e) - addFinalizer (EvalSuccess rs) = do - EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs - --- | Execute an action of type @IO ()@ -evalIO :: HscEnv -> ForeignHValue -> IO () -evalIO hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult - --- | Execute an action of type @IO String@ -evalString :: HscEnv -> ForeignHValue -> IO String -evalString hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalString fhv) >>= fromEvalResult - --- | Execute an action of type @String -> IO String@ -evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String -evalStringToIOString hsc_env fhv str = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult - - --- | Allocate and store the given bytes in memory, returning a pointer --- to the memory in the remote process. -mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) -mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) - -mkCostCentres - :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres hsc_env mod ccs = - iservCmd hsc_env (MkCostCentres mod ccs) - --- | Create a set of BCOs that may be mutually recursive. -createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] -createBCOs hsc_env rbcos = do - n_jobs <- case parMakeCount (hsc_dflags hsc_env) of - Nothing -> liftIO getNumProcessors - Just n -> return n - -- Serializing ResolvedBCO is expensive, so if we're in parallel mode - -- (-j) parallelise the serialization. - if (n_jobs == 1) - then - iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) - - else do - old_caps <- getNumCapabilities - if old_caps == n_jobs - then void $ evaluate puts - else bracket_ (setNumCapabilities n_jobs) - (setNumCapabilities old_caps) - (void $ evaluate puts) - iservCmd hsc_env (CreateBCOs puts) - where - puts = parMap doChunk (chunkList 100 rbcos) - - -- make sure we force the whole lazy ByteString - doChunk c = pseq (LB.length bs) bs - where bs = runPut (put c) - - -- We don't have the parallel package, so roll our own simple parMap - parMap _ [] = [] - parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) - where fx = f x; fxs = parMap f xs - -costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] -costCentreStackInfo hsc_env ccs = - iservCmd hsc_env (CostCentreStackInfo ccs) - -newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) -newBreakArray hsc_env size = do - breakArray <- iservCmd hsc_env (NewBreakArray size) - mkFinalizedHValue hsc_env breakArray - -enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () -enableBreakpoint hsc_env ref ix b = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (EnableBreakpoint breakarray ix b) - -breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool -breakpointStatus hsc_env ref ix = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (BreakpointStatus breakarray ix) - -getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) -getBreakpointVar hsc_env ref ix = - withForeignRef ref $ \apStack -> do - mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) - mapM (mkFinalizedHValue hsc_env) mb - --- ----------------------------------------------------------------------------- --- Interface to the object-code linker - -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 = - fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) - -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 - - --- | loadDLL loads a dynamic library using the OS's native linker --- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either --- an absolute pathname to the file, or a relative filename --- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL --- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) - -loadArchive :: HscEnv -> String -> IO () -loadArchive hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadArchive path') - -loadObj :: HscEnv -> String -> IO () -loadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadObj path') - -unloadObj :: HscEnv -> String -> IO () -unloadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (UnloadObj path') - --- Note [loadObj and relative paths] --- the iserv process might have a different current directory from the --- GHC process, so we must make paths absolute before sending them --- over. - -addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) -addLibrarySearchPath hsc_env str = - fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) - -removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool -removeLibrarySearchPath hsc_env p = - iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) - -resolveObjs :: HscEnv -> IO SuccessFlag -resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs - -findSystemLibrary :: HscEnv -> String -> IO (Maybe String) -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 - `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 - `catch` \(e :: SomeException) -> handleIServFailure iserv e - --- | Send a value to the iserv process -writeIServ :: IServ -> Put -> IO () -writeIServ iserv@IServ{..} put = - writePipe iservPipe put - `catch` \(e :: SomeException) -> handleIServFailure iserv e - -handleIServFailure :: IServ -> SomeException -> IO a -handleIServFailure IServ{..} e = do - ex <- getProcessExitCode iservProcess - case ex of - Just (ExitFailure n) -> - throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) - _ -> do - terminateProcess iservProcess - _ <- waitForProcess iservProcess - 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 - 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 = [] - } - -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 - -runWithPipes :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -#ifdef mingw32_HOST_OS -foreign import ccall "io.h _close" - c__close :: CInt -> IO CInt - -foreign import ccall unsafe "io.h _get_osfhandle" - _get_osfhandle :: CInt -> IO CInt - -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- createPipeFd -- we read on rfd1 - (rfd2, wfd2) <- createPipeFd -- we write on wfd2 - wh_client <- _get_osfhandle wfd1 - rh_client <- _get_osfhandle rfd2 - let args = show wh_client : show rh_client : opts - ph <- createProc (proc prog args) - rh <- mkHandle rfd1 - wh <- mkHandle wfd2 - return (ph, rh, wh) - where mkHandle :: CInt -> IO Handle - mkHandle fd = (fdToHandle fd) `onException` (c__close fd) -#else -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 - (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 - setFdOption rfd1 CloseOnExec True - setFdOption wfd2 CloseOnExec True - let args = show wfd1 : show rfd2 : opts - ph <- createProc (proc prog args) - closeFd wfd1 - closeFd rfd2 - rh <- fdToHandle rfd1 - wh <- fdToHandle wfd2 - return (ph, rh, wh) -#endif - --- ----------------------------------------------------------------------------- -{- Note [External GHCi pointers] - -We have the following ways to reference things in GHCi: - -HValue ------- - -HValue is a direct reference to an value in the local heap. Obviously -we cannot use this to refer to things in the external process. - - -RemoteRef ---------- - -RemoteRef is a StablePtr to a heap-resident value. When --fexternal-interpreter is used, this value resides in the external -process's heap. RemoteRefs are mostly used to send pointers in -messages between GHC and iserv. - -A RemoteRef must be explicitly freed when no longer required, using -freeHValueRefs, or by attaching a finalizer with mkForeignHValue. - -To get from a RemoteRef to an HValue you can use 'wormholeRef', which -fails with an error message if -fexternal-interpreter is in use. - -ForeignRef ----------- - -A ForeignRef is a RemoteRef with a finalizer that will free the -'RemoteRef' when it is gargabe collected. We mostly use ForeignHValue -on the GHC side. - -The finalizer adds the RemoteRef to the iservPendingFrees list in the -IServ record. The next call to iservCmd will free any RemoteRefs in -the list. It was done this way rather than calling iservCmd directly, -because I didn't want to have arbitrary threads calling iservCmd. In -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}) - -freeHValueRefs :: HscEnv -> [HValueRef] -> IO () -freeHValueRefs _ [] = return () -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) - --- | 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") - | otherwise - = localRef r - --- ----------------------------------------------------------------------------- --- Misc utils - -mkEvalOpts :: DynFlags -> Bool -> EvalOpts -mkEvalOpts dflags step = - EvalOpts - { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step - , breakOnException = gopt Opt_BreakOnException dflags - , breakOnError = gopt Opt_BreakOnError dflags } - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hsc new file mode 100644 index 0000000000..4503034971 --- /dev/null +++ b/compiler/ghci/GHCi.hsc @@ -0,0 +1,670 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} + +-- +-- | Interacting with the interpreter, whether it is running on an +-- external process or in the current process. +-- +module GHCi + ( -- * High-level interface to the interpreter + evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) + , resumeStmt + , abandonStmt + , evalIO + , evalString + , evalStringToIOString + , mallocData + , createBCOs + , mkCostCentres + , costCentreStackInfo + , newBreakArray + , enableBreakpoint + , breakpointStatus + , getBreakpointVar + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + -- * Lower-level API using messages + , iservCmd, Message(..), withIServ, stopIServ + , iservCall, readIServ, writeIServ + , purgeLookupSymbolCache + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , mkEvalOpts + , fromEvalResult + ) where + +import GHCi.Message +#ifdef GHCI +import GHCi.Run +#endif +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray (BreakArray) +import HscTypes +import UniqFM +import Panic +import DynFlags +import ErrUtils +import Outputable +import Exception +import BasicTypes +import FastString +import Util +import Hooks + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Binary +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.IORef +import Foreign hiding (void) +#if MIN_VERSION_base(4,9,0) +import GHC.Stack.CCS (CostCentre,CostCentreStack) +#else +import GHC.Stack (CostCentre,CostCentreStack) +#endif +import System.Exit +import Data.Maybe +import GHC.IO.Handle.Types (Handle) +#ifdef mingw32_HOST_OS +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +#if !MIN_VERSION_process(1,4,2) +import System.Posix.Internals +import Foreign.Marshal.Array +import Foreign.C.Error +import Foreign.Storable +#endif +#else +import System.Posix as Posix +#endif +import System.Directory +import System.Process +import GHC.Conc (getNumProcessors, pseq, par) + +{- Note [Remote GHCi] + +When the flag -fexternal-interpreter is given to GHC, interpreted code +is run in a separate process called iserv, and we communicate with the +external process over a pipe using Binary-encoded messages. + +Motivation +~~~~~~~~~~ + +When the interpreted code is running in a separate process, it can +use a different "way", e.g. profiled or dynamic. This means + +- compiling Template Haskell code with -prof does not require + building the code without -prof first + +- when GHC itself is profiled, it can interpret unprofiled code, + and the same applies to dynamic linking. + +- An unprofiled GHCi can load and run profiled code, which means it + can use the stack-trace functionality provided by profiling without + taking the performance hit on the compiler that profiling would + entail. + +For other reasons see RemoteGHCi on the wiki. + +Implementation Overview +~~~~~~~~~~~~~~~~~~~~~~~ + +The main pieces are: + +- libraries/ghci, containing: + - types for talking about remote values (GHCi.RemoteTypes) + - the message protocol (GHCi.Message), + - implementation of the messages (GHCi.Run) + - implementation of Template Haskell (GHCi.TH) + - a few other things needed to run interpreted code + +- top-level iserv directory, containing the codefor the external + server. This is a fairly simple wrapper, most of the functionality + is provided by modules in libraries/ghci. + +- This module (GHCi) which provides the interface to the server used + by the rest of GHC. + +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, +interpreted code is run in the same process as GHC. + +Things that do not work with -fexternal-interpreter +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +dynCompileExpr cannot work, because we have no way to run code of an +unknown type in the remote process. This API fails with an error +message if it is used with -fexternal-interpreter. + +Other Notes on Remote GHCi +~~~~~~~~~~~~~~~~~~~~~~~~~~ + * This wiki page has an implementation overview: + https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter + * Note [External GHCi pointers] in compiler/ghci/GHCi.hs + * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs +-} + +#ifndef GHCI +needExtInt :: IO a +needExtInt = throwIO + (InstallationError "this operation requires -fexternal-interpreter") +#endif + +-- | Run a command in the interpreter's context. With +-- @-fexternal-interpreter@, the command is serialized and sent to an +-- external iserv process, and the response is deserialized (hence the +-- @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 +#ifdef GHCI + run msg +#else + needExtInt +#endif + +-- 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 +-- 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. + +-- | Grab a lock on the 'IServ' and do something with it. +-- 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 = + 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) + -- 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') + return a + + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: HscEnv -> Bool -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +evalStmt hsc_env step foreign_expr = do + let dflags = hsc_dflags hsc_env + status <- withExpr foreign_expr $ \expr -> + iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) + handleEvalStatus hsc_env status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt + :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +resumeStmt hsc_env step resume_ctxt = do + let dflags = hsc_dflags hsc_env + status <- withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) + handleEvalStatus hsc_env status + +abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () +abandonStmt hsc_env resume_ctxt = do + withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (AbandonStmt rhv) + +handleEvalStatus + :: HscEnv -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +handleEvalStatus hsc_env status = + case status of + EvalBreak a b c d e f -> return (EvalBreak a b c d e f) + EvalComplete alloc res -> + EvalComplete alloc <$> addFinalizer res + where + addFinalizer (EvalException e) = return (EvalException e) + addFinalizer (EvalSuccess rs) = do + EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs + +-- | Execute an action of type @IO ()@ +evalIO :: HscEnv -> ForeignHValue -> IO () +evalIO hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult + +-- | Execute an action of type @IO String@ +evalString :: HscEnv -> ForeignHValue -> IO String +evalString hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalString fhv) >>= fromEvalResult + +-- | Execute an action of type @String -> IO String@ +evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String +evalStringToIOString hsc_env fhv str = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult + + +-- | Allocate and store the given bytes in memory, returning a pointer +-- to the memory in the remote process. +mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) +mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) + +mkCostCentres + :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres hsc_env mod ccs = + iservCmd hsc_env (MkCostCentres mod ccs) + +-- | Create a set of BCOs that may be mutually recursive. +createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] +createBCOs hsc_env rbcos = do + n_jobs <- case parMakeCount (hsc_dflags hsc_env) of + Nothing -> liftIO getNumProcessors + Just n -> return n + -- Serializing ResolvedBCO is expensive, so if we're in parallel mode + -- (-j) parallelise the serialization. + if (n_jobs == 1) + then + iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) + + else do + old_caps <- getNumCapabilities + if old_caps == n_jobs + then void $ evaluate puts + else bracket_ (setNumCapabilities n_jobs) + (setNumCapabilities old_caps) + (void $ evaluate puts) + iservCmd hsc_env (CreateBCOs puts) + where + puts = parMap doChunk (chunkList 100 rbcos) + + -- make sure we force the whole lazy ByteString + doChunk c = pseq (LB.length bs) bs + where bs = runPut (put c) + + -- We don't have the parallel package, so roll our own simple parMap + parMap _ [] = [] + parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) + where fx = f x; fxs = parMap f xs + +costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] +costCentreStackInfo hsc_env ccs = + iservCmd hsc_env (CostCentreStackInfo ccs) + +newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) +newBreakArray hsc_env size = do + breakArray <- iservCmd hsc_env (NewBreakArray size) + mkFinalizedHValue hsc_env breakArray + +enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () +enableBreakpoint hsc_env ref ix b = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (EnableBreakpoint breakarray ix b) + +breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool +breakpointStatus hsc_env ref ix = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (BreakpointStatus breakarray ix) + +getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) +getBreakpointVar hsc_env ref ix = + withForeignRef ref $ \apStack -> do + mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) + mapM (mkFinalizedHValue hsc_env) mb + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +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 = +#ifdef GHCI + fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) +#else + needExtInt +#endif + +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 + + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +-- Returns: +-- +-- Nothing => success +-- Just err_msg => failure +loadDLL :: HscEnv -> String -> IO (Maybe String) +loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) + +loadArchive :: HscEnv -> String -> IO () +loadArchive hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadArchive path') + +loadObj :: HscEnv -> String -> IO () +loadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadObj path') + +unloadObj :: HscEnv -> String -> IO () +unloadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (UnloadObj path') + +-- Note [loadObj and relative paths] +-- the iserv process might have a different current directory from the +-- GHC process, so we must make paths absolute before sending them +-- over. + +addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) +addLibrarySearchPath hsc_env str = + fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) + +removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool +removeLibrarySearchPath hsc_env p = + iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) + +resolveObjs :: HscEnv -> IO SuccessFlag +resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs + +findSystemLibrary :: HscEnv -> String -> IO (Maybe String) +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 + `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 + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Send a value to the iserv process +writeIServ :: IServ -> Put -> IO () +writeIServ iserv@IServ{..} put = + writePipe iservPipe put + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +handleIServFailure :: IServ -> SomeException -> IO a +handleIServFailure IServ{..} e = do + ex <- getProcessExitCode iservProcess + case ex of + Just (ExitFailure n) -> + throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess iservProcess + _ <- waitForProcess iservProcess + 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 + 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 = [] + } + +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 + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) +#ifdef mingw32_HOST_OS +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt + +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO CInt + +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- createPipeFd -- we read on rfd1 + (rfd2, wfd2) <- createPipeFd -- we write on wfd2 + wh_client <- _get_osfhandle wfd1 + rh_client <- _get_osfhandle rfd2 + let args = show wh_client : show rh_client : opts + ph <- createProc (proc prog args) + rh <- mkHandle rfd1 + wh <- mkHandle wfd2 + return (ph, rh, wh) + where mkHandle :: CInt -> IO Handle + mkHandle fd = (fdToHandle fd) `onException` (c__close fd) + +#if !MIN_VERSION_process(1,4,2) +-- This #include and the _O_BINARY below are the only reason this is hsc, +-- so we can remove that once we can depend on process 1.4.2 +#include + +createPipeFd :: IO (FD, FD) +createPipeFd = do + allocaArray 2 $ \ pfds -> do + throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY) + readfd <- peek pfds + writefd <- peekElemOff pfds 1 + return (readfd, writefd) + +foreign import ccall "io.h _pipe" c__pipe :: + Ptr CInt -> CUInt -> CInt -> IO CInt +#endif +#else +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = show wfd1 : show rfd2 : opts + ph <- createProc (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + return (ph, rh, wh) +#endif + +-- ----------------------------------------------------------------------------- +{- Note [External GHCi pointers] + +We have the following ways to reference things in GHCi: + +HValue +------ + +HValue is a direct reference to an value in the local heap. Obviously +we cannot use this to refer to things in the external process. + + +RemoteRef +--------- + +RemoteRef is a StablePtr to a heap-resident value. When +-fexternal-interpreter is used, this value resides in the external +process's heap. RemoteRefs are mostly used to send pointers in +messages between GHC and iserv. + +A RemoteRef must be explicitly freed when no longer required, using +freeHValueRefs, or by attaching a finalizer with mkForeignHValue. + +To get from a RemoteRef to an HValue you can use 'wormholeRef', which +fails with an error message if -fexternal-interpreter is in use. + +ForeignRef +---------- + +A ForeignRef is a RemoteRef with a finalizer that will free the +'RemoteRef' when it is gargabe collected. We mostly use ForeignHValue +on the GHC side. + +The finalizer adds the RemoteRef to the iservPendingFrees list in the +IServ record. The next call to iservCmd will free any RemoteRefs in +the list. It was done this way rather than calling iservCmd directly, +because I didn't want to have arbitrary threads calling iservCmd. In +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}) + +freeHValueRefs :: HscEnv -> [HValueRef] -> IO () +freeHValueRefs _ [] = return () +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) + +-- | 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") +#ifdef GHCI + | otherwise + = localRef r +#else + | otherwise + = throwIO (InstallationError + "can't wormhole a value in a stage1 compiler") +#endif + +-- ----------------------------------------------------------------------------- +-- Misc utils + +mkEvalOpts :: DynFlags -> Bool -> EvalOpts +mkEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = step + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags } + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 7379c46772..6a0483ce1b 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -709,6 +709,16 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) adjust_ul _ l@(BCOs {}) = return l +#if !MIN_VERSION_filepath(1,4,1) + stripExtension :: String -> FilePath -> Maybe FilePath + stripExtension [] path = Just path + stripExtension ext@(x:_) path = stripSuffix dotExt path + where dotExt = if isExtSeparator x then ext else '.':ext + + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) +#endif + {- ********************************************************************** -- cgit v1.2.1