From 44a5d51a4892b85c7eba09dcb90ca02245637812 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Wed, 27 Jan 2016 10:20:11 +0100 Subject: Enable RemoteGHCi on Windows Makes the needed changes to make RemoteGHCi work on Windows. The approach passes OS Handles areound instead of the Posix Fd as on Linux. The reason is that I could not find any real documentation about the behaviour of Windows w.r.t inheritance and Posix FDs. The implementation with Fd did not seem to be able to find the Fd in the child process. Instead I'm using the much better documented approach of passing inheriting handles. This requires a small modification to the `process` library. https://github.com/haskell/process/pull/52 Test Plan: ./validate On Windows x86_64 Reviewers: thomie, erikd, bgamari, simonmar, austin, hvr Reviewed By: simonmar Subscribers: #ghc_windows_task_force Differential Revision: https://phabricator.haskell.org/D1836 GHC Trac Issues: #11100 --- iserv/Main.hs | 94 ------------------------------------------------ iserv/cbits/iservmain.c | 16 +++++++++ iserv/iserv-bin.cabal | 8 +++-- iserv/iservmain.c | 16 --------- iserv/src/GHCi/Utils.hsc | 25 +++++++++++++ iserv/src/Main.hs | 94 ++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 141 insertions(+), 112 deletions(-) delete mode 100644 iserv/Main.hs create mode 100644 iserv/cbits/iservmain.c delete mode 100644 iserv/iservmain.c create mode 100644 iserv/src/GHCi/Utils.hsc create mode 100644 iserv/src/Main.hs (limited to 'iserv') diff --git a/iserv/Main.hs b/iserv/Main.hs deleted file mode 100644 index cbaf9277d5..0000000000 --- a/iserv/Main.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-} -module Main (main) where - -import GHCi.Run -import GHCi.TH -import GHCi.Message -import GHCi.Signals - -import Control.DeepSeq -import Control.Exception -import Control.Monad -import Data.Binary -import Data.IORef -import System.Environment -import System.Exit -import System.Posix -import Text.Printf - -main :: IO () -main = do - (arg0:arg1:rest) <- getArgs - let wfd1 = read arg0; rfd2 = read arg1 - verbose <- case rest of - ["-v"] -> return True - [] -> return False - _ -> die "iserv: syntax: iserv [-v]" - when verbose $ do - printf "GHC iserv starting (in: %d; out: %d)\n" - (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int) - inh <- fdToHandle rfd2 - outh <- fdToHandle wfd1 - installSignalHandlers - lo_ref <- newIORef Nothing - let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref} - uninterruptibleMask $ serv verbose pipe - -- we cannot allow any async exceptions while communicating, because - -- we will lose sync in the protocol, hence uninterruptibleMask. - -serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose pipe@Pipe{..} restore = loop - where - loop = do - Msg msg <- readPipe pipe getMessage - discardCtrlC - when verbose $ putStrLn ("iserv: " ++ show msg) - case msg of - Shutdown -> return () - RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc - FinishTH st -> wrapRunTH $ finishTH pipe st - _other -> run msg >>= reply - - reply :: forall a. (Binary a, Show a) => a -> IO () - reply r = do - when verbose $ putStrLn ("iserv: return: " ++ show r) - writePipe pipe (put r) - loop - - wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () - wrapRunTH io = do - r <- try io - case r of - Left e - | Just (GHCiQException _ err) <- fromException e -> do - when verbose $ putStrLn "iserv: QFail" - writePipe pipe (putMessage (QFail err)) - loop - | otherwise -> do - when verbose $ putStrLn "iserv: QException" - str <- showException e - writePipe pipe (putMessage (QException str)) - loop - Right a -> do - when verbose $ putStrLn "iserv: QDone" - writePipe pipe (putMessage QDone) - reply a - - -- carefully when showing an exception, there might be other exceptions - -- lurking inside it. If so, we return the inner exception instead. - showException :: SomeException -> IO String - showException e0 = do - r <- try $ evaluate (force (show (e0::SomeException))) - case r of - Left e -> showException e - Right str -> return str - - -- throw away any pending ^C exceptions while we're not running - -- interpreted code. GHC will also get the ^C, and either ignore it - -- (if this is GHCi), or tell us to quit with a Shutdown message. - discardCtrlC = do - r <- try $ restore $ return () - case r of - Left UserInterrupt -> return () >> discardCtrlC - Left e -> throwIO e - _ -> return () diff --git a/iserv/cbits/iservmain.c b/iserv/cbits/iservmain.c new file mode 100644 index 0000000000..f7eb5664c5 --- /dev/null +++ b/iserv/cbits/iservmain.c @@ -0,0 +1,16 @@ +#include "../rts/PosixSource.h" +#include "Rts.h" + +#include "HsFFI.h" + +int main (int argc, char *argv[]) +{ + RtsConfig conf = defaultRtsConfig; + + // We never know what symbols GHC will look up in the future, so + // we must retain CAFs for running interpreted code. + conf.keep_cafs = 1; + + extern StgClosure ZCMain_main_closure; + hs_main(argc, argv, &ZCMain_main_closure, conf); +} diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal index a770b4fc99..3fd5d2bd28 100644 --- a/iserv/iserv-bin.cabal +++ b/iserv/iserv-bin.cabal @@ -15,12 +15,16 @@ cabal-version: >=1.10 Executable iserv Default-Language: Haskell2010 Main-Is: Main.hs - C-Sources: iservmain.c + C-Sources: cbits/iservmain.c + Hs-Source-Dirs: src + Other-Modules: GHCi.Utils Build-Depends: array >= 0.5 && < 0.6, base >= 4 && < 5, - unix >= 2.7 && < 2.8, binary >= 0.7 && < 0.9, bytestring >= 0.10 && < 0.11, containers >= 0.5 && < 0.6, deepseq >= 1.4 && < 1.5, ghci == 8.1 + + if !os(windows) + Build-Depends: unix >= 2.7 && < 2.8 diff --git a/iserv/iservmain.c b/iserv/iservmain.c deleted file mode 100644 index f7eb5664c5..0000000000 --- a/iserv/iservmain.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "../rts/PosixSource.h" -#include "Rts.h" - -#include "HsFFI.h" - -int main (int argc, char *argv[]) -{ - RtsConfig conf = defaultRtsConfig; - - // We never know what symbols GHC will look up in the future, so - // we must retain CAFs for running interpreted code. - conf.keep_cafs = 1; - - extern StgClosure ZCMain_main_closure; - hs_main(argc, argv, &ZCMain_main_closure, conf); -} diff --git a/iserv/src/GHCi/Utils.hsc b/iserv/src/GHCi/Utils.hsc new file mode 100644 index 0000000000..b90cfacb5f --- /dev/null +++ b/iserv/src/GHCi/Utils.hsc @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module GHCi.Utils + ( getGhcHandle + ) where + +import Foreign.C +import GHC.IO.Handle (Handle()) +#ifdef mingw32_HOST_OS +import GHC.IO.Handle.FD (fdToHandle) +#else +import System.Posix +#endif + +#include /* for _O_BINARY */ + +-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. +getGhcHandle :: CInt -> IO Handle +#ifdef mingw32_HOST_OS +getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle + +foreign import ccall "io.h _open_osfhandle" _open_osfhandle :: + CInt -> CInt -> IO CInt +#else +getGhcHandle fd = fdToHandle $ Fd fd +#endif diff --git a/iserv/src/Main.hs b/iserv/src/Main.hs new file mode 100644 index 0000000000..46ae82b464 --- /dev/null +++ b/iserv/src/Main.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-} +module Main (main) where + +import GHCi.Run +import GHCi.TH +import GHCi.Message +import GHCi.Signals +import GHCi.Utils + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Binary +import Data.IORef +import System.Environment +import System.Exit +import Text.Printf + +main :: IO () +main = do + (arg0:arg1:rest) <- getArgs + let wfd1 = read arg0; rfd2 = read arg1 + verbose <- case rest of + ["-v"] -> return True + [] -> return False + _ -> die "iserv: syntax: iserv [-v]" + when verbose $ do + printf "GHC iserv starting (in: %d; out: %d)\n" + (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int) + inh <- getGhcHandle rfd2 + outh <- getGhcHandle wfd1 + installSignalHandlers + lo_ref <- newIORef Nothing + let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref} + uninterruptibleMask $ serv verbose pipe + -- we cannot allow any async exceptions while communicating, because + -- we will lose sync in the protocol, hence uninterruptibleMask. + +serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO () +serv verbose pipe@Pipe{..} restore = loop + where + loop = do + Msg msg <- readPipe pipe getMessage + discardCtrlC + when verbose $ putStrLn ("iserv: " ++ show msg) + case msg of + Shutdown -> return () + RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc + FinishTH st -> wrapRunTH $ finishTH pipe st + _other -> run msg >>= reply + + reply :: forall a. (Binary a, Show a) => a -> IO () + reply r = do + when verbose $ putStrLn ("iserv: return: " ++ show r) + writePipe pipe (put r) + loop + + wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () + wrapRunTH io = do + r <- try io + case r of + Left e + | Just (GHCiQException _ err) <- fromException e -> do + when verbose $ putStrLn "iserv: QFail" + writePipe pipe (putMessage (QFail err)) + loop + | otherwise -> do + when verbose $ putStrLn "iserv: QException" + str <- showException e + writePipe pipe (putMessage (QException str)) + loop + Right a -> do + when verbose $ putStrLn "iserv: QDone" + writePipe pipe (putMessage QDone) + reply a + + -- carefully when showing an exception, there might be other exceptions + -- lurking inside it. If so, we return the inner exception instead. + showException :: SomeException -> IO String + showException e0 = do + r <- try $ evaluate (force (show (e0::SomeException))) + case r of + Left e -> showException e + Right str -> return str + + -- throw away any pending ^C exceptions while we're not running + -- interpreted code. GHC will also get the ^C, and either ignore it + -- (if this is GHCi), or tell us to quit with a Shutdown message. + discardCtrlC = do + r <- try $ restore $ return () + case r of + Left UserInterrupt -> return () >> discardCtrlC + Left e -> throwIO e + _ -> return () -- cgit v1.2.1