diff --git a/FilePathCaching.hs b/FilePathCaching.hs --- a/FilePathCaching.hs +++ b/FilePathCaching.hs @@ -1,6 +1,7 @@ module FilePathCaching ( MonadFilePathCaching(..) , mkFilePathPtr + , extractEitherSpan , extractSourceSpan ) where @@ -46,15 +47,24 @@ Just key -> return $ FilePathPtr key -extractSourceSpan :: MonadFilePathCaching m => SrcSpan -> m EitherSpan -extractSourceSpan (RealSrcSpan srcspan) = do +extractEitherSpan :: MonadFilePathCaching m => SrcSpan -> m EitherSpan +extractEitherSpan (RealSrcSpan srcspan) = do key <- mkFilePathPtr $ unpackFS (srcSpanFile srcspan) return . ProperSpan $ SourceSpan key (srcSpanStartLine srcspan) (srcSpanStartCol srcspan) (srcSpanEndLine srcspan) (srcSpanEndCol srcspan) -extractSourceSpan (UnhelpfulSpan s) = +extractEitherSpan (UnhelpfulSpan s) = return . TextSpan $ fsToText s + +extractSourceSpan:: MonadFilePathCaching m => RealSrcSpan -> m SourceSpan +extractSourceSpan srcspan = do + key <- mkFilePathPtr $ unpackFS (srcSpanFile srcspan) + return $ SourceSpan + key + (srcSpanStartLine srcspan) (srcSpanStartCol srcspan) + (srcSpanEndLine srcspan) (srcSpanEndCol srcspan) + fsToText :: FastString -> Text fsToText = Text.pack . unpackFS diff --git a/GhcShim.hs b/GhcShim.hs --- a/GhcShim.hs +++ b/GhcShim.hs @@ -50,7 +50,7 @@ #ifdef GHC_710 import GhcShim.GhcShim710 #else -#error "Unsupported GHC version" +#error "No GHC_* CPP flag specified, possibly using an unsupported GHC version" #endif #endif #endif diff --git a/HsWalk.hs b/HsWalk.hs --- a/HsWalk.hs +++ b/HsWalk.hs @@ -136,9 +136,15 @@ extractIdsResumeTc stRef $ go span return qq where +#ifdef GHC_AFTER_710_1 + go :: RealSrcSpan -> ExtractIdsM () + go span = do + span' <- extractSourceSpan span +#else go :: SrcSpan -> ExtractIdsM () go span = do - ProperSpan span' <- extractSourceSpan span + ProperSpan span' <- extractEitherSpan span +#endif dflags <- asks eIdsDynFlags linkEnv <- asks eIdsLinkEnv rdrEnv <- asks eIdsRdrEnv @@ -397,7 +403,7 @@ recordExpType :: SrcSpan -> Maybe Type -> ExtractIdsM (Maybe Type) recordExpType span (Just typ) = do - eitherSpan <- extractSourceSpan span + eitherSpan <- extractEitherSpan span case eitherSpan of ProperSpan properSpan -> do prettyTyp <- tidyType typ >>= showTypeForUser @@ -455,7 +461,7 @@ -> m (IdPropPtr, Maybe IdScope) -- ^ Nothing if imported but no GlobalRdrElt idInfoForName dflags name idIsBinder mElt mCurrent home = do scope <- constructScope - idDefSpan <- extractSourceSpan (Name.nameSrcSpan name) + idDefSpan <- extractEitherSpan (Name.nameSrcSpan name) let mod = if isLocal scope then fromJust mCurrent @@ -501,8 +507,8 @@ extractImportInfo :: [RdrName.ImportSpec] -> m (GHC.ModuleName, EitherSpan, String) extractImportInfo (RdrName.ImpSpec decl item:_) = do span <- case item of - RdrName.ImpAll -> extractSourceSpan (RdrName.is_dloc decl) - RdrName.ImpSome _explicit loc -> extractSourceSpan loc + RdrName.ImpAll -> extractEitherSpan (RdrName.is_dloc decl) + RdrName.ImpSome _explicit loc -> extractEitherSpan loc return ( RdrName.is_mod decl , span @@ -563,7 +569,7 @@ -> IsBinder -> Located Name -> ExtractIdsM (Maybe Type) recordName mkSpanInfo idIsBinder (L span name) = do - span' <- extractSourceSpan span + span' <- extractEitherSpan span case span' of ProperSpan sourceSpan -> do dflags <- getDynFlags diff --git a/Posix.hsc b/Posix.hsc new file mode 100644 --- /dev/null +++ b/Posix.hsc @@ -0,0 +1,197 @@ +{- + +Modified by Michael Sloan, FP Complete, in 2015 + +Copyright 2012-2013 Google Inc. All Rights Reserved. +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + http://www.apache.org/licenses/LICENSE-2.0 +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +-} + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | Modified by Michael Sloan, FP Complete, in 2015 +-- +-- Based on https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/System/Posix/Missing.hsc +module Posix ( + dupFd, dupFdCloseOnExec, + + loginTerminal, + setControllingTerminal, + + getArg0, + executeFile0, + -- * From Plush.Run.Posix.IO + write, + readChunk + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import Control.Exception (throwIO) +import Control.Monad (when, void) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Internal as BS (createAndTrim) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign (withArray0, withMany) +import Foreign.C (CInt(..), CString, CULong(..), + throwErrnoIfMinus1, throwErrnoIfMinus1_, throwErrnoPathIfMinus1_) +import Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr) +import Foreign.Ptr (nullPtr, Ptr) +import Foreign.Safe (alloca, peek, peekElemOff) +import GHC.Foreign (peekCString) +import GHC.IO.Device (SeekMode(SeekFromEnd, AbsoluteSeek)) +import GHC.IO.Encoding (getFileSystemEncoding) +import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) +import System.IO.Error (ioeGetErrorType, catchIOError) +import System.Posix.IO (fdReadBuf, fdSeek, fdWriteBuf, setFdOption, FdOption(CloseOnExec)) +import System.Posix.Internals (c_fcntl_write, FD, withFilePath) +import System.Posix.Process.Internals (pPrPr_disableITimers) +import System.Posix.Types (Fd(Fd)) + +#include "HsUnix.h" + +-- | This is like 'dup', but takes an extra argument. The new file descriptor +-- will be the lowest free file descriptor not less than the second argument. +-- The 'CloseOnExec' flag (FD_CLOEXEC) will be cleared on the new descriptor. +dupFd :: Fd -> Fd -> IO Fd +dupFd = dupFdViaFcntl (#const F_DUPFD) + +-- | Same as 'dupFd', but the 'CloseOnExec' flag (FD_CLOEXEC) will be set. +dupFdCloseOnExec :: Fd -> Fd -> IO Fd +-- dupFdCloseOnExec = dupFdViaFcntl (#const F_DUPFD_CLOEXEC) + -- While this is POSIX, is is relatively new, and many systems do not + -- support this operation. The following code simulates it. +dupFdCloseOnExec src base = do + dest <- dupFd src base + setFdOption dest CloseOnExec True + return dest + +dupFdViaFcntl :: CInt -> Fd -> Fd -> IO Fd +dupFdViaFcntl op (Fd srcFd) (Fd minFd) = Fd `fmap` + throwErrnoIfMinus1 "dupFdViaFcntl" + (c_fcntl_write srcFd op (fromIntegral minFd)) + +-- | Prepares for login on the tty, which should be a real tty or the slave +-- from a call to `openPseudoTerminal`. A new session will be started, the tty +-- will become the controlling terminal, and the tty is dup'd down to become +-- the standard in, out and err FDs. +loginTerminal :: Fd -> IO () + +#ifdef HAVE_OPENPTY + -- In theory this should be testing HAVE_LOGIN_TTY, but that doesn't exist. + -- The calls login_tty, openpty, and forkpty are part of the same BSD module + -- and so are all generally present together or not. +loginTerminal (Fd ttyFd) = + throwErrnoIfMinus1_ "loginTerminal" (c_login_tty ttyFd) + +foreign import ccall unsafe "login_tty" + c_login_tty :: CInt -> IO CInt + +#else +loginTerminal tty = do + _ <- createSession + setControllingTerminal tty + _ <- dupTo tty stdInput + _ <- dupTo tty stdOutput + _ <- dupTo tty stdError + when (tty > stdError) $ closeFd tty +#endif + +-- | Set the controlling terminal of the process. The tty should be a real tty +-- or the slave from a call to 'openPseudoTerminal'. +setControllingTerminal :: Fd -> IO () + +#ifdef TIOCSCTTY +setControllingTerminal (Fd ttyfd) = + throwErrnoIfMinus1_ "setControllingTerminal" + (ioctl ttyfd (#const TIOCSCTTY) nullPtr) + +foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt +#else +-- POSIX doesn't spec how to set the controlling terminal! The ioctl TIOSCTTY +-- method above is generally available, but some systems don't have it. The +-- second most common way to set the controlling terminal is to open it when no +-- other terminal is opened in the process. That is what this alternative +-- implementation does. Be forewarned that they may be systems that use yet some +-- third unknown method. +setControllingTerminal tty = do + ttyName <- getTerminalName tty + when (tty /= stdInput) $ closeFd stdInput + when (tty /= stdOutput) $ closeFd stdOutput + when (tty /= stdError) $ closeFd stdError + openFd ttyName ReadWrite Nothing defaultFileFlags >>= closeFd +#endif + +-- | Return @argv[0]@ as passed to the program on invocation. Unlike +-- 'getProgName', this is the raw value passed to the process. It may, or may +-- not, have anything to do with the name of the running executable! +getArg0 :: IO String +getArg0 = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getProgArgv p_argc p_argv + argv <- peek p_argv + enc <- getFileSystemEncoding + peekElemOff argv 0 >>= peekCString enc + +foreign import ccall unsafe "getProgArgv" + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + + +-- | Like 'executeFile', but allow for expressly setting @argv[0]@ +-- For simplicity, this version has no path search option, and always takes an +-- environment. If incorporating into System.Posix.Process, the signature +-- should better match 'executeFile'. +executeFile0 :: FilePath -> String -> [String] -> [(String, String)] -> IO a +executeFile0 path cmd args env = do + withFilePath path $ \s -> + withMany withFilePath (cmd:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arg_arr -> + let env' = map (\ (name, val) -> name ++ ('=' : val)) env in + withMany withFilePath env' $ \cenv -> + withArray0 nullPtr cenv $ \env_arr -> do + pPrPr_disableITimers + throwErrnoPathIfMinus1_ "executeFile" path + (c_execve s arg_arr env_arr) + return undefined -- never reached + +foreign import ccall unsafe "execve" + c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt + +-- Copied from Plush.Run.Posix +-- https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/Plush/Run/Posix.hs + +-- | Based on code for readLoop, but instead expects a blocking Fd. +readChunk :: Fd -> IO BS.ByteString +readChunk fd = + BS.createAndTrim bufSize $ \buf -> + fmap fromIntegral (fdReadBuf fd buf (fromIntegral bufSize)) + where + bufSize = 4096 + +-- | 'write' for 'IO': Seek to the end, and write. +-- +-- Modified to take a strict bytestring +write :: Fd -> BS.ByteString -> IO () +write fd bs = unsafeUseAsCStringLen bs writeBuf + where + writeBuf (p, n) | n > 0 = do + ignoreUnsupportedOperation $ fdSeek fd SeekFromEnd 0 + m <- fromIntegral `fmap` fdWriteBuf fd (castPtr p) (fromIntegral n) + when (0 <= m && m <= n) $ writeBuf (p `plusPtr` m, n - m) + writeBuf _ = return () + +ignoreUnsupportedOperation :: IO a -> IO () +ignoreUnsupportedOperation act = void act `catchIOError` \ex -> + if ioeGetErrorType ex == UnsupportedOperation + then return () + else throwIO ex diff --git a/RTS.hs b/RTS.hs new file mode 100644 --- /dev/null +++ b/RTS.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +module RTS ( RtsInfo(..), deployRts ) + +where + +import Data.FileEmbed (embedFile) +import System.IO.Temp (createTempDirectory) +import System.FilePath ( () ) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS + + +-- | A tarball with a relocatable package-db, containing the rts. +-- File "embedded-rts.tgz" is automatically created by the build system. +rts_tarball :: BS.ByteString +rts_tarball = $(embedFile "embedded-rts.tgz") + +data RtsInfo = RtsInfo { rtsPackageDb :: FilePath, rtsPackage :: String } + + +-- | Extracts the embedded rts-package to a temporary directory +-- inside the given directory, and returns its location. +deployRts :: FilePath -> IO RtsInfo +deployRts dir = do + deployDir <- createTempDirectory dir "rts." + + extractTarball (LBS.fromStrict rts_tarball) deployDir + + return RtsInfo { + rtsPackageDb = deployDir "embedded-rts" "pkgdb" + , rtsPackage = "ide-backend-rts" + } + + +extractTarball :: LBS.ByteString -> FilePath -> IO () +extractTarball tarball dest = + Tar.unpack dest $ Tar.read $ GZip.decompress $ tarball diff --git a/Run.hs b/Run.hs --- a/Run.hs +++ b/Run.hs @@ -11,7 +11,7 @@ -- any modules from the ghc package and the modules should not be reexported -- anywhere else, with the exception of @IdeSession.GHC.Server@. module Run - ( -- * Re-expored GHC API + ( -- * Re-exported GHC API Ghc , runFromGhc , liftIO @@ -73,7 +73,7 @@ import DynFlags (defaultDynFlags) import Exception (ghandle) import ErrUtils (ErrMsg) -import FastString ( unpackFS ) +import FastString (unpackFS, mkFastString) import GHC hiding ( ModuleName , RunResult(..) @@ -85,6 +85,7 @@ import Outputable (PprStyle, mkUserStyle) import RdrName (GlobalRdrEnv, GlobalRdrElt, gre_name) import RnNames (rnImports) +import SrcLoc (mkRealSrcSpan, mkRealSrcLoc) import TcRnMonad (initTc) import TcRnTypes (RnM) import RtClosureInspect (Term) @@ -155,7 +156,7 @@ -- | Compile a set of targets -- -- Returns the errors, loaded modules, and mapping from filenames to modules -compileInGhc :: FilePath -- ^ target directory +compileInGhc :: FilePath -- ^ target directory, only used for 'TargetsExclude' -> Bool -- ^ should we generate code -> Targets -- ^ targets -> StrictIORef (Strict [] SourceError) -- ^ the IORef where GHC stores errors @@ -317,14 +318,23 @@ return IdInfo{..} autoEnvs :: ModSummary -> IO [GlobalRdrElt] - autoEnvs ModSummary{ ms_mod + autoEnvs ms@ModSummary{ ms_mod , ms_hsc_src , ms_srcimps , ms_textual_imps } = do let go :: RnM (a, GlobalRdrEnv, b, c) -> IO [GlobalRdrElt] go op = do +#if GHC_AFTER_710_1 + -- Not sure if this is the same thing that GHC would + -- pass in, but this is just to initialize the state, + -- and will be overridden before any uses. + let srcSpan = mkRealSrcSpan loc loc + loc = mkRealSrcLoc (mkFastString (HscTypes.msHsFilePath ms)) 1 1 + ((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod srcSpan op +#else ((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod op +#endif case res of Nothing -> do -- TODO: deal with import errors @@ -465,7 +475,7 @@ setPrintContext pprStyle localVars <- mkTerms >>= mapM (exportVar pprStyle) - ProperSpan srcSpan' <- liftIO $ extractSourceSpan srcSpan + ProperSpan srcSpan' <- liftIO $ extractEitherSpan srcSpan prettyResTy <- prettyM pprStyle breakInfo_resty return BreakInfo { @@ -534,7 +544,7 @@ SevFatal -> Just KindError _ -> Nothing = do let msgstr = showSDocForUser flags (queryQual style) msg - sp <- extractSourceSpan srcspan + sp <- extractEitherSpan srcspan modifyIORef errsRef (StrictList.cons $ SourceError errKind sp (Text.pack msgstr)) collectSrcError' _errsRef handlerOutput _ flags SevOutput _srcspan style msg @@ -563,7 +573,7 @@ case sourceErrorSpan e of Just real -> do - xSpan <- extractSourceSpan real + xSpan <- extractEitherSpan real return $ SourceError KindError xSpan err Nothing -> return $ SourceError KindError (TextSpan noloc) err diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -5,28 +5,32 @@ import Prelude hiding (mod, span) import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId, threadDelay) -import Control.Concurrent.Async (async) +import Control.Concurrent.Async (async, withAsync) import Control.Concurrent.MVar (MVar, newEmptyMVar) -import Control.Monad (void, unless, when) +import Control.Monad (void, unless, when, forever) import Control.Monad.State (StateT, runStateT) import Control.Monad.Trans.Class (lift) import Data.Accessor (accessor, (.>)) import Data.Accessor.Monad.MTL.State (set) -import Data.Function (on) -import Foreign.Ptr (Ptr, nullPtr) +import Data.Function (on, fix) import Foreign.C.Types (CFile) -import System.Environment (withArgs, getEnvironment) +import Foreign.Ptr (Ptr, nullPtr) +import GHC.IO.Exception (IOException(..), IOErrorType(..)) +import System.Environment (withArgs, getEnvironment, setEnv) import System.FilePath (()) import System.IO (Handle, hFlush, hClose) -import System.IO.Temp (createTempDirectory, openTempFile) +import System.IO.Temp (createTempDirectory, openTempFile, withSystemTempDirectory) import System.Mem (performGC) -import System.Posix (Fd) +import System.Posix (Fd, createSession) import System.Posix.IO import System.Posix.Files (createNamedPipe) import System.Posix.Process (forkProcess, getProcessStatus) +import System.Posix.Terminal (openPseudoTerminal) +import System.Posix.Signals (signalProcess, sigKILL, sigTERM) +import qualified Posix import System.Posix.Types (ProcessID) import qualified Control.Exception as Ex -import qualified Data.ByteString as BSS (hGetSome, hPut, null) +import qualified Data.ByteString as BSS import qualified Data.List as List import qualified Data.Text as Text import qualified System.Directory as Dir @@ -53,6 +57,7 @@ import HsWalk import Debug import GhcShim +import RTS foreign import ccall "fflush" fflush :: Ptr CFile -> IO () @@ -62,18 +67,23 @@ -- | Start the RPC server. Used from within the server executable. ghcServer :: [String] -> IO () -ghcServer = rpcServer ghcServerEngine +ghcServer args = + withSystemTempDirectory "ghc-server." $ \tmpDir -> do + -- Prepare the rts support module + rtsInfo <- deployRts tmpDir + -- Launch the server + rpcServer (ghcServerEngine rtsInfo) args + + -- | The GHC server engine proper. -- -- This function runs in end endless loop inside the @Ghc@ monad, making -- incremental compilation possible. -ghcServerEngine :: FilePath -> RpcConversation -> IO () -ghcServerEngine errorLog conv@RpcConversation{..} = do +ghcServerEngine :: RtsInfo -> FilePath -> RpcConversation -> IO () +ghcServerEngine rtsInfo errorLog conv@RpcConversation{..} = do -- The initial handshake with the client - (configGenerateModInfo, initOpts, sessionDir) <- handleInit conv - let distDir = ideSessionDistDir sessionDir - sourceDir = ideSessionSourceDir sessionDir + (configGenerateModInfo, initOpts, sourceDir, sessionDir, distDir) <- handleInit conv -- Submit static opts and get back leftover dynamic opts. dOpts <- submitStaticOpts initOpts @@ -90,7 +100,7 @@ -- Start handling requests. From this point on we don't leave the GHC monad. runFromGhc $ do -- Register startup options and perhaps our plugin in dynamic flags. - initSession distDir configGenerateModInfo dOpts errsRef stRef pluginRef progressCallback + initSession distDir configGenerateModInfo dOpts rtsInfo errsRef stRef pluginRef progressCallback -- We store the DynFlags _after_ setting the "static" options, so that -- we restore to this state before every call to updateDynamicOpts @@ -115,11 +125,20 @@ conv pluginRef importsRef errsRef sourceDir genCode targets configGenerateModInfo return args - ReqRun runCmd -> do - (pid, stdin, stdout, errorLog') <- startConcurrentConversation sessionDir $ \_errorLog' conv' -> do - ghcWithArgs args $ ghcHandleRun conv' runCmd - liftIO $ put (pid, stdin, stdout, errorLog') - return args + ReqRun runCmd + | runCmdPty runCmd -> do + fds <- liftIO openPseudoTerminal + conversationTuple <- startConcurrentConversation sessionDir $ \_ _ _ -> + ghcWithArgs args $ ghcHandleRunPtySlave fds runCmd + liftIO $ runPtyMaster fds conversationTuple + liftIO $ put conversationTuple + return args + | otherwise -> do + conversationTuple <- startConcurrentConversation sessionDir $ + ghcConcurrentConversation $ \_errorLog' conv' -> + ghcWithArgs args $ ghcHandleRun conv' runCmd + liftIO $ put conversationTuple + return args ReqSetEnv env -> do ghcHandleSetEnv conv initEnv env return args @@ -174,12 +193,13 @@ initSession :: FilePath -> Bool -> DynamicOpts + -> RtsInfo -> StrictIORef (Strict [] SourceError) -> StrictIORef ExtractIdsSuspendedState -> StrictIORef (Strict (Map ModuleName) PluginResult) -> (String -> IO ()) -> Ghc () -initSession distDir modInfo dOpts errsRef stRef pluginRef callback = do +initSession distDir modInfo dOpts rtsInfo errsRef stRef pluginRef callback = do flags <- getSessionDynFlags (flags', _, _) <- parseDynamicFlags flags $ dOpts ++ dynOpts @@ -191,8 +211,8 @@ where dynOpts :: DynamicOpts dynOpts = optsToDynFlags [ - -- Just in case the user specified -hide-all-packages. - "-package ide-backend-rts" + "-package-db " ++ rtsPackageDb rtsInfo + , "-package " ++ rtsPackage rtsInfo -- Include cabal_macros.h , "-optP-include" @@ -217,8 +237,11 @@ #endif } -startConcurrentConversation :: FilePath -> (FilePath -> RpcConversation -> Ghc ()) -> Ghc (ProcessID, FilePath, FilePath, FilePath) -startConcurrentConversation sessionDir server = do +startConcurrentConversation + :: FilePath + -> (FilePath -> FilePath -> FilePath -> Ghc ()) + -> Ghc (ProcessID, FilePath, FilePath, FilePath) +startConcurrentConversation sessionDir inner = do -- Ideally, we'd have the child process create the temp directory and -- communicate the name back to us, so that the child process can remove the -- directories again when it's done with it. However, this means we need some @@ -244,11 +267,14 @@ -- because we need to change global state in the child process; in particular, -- we need to redirect stdin, stdout, and stderr (as well as some other global -- state, including withArgs). - liftIO $ performGC - processId <- forkGhcProcess $ ghcConcurrentConversation stdin stdout errorLog server + liftIO performGC + processId <- forkGhcProcess $ inner stdin stdout errorLog -- We wait for the process to finish in a separate thread so that we do not -- accumulate zombies + -- + -- FIXME(mgs): I didn't write this, and I'm not sure I see the point + -- of doing this. liftIO $ void $ forkIO $ void $ getProcessStatus True False processId @@ -269,7 +295,7 @@ } -- | Client handshake -handleInit :: RpcConversation -> IO (Bool, [String], FilePath) +handleInit :: RpcConversation -> IO (Bool, [String], FilePath, FilePath, FilePath) handleInit RpcConversation{..} = do GhcInitRequest{..} <- get @@ -289,7 +315,9 @@ return ( ghcInitGenerateModInfo , ghcInitOpts ++ packageDBFlags ghcInitUserPackageDB ghcInitSpecificPackageDBs + , ghcInitSourceDir , ghcInitSessionDir + , ghcInitDistDir ) -- | Handle a compile or type check request @@ -516,6 +544,65 @@ mapM_ ObjLink.unloadObj objects put () +runPtyMaster :: (Fd, Fd) -> (ProcessID, FilePath, FilePath, FilePath) -> IO () +runPtyMaster (masterFd, slaveFd) (processId, stdin, stdout, errorLog) = do + -- Since we're in the master process, close the slave FD. + closeFd slaveFd + let readOutput :: RpcConversation -> IO RunResult + readOutput conv = fix $ \loop -> do + bs <- Posix.readChunk masterFd `Ex.catch` \ex -> + -- Ignore HardwareFaults as they seem to always happen when + -- process exits.. + if ioe_type ex == HardwareFault + then return BSS.empty + else Ex.throwIO ex + if BSS.null bs + then return RunOk + else do + put conv (GhcRunOutp bs) + loop + handleRequests :: RpcConversation -> IO () + handleRequests conv = forever $ do + request <- get conv + case request of + GhcRunInput bs -> Posix.write masterFd bs + -- Fork a new thread because this could throw exceptions. + GhcRunInterrupt -> void $ forkIO $ signalProcess sigTERM processId + -- Turn a GHC exception into a RunResult + ghcException :: GhcException -> IO RunResult + ghcException = return . RunGhcException . show + void $ forkIO $ + concurrentConversation stdin stdout errorLog $ \_ conv -> do + result <- Ex.handle ghcException $ + withAsync (handleRequests conv) $ \_ -> + readOutput conv + put conv (GhcRunDone result) + +ghcHandleRunPtySlave :: (Fd, Fd) -> RunCmd -> Ghc () +ghcHandleRunPtySlave (masterFd, slaveFd) runCmd = do + liftIO $ do + -- Since we're in the slave process, close the master FD. + closeFd masterFd + -- Create a new session with a controlling terminal. + void createSession + Posix.setControllingTerminal slaveFd + -- Redirect standard IO to the terminal FD. + void $ dupTo slaveFd stdInput + void $ dupTo slaveFd stdOutput + void $ dupTo slaveFd stdError + closeFd slaveFd + -- Set TERM env variable + setEnv "TERM" "xterm-256color" + --FIXME: Properly pass the run result to the client as a GhcRunDone + --value. Instead, we write it to standard output, which gets sent to + --the terminal. + result <- runInGhc runCmd + case result of + -- A successful result will be sent by runPtyMaster - only send + -- failures. + RunOk -> return () + _ -> liftIO $ putStrLn $ "\r\nProcess done: " ++ show result ++ "\r\n" + -- | Handle a run request ghcHandleRun :: RpcConversation -> RunCmd -> Ghc () ghcHandleRun RpcConversation{..} runCmd = do @@ -706,10 +793,10 @@ forkGhcProcess = unsafeLiftIO forkProcess -- | Lifted version of concurrentConversation -ghcConcurrentConversation :: FilePath +ghcConcurrentConversation :: (FilePath -> RpcConversation -> Ghc ()) -> FilePath -> FilePath - -> (FilePath -> RpcConversation -> Ghc ()) + -> FilePath -> Ghc () -ghcConcurrentConversation requestR responseW errorLog = - unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) +ghcConcurrentConversation f requestR responseW errorLog = + unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) f diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,195 @@ import Distribution.Simple -main = defaultMain +import Distribution.Simple.LocalBuildInfo ( withPrograms, compiler ) +import Distribution.Simple.Program ( runProgram, lookupProgram, ghcPkgProgram ) +import Distribution.Simple.Setup ( fromFlag, configVerbosity, buildVerbosity ) +import Distribution.Simple.Utils ( notice, die ) + +import Control.Exception ( bracket ) +import Control.Monad ( join, when, forM_, liftM2 ) +import Data.Bits ( xor ) +import Data.Word ( Word ) +import System.Directory ( getCurrentDirectory, setCurrentDirectory + , removeDirectoryRecursive, removeFile + , doesDirectoryExist, doesFileExist + , getDirectoryContents ) +import System.Environment ( getArgs ) +import System.FilePath ( (), takeExtension ) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as List +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + + +main :: IO () +main = join $ liftM2 mainWith getArgs getCurrentDirectory + +mainWith :: [String] -> FilePath -> IO () +mainWith cmdLineArgs cwd = defaultMainWithHooksArgs hooks cmdLineArgs + where + hooks = simpleUserHooks { + + postConf = \args flags pd lbi -> + do configureRts lbi flags + (postConf simpleUserHooks) args flags pd lbi + + , buildHook = \pd lbi hs flags -> + do buildRts lbi flags + makeRtsRelocatable lbi flags + makeTarball "embedded-rts.tgz" cwd [dirToEmbed] + (buildHook simpleUserHooks) pd lbi hs flags + + , preClean = \args flags -> + do onRtsDir $ runSetupClean + (preClean simpleUserHooks) args flags + } + + + dirToEmbed = "embedded-rts" + pkgDbPath = dirToEmbed "pkgdb" + + onRtsDir = withCurrentDirectory "ide-backend-rts" + + rawRunSetup args lbi verbosity = do + let args' = args ++ [rtsBuildDirArg lbi] + notice verbosity $ "Running cabal with " ++ show args' + defaultMainArgs args' + runSetup cmd lbi verbosity = rawRunSetup [cmd] lbi verbosity + rerunSetupWith flags lbi verbosity = rawRunSetup (cmdLineArgs ++ flags) lbi verbosity + -- NB. we must set builddir explicitly (and as the final arg) + -- since when rerunning the command during configuration, the default + -- builddir may be changed by a flag (e.g. as "stack" does), and if we + -- are not aware of the right builddir on the subsequent calls, we won't + -- find the configuration info and fail. + + rtsBuildDirArg lbi = "--builddir=dist/buildinfo-" ++ show (hashString $ show (compiler lbi)) + -- NB. We make the builddir a function of the compiler being used + -- (approximated by the local build info). This is only relevant for + -- people hacking on this library: we are trying to avoid the scenario + -- where one first builds the server using compiler A and then, on the same + -- directory, rebuilds the server using compiler B, but the "Setup build" step + -- on the rts directory finds that the rts is already built (but with compiler A!), + -- leaves it as is, and one ends up with a server for B with an embedded rts for A. + -- Using a different builddir for A and B, this won't happen. + -- Note also that we put all the local build dirs under the same root dist, so we + -- know what to remove during cleanup + + runSetupClean = defaultMainArgs ["clean", "--builddir=dist"] + + + -- Run "Setup configure" on the directory of the rts. + -- We ensure that we pass exactly the same command line arguments + -- we received (since those can be indicating the version of ghc + -- with which we are compiling the server) but override the location + -- of the output, since we want the package-db on "embedded-rts" + configureRts lbi flags = do + let verbosity = fromFlag (configVerbosity flags) + notice verbosity "configuring rts..." + + let dirToEmbedFullPath = cwd dirToEmbed + pkgDbFullPath = cwd pkgDbPath + + outOfTheWay dirToEmbed + runGhcPkg ["init", pkgDbPath] lbi verbosity + + onRtsDir $ + rerunSetupWith [ + "--package-db=" ++ pkgDbFullPath + , "--libdir=" ++ (dirToEmbedFullPath "lib") + , "--bindir=" ++ (dirToEmbedFullPath "bin") + , "--datadir=" ++ (dirToEmbedFullPath "share") + , "--docdir=" ++ (dirToEmbedFullPath "doc") + , "--htmldir=" ++ (dirToEmbedFullPath "doc") + , "--haddockdir=" ++ (dirToEmbedFullPath "doc") + , "--enable-library-for-ghci" + ] lbi verbosity + + + -- Builds the rts, which will end up in embedded-rts, and + -- registers it to a package-db contained there as well + buildRts lbi flags = do + let verbosity = fromFlag (buildVerbosity flags) + notice verbosity "building rts..." + + onRtsDir $ do + runSetup "build" lbi verbosity + + notice verbosity "locally registering rts..." + onRtsDir $ do + runSetup "copy" lbi verbosity + runSetup "register" lbi verbosity + + -- This hack is a workaround to Cabal not having yet (as of 1.22) + -- a clear story regarding relocatable packages. We just replace + -- every occurrence of 'cwd dirToEmbed' by the string "${pkgroot}" + -- everywhere in the installed-package-conf and run 'ghc-pkg recache' + -- afterwards. + makeRtsRelocatable lbi flags = do + let verbosity = fromFlag (buildVerbosity flags) + notice verbosity "making rts a relocatable package..." + + pkgDb_files <- getDirectoryContents pkgDbPath + let conf_files = filter ((== ".conf").takeExtension) pkgDb_files + + -- we expect only one conf file, if we couldn't find it the hack + -- has failed (better to detect here than at runtime!) + when (null conf_files) $ + die "Couldn't file a conf file to hack" + + forM_ (map (pkgDbPath ) conf_files) $ \conf_file -> do + + -- NB. ghc-pkg expects conf files to be in utf-8 + contents <- T.decodeUtf8 `fmap` BS.readFile conf_file + + -- we do a simple text substitution instead of parsing the conf file + -- using Distribution.InstalledPackageInfo; the text substitution is + -- safe enough and arguably more future-proof. + let hack = T.replace (T.pack $ cwd dirToEmbed) (T.pack "${pkgroot}") + new_contents = hack contents + + -- make sure that we have indeed made a substitution, otherwise this + -- will blow at runtime.... + when (contents == new_contents) $ + die "No substitution, hack failed" + + BS.writeFile conf_file $ T.encodeUtf8 (new_contents) + + -- Update the package cache + runGhcPkg ["recache", "--package-db=" ++ pkgDbPath] lbi verbosity + + runGhcPkg args lbi verb = + let Just ghc_pkg = lookupProgram ghcPkgProgram (withPrograms lbi) + in runProgram verb ghc_pkg args + + +-- Available in directory-1.2.3.0 +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory dir + action + +-- Removes the given file or directory +outOfTheWay :: FilePath -> IO () +outOfTheWay fileOrDir = do + is_dir <- doesDirectoryExist fileOrDir + if is_dir + then removeDirectoryRecursive fileOrDir + else do is_file <- doesFileExist fileOrDir + when is_file $ + removeFile fileOrDir + +makeTarball :: FilePath -> FilePath -> [FilePath] -> IO () +makeTarball tarball base contents = + LBS.writeFile tarball . GZip.compress . Tar.write =<< Tar.pack base contents + + +-- Based on the Hashable String instance +hashString :: String -> Word +hashString = List.foldl' (\salt x -> salt `combine` hashChar x) 0x087fc72c + where + hashChar = fromIntegral . fromEnum + combine h1 h2 = (h1 * 16777619) `xor` h2 diff --git a/ide-backend-rts/IdeBackendRTS.hs b/ide-backend-rts/IdeBackendRTS.hs new file mode 100644 --- /dev/null +++ b/ide-backend-rts/IdeBackendRTS.hs @@ -0,0 +1,126 @@ +module IdeBackendRTS ( + run + , RunBufferMode(..) + , Maybe(..) + ) where + +import Control.Concurrent (forkIO, threadDelay, killThread) +import Control.Concurrent.MVar (MVar, takeMVar, putMVar) +import qualified System.IO as IO +import qualified Control.Exception as Ex +import Control.Monad (forever) + +import GHC.IO.Handle.Types ( + Handle(FileHandle) + , HandleType(ClosedHandle, ReadHandle, WriteHandle) + , nativeNewlineMode + , Handle__ + , haType + ) +import GHC.IO.Handle.Internals ( + mkHandle + , closeTextCodecs + , ioe_finalizedHandle + , flushWriteBuffer + ) +import qualified GHC.IO.FD as FD + +run :: RunBufferMode -> RunBufferMode -> IO a -> IO () +run outBMode errBMode io = do + let resetHandles = do + resetStdin IO.utf8 + resetStdout IO.utf8 + resetStderr IO.utf8 + let io' = do _result <- io ; return () -- Throw away any snippet result + withBuffering IO.stdout outBMode (withBuffering IO.stderr errBMode io') + `Ex.finally` resetHandles + +{------------------------------------------------------------------------------- + Buffer modes +-------------------------------------------------------------------------------} + +data RunBufferMode = + RunNoBuffering + | RunLineBuffering (Maybe Int) + | RunBlockBuffering (Maybe Int) (Maybe Int) + deriving Read + +withBuffering :: IO.Handle -> RunBufferMode -> IO a -> IO a +withBuffering h mode io = do + IO.hSetBuffering h (bufferMode mode) + result <- withBufferTimeout h (bufferTimeout mode) io + ignoreIOExceptions $ IO.hFlush h + return result + +ignoreIOExceptions :: IO () -> IO () +ignoreIOExceptions = let handler :: Ex.IOException -> IO () + handler _ = return () + in Ex.handle handler + +bufferMode :: RunBufferMode -> IO.BufferMode +bufferMode RunNoBuffering = IO.NoBuffering +bufferMode (RunLineBuffering _) = IO.LineBuffering +bufferMode (RunBlockBuffering sz _) = IO.BlockBuffering sz + +bufferTimeout :: RunBufferMode -> Maybe Int +bufferTimeout RunNoBuffering = Nothing +bufferTimeout (RunLineBuffering t) = t +bufferTimeout (RunBlockBuffering _ t) = t + +withBufferTimeout :: IO.Handle -> Maybe Int -> IO a -> IO a +withBufferTimeout _ Nothing io = io +withBufferTimeout h (Just n) io = do + tid <- forkIO . ignoreIOExceptions . forever $ threadDelay n >> IO.hFlush h + result <- io + killThread tid + return result + +swapFileHandles :: Handle -> Handle -> IO () +swapFileHandles (FileHandle _ h1) (FileHandle _ h2) = Ex.mask_ $ do + h1' <- takeMVar h1 + h2' <- takeMVar h2 + putMVar h1 h2' + putMVar h2 h1' +swapFileHandles _ _ = + Ex.throwIO (userError "swapFileHandles: unsupported handles") + +{------------------------------------------------------------------------------- + To reset the handle we duplicate the implementation of 'stdin', 'stdout' or + 'stderr' and then use 'swapFileHandles' to swap the MVar contents of the real + Handle +-------------------------------------------------------------------------------} + +resetStdin :: IO.TextEncoding -> IO () +resetStdin enc = do + new <- mkHandle FD.stdin "" ReadHandle True (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + swapFileHandles new IO.stdin + +resetStdout :: IO.TextEncoding -> IO () +resetStdout enc = do + new <- mkHandle FD.stdout "" WriteHandle True (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + swapFileHandles new IO.stdout + +resetStderr :: IO.TextEncoding -> IO () +resetStderr enc = do + new <- mkHandle FD.stderr "" WriteHandle False{-stderr is unbuffered-} + (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + swapFileHandles new IO.stderr + +{------------------------------------------------------------------------------- + Taken directly from the GHC.IO.Handle.FD (not exported) +-------------------------------------------------------------------------------} + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do + h_ <- takeMVar m + flushWriteBuffer h_ + case haType h_ of + ClosedHandle -> return () + _other -> closeTextCodecs h_ + putMVar m (ioe_finalizedHandle fp) diff --git a/ide-backend-rts/LICENSE b/ide-backend-rts/LICENSE new file mode 100644 --- /dev/null +++ b/ide-backend-rts/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/ide-backend-rts/Setup.hs b/ide-backend-rts/Setup.hs new file mode 100644 --- /dev/null +++ b/ide-backend-rts/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ide-backend-rts/ide-backend-rts.cabal b/ide-backend-rts/ide-backend-rts.cabal new file mode 100644 --- /dev/null +++ b/ide-backend-rts/ide-backend-rts.cabal @@ -0,0 +1,21 @@ +-- Initial ide-backend-rts.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: ide-backend-rts +version: 0.1.3.1 +synopsis: RTS for the IDE backend +description: Add on package used internally. End users should not need to use this. +license: MIT +license-file: LICENSE +author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries +maintainer: Duncan Coutts +copyright: (c) 2015 FP Complete +category: Development +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: IdeBackendRTS + -- other-modules: + build-depends: base >=4.5 && <5 + ghc-options: -Wall diff --git a/ide-backend-server.cabal b/ide-backend-server.cabal --- a/ide-backend-server.cabal +++ b/ide-backend-server.cabal @@ -1,5 +1,5 @@ name: ide-backend-server -version: 0.9.0 +version: 0.10.0 synopsis: An IDE backend server description: Server executable used internally by the ide-backend library. license: MIT @@ -8,9 +8,18 @@ maintainer: Duncan Coutts copyright: (c) 2015 FP Complete category: Development -build-type: Simple +build-type: Custom cabal-version: >=1.10 +extra-tmp-files: embedded-rts, embedded-rts.tgz + -- This directory will be created by the custom setup + -- and should be removed on clean up. +extra-source-files: ide-backend-rts/ide-backend-rts.cabal, + ide-backend-rts/LICENSE, + ide-backend-rts/Setup.hs, + ide-backend-rts/IdeBackendRTS.hs + + executable ide-backend-server main-is: ide-backend-server.hs other-modules: IdPropCaching @@ -28,8 +37,10 @@ GhcShim.GhcShim78 GhcShim.GhcShim710 GhcShim + Posix + RTS build-depends: base < 10, - ghc == 7.4.* || == 7.8.* || == 7.10.*, + ghc == 7.4.* || == 7.8.* || == 7.10.* || == 7.11.*, containers >= 0.4.1 && < 1, bytestring >= 0.9.2 && < 1, data-accessor >= 0.2 && < 0.3, @@ -47,7 +58,10 @@ filemanip >= 0.3.6.2 && < 0.4, array >= 0.4 && < 0.6, temporary >= 1.1.2.4 && < 1.3, - ide-backend-common >= 0.9 && < 0.10 + tar >= 0.3 && < 0.5, + zlib >= 0.5.3 && < 0.7, + file-embed >= 0.0 && < 0.1, + ide-backend-common >= 0.10 && < 0.11 -- The standard macros don't give us 7.6.x granularity -- We _could_ add support for 7.6, 7.6.1 specifically is broken (#7548) @@ -67,7 +81,7 @@ Cabal cpp-options: -DGHC_78 ghc-options: -dynamic - if impl(ghc == 7.10.*) + if impl(ghc == 7.10.*) || impl(ghc == 7.11.*) build-depends: time == 1.5.*, haddock-api == 2.16.*, -- although from 7.10 basic datatypes are defined in @@ -76,6 +90,8 @@ Cabal cpp-options: -DGHC_710 ghc-options: -dynamic + if impl(ghc > 7.10.1) + cpp-options: -DGHC_AFTER_710_1 default-language: Haskell2010 default-extensions: MonoLocalBinds,