[commit: ghc] ghc-8.0: runghc: use executeFile to run ghc process on POSIX (c904258)
git at git.haskell.org
git at git.haskell.org
Mon Oct 10 15:00:14 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/c904258319b8eb6e47ba727c667bca765537802b/ghc
>---------------------------------------------------------------
commit c904258319b8eb6e47ba727c667bca765537802b
Author: Michael Snoyman <michael at snoyman.com>
Date: Sat Oct 1 21:24:05 2016 -0400
runghc: use executeFile to run ghc process on POSIX
This means that, on POSIX systems, there will be only one ghc process
used for running scripts, as opposed to the current situation of a
runghc process and a ghc process. Beyond minor performance benefits of
not having an extra fork and resident process, the more important impact
of this is automatically getting proper signal handling. I noticed this
problem myself when running runghc as PID1 inside a Docker container.
I attempted to create a shim library for executeFile that would work for
both POSIX and Windows, but unfortunately I ran into issues with exit
codes being propagated correctly (see
https://github.com/fpco/replace-process/issues/2). Therefore, this patch
leaves the Windows behavior unchanged. Given that signals are a POSIX
issue, this isn't too bad a trade-off. If someone has suggestions for
better Windows _exec support, please let me know.
Reviewers: erikd, austin, bgamari
Reviewed By: bgamari
Subscribers: Phyx, thomie
Differential Revision: https://phabricator.haskell.org/D2538
(cherry picked from commit 42f1d86770f963cf810aa4d31757dda8a08a52fa)
>---------------------------------------------------------------
c904258319b8eb6e47ba727c667bca765537802b
testsuite/tests/runghc/Makefile | 4 ++
testsuite/tests/runghc/T-signals-child.hs | 113 ++++++++++++++++++++++++++++++
testsuite/tests/runghc/T7859.stderr | 2 +-
testsuite/tests/runghc/all.T | 5 ++
utils/runghc/Main.hs | 24 +++++--
utils/runghc/runghc.cabal.in | 3 +
6 files changed, 144 insertions(+), 7 deletions(-)
diff --git a/testsuite/tests/runghc/Makefile b/testsuite/tests/runghc/Makefile
index f96c829..643e967 100644
--- a/testsuite/tests/runghc/Makefile
+++ b/testsuite/tests/runghc/Makefile
@@ -10,3 +10,7 @@ T7859:
#compile.
T8601:
-echo 'main = putStrLn "Hello World!"' | '$(RUNGHC)' -f '$(TEST_HC)' -hide-package --ghc-arg=bytestring
+
+T-signals-child:
+ -'$(RUNGHC)' T-signals-child.hs --runghc '$(RUNGHC)'
+
diff --git a/testsuite/tests/runghc/T-signals-child.hs b/testsuite/tests/runghc/T-signals-child.hs
new file mode 100644
index 0000000..21c1b64
--- /dev/null
+++ b/testsuite/tests/runghc/T-signals-child.hs
@@ -0,0 +1,113 @@
+import Control.Concurrent.MVar (readMVar)
+import System.Environment (getArgs)
+import System.Exit (ExitCode (ExitFailure), exitFailure)
+import System.IO (hGetLine, hPutStrLn)
+import System.Posix.Process (exitImmediately, getProcessID)
+import System.Posix.Signals (Handler (Catch), installHandler, sigHUP,
+ signalProcess)
+import System.Process (StdStream (CreatePipe), createProcess, proc,
+ std_in, std_out, waitForProcess)
+import System.Process.Internals (ProcessHandle (..),
+ ProcessHandle__ (OpenHandle))
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["--runghc", runghc] -> runParent runghc
+ ["child"] -> runChild
+ _ -> error $ "Unknown args: " ++ show args
+
+runParent :: FilePath -> IO ()
+runParent runghc = do
+ (Just inH, Just outH, Nothing, ph@(ProcessHandle mvar _)) <-
+ createProcess (proc runghc ["T-signals-child.hs", "child"])
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+
+ -- Get the PID of the actual child process. This will initially be
+ -- runghc. If executeFile is used by runghc, that same process
+ -- will become the ghc process running our code from
+ -- runChild. Otherwise, runChild will run in a child of this
+ -- process.
+ OpenHandle childPid <- readMVar mvar
+
+ -- Get the PID of the process actually running the runChild code,
+ -- by reading it from its stdout (see runChild below).
+ pidS <- hGetLine outH
+ let pid = fromIntegral (read pidS :: Int)
+
+ -- Send the child process the HUP signal. We know this is after
+ -- the signal handler has been installed, since we already got the
+ -- PID from the process.
+ signalProcess sigHUP childPid
+
+ -- Send the child some input so that it will exit if it didn't
+ -- have a sigHUP handler installed.
+ hPutStrLn inH ""
+
+ -- Read out the rest of stdout from the child, which will be
+ -- either "NOSIGNAL\n" or "HUP\n"
+ rest <- hGetLine outH
+
+ -- Get the exit code of the child
+ ec <- waitForProcess ph
+
+ -- Check that everything matches
+ if childPid /= pid || rest /= hupMessage || ec /= hupExitCode
+ then do
+ -- Debugging display
+ putStrLn $ concat
+ [ "Child process: "
+ , show childPid
+ , ", real process: "
+ , show pid
+ ]
+ putStrLn $ concat
+ [ "Expected "
+ , show hupMessage
+ , ", received: "
+ , show rest
+ ]
+ putStrLn $ concat
+ [ "Expected "
+ , show hupExitCode
+ , ", received "
+ , show ec
+ ]
+ exitFailure
+ else return ()
+
+runChild :: IO ()
+runChild = do
+ -- Install our sigHUP handler: print the HUP message and exit with
+ -- the HUP exit code.
+ let handler = Catch $ do
+ putStrLn hupMessage
+ exitImmediately hupExitCode
+ _ <- installHandler sigHUP handler Nothing
+
+ -- Get our actual process ID and print it to stdout.
+ pid <- getProcessID
+ print (fromIntegral pid :: Int)
+
+ -- Block until we receive input, giving a chance for the signal
+ -- handler to be triggered, and if the signal handler isn't
+ -- triggered, gives us an escape route from this function.
+ _ <- getLine
+
+ -- Reaching this point indicates a failure of the test. Print some
+ -- non HUP message and exit with a non HUP exit
+ -- code. Interestingly, in a failure, this exit code will _not_
+ -- be received by the parent process, since the runghc process
+ -- itself will exit with ExitFailure -1, indicating that it was
+ -- killed by signal 1 (SIGHUP).
+ putStrLn "No signal received"
+ exitImmediately $ ExitFailure 41
+
+hupExitCode :: ExitCode
+hupExitCode = ExitFailure 42
+
+hupMessage :: String
+hupMessage = "HUP"
diff --git a/testsuite/tests/runghc/T7859.stderr b/testsuite/tests/runghc/T7859.stderr
index f784874..59348de 100644
--- a/testsuite/tests/runghc/T7859.stderr
+++ b/testsuite/tests/runghc/T7859.stderr
@@ -1 +1 @@
-runghc: defer-type-errors: rawSystem: runInteractiveProcess: exec: does not exist (No such file or directory)
+runghc: defer-type-errors: executeFile: does not exist (No such file or directory)
diff --git a/testsuite/tests/runghc/all.T b/testsuite/tests/runghc/all.T
index 3ffaa20..ef3cb94 100644
--- a/testsuite/tests/runghc/all.T
+++ b/testsuite/tests/runghc/all.T
@@ -3,3 +3,8 @@ test('T7859', req_interp, run_command,
test('T8601', req_interp, run_command,
['$MAKE --no-print-directory -s T8601'])
+
+test('T-signals-child',
+ [when(opsys('mingw32'), skip), req_interp],
+ run_command,
+ ['$MAKE --no-print-directory -s T-signals-child'])
diff --git a/utils/runghc/Main.hs b/utils/runghc/Main.hs
index 001d902..bcf77e7 100644
--- a/utils/runghc/Main.hs
+++ b/utils/runghc/Main.hs
@@ -24,11 +24,13 @@ import System.Environment
import System.Exit
import System.FilePath
import System.IO
-import System.Process
#if defined(mingw32_HOST_OS)
+import System.Process (runProcess)
import Foreign
import Foreign.C.String
+#else
+import System.Posix.Process (executeFile)
#endif
#if defined(mingw32_HOST_OS)
@@ -141,11 +143,21 @@ doIt ghc ghc_args rest = do
else []
c1 = ":set prog " ++ show filename
c2 = ":main " ++ show prog_args
- res <- rawSystem ghc (["-ignore-dot-ghci"] ++
- xflag ++
- ghc_args ++
- [ "-e", c1, "-e", c2, filename])
- exitWith res
+
+ let cmd = ghc
+ args = ["-ignore-dot-ghci"] ++
+ xflag ++
+ ghc_args ++
+ [ "-e", c1, "-e", c2, filename]
+
+
+#if defined(mingw32_HOST_OS)
+ rawSystem cmd args >>= exitWith
+#else
+ -- Passing False to avoid searching the PATH, since the cmd should
+ -- always be an absolute path to the ghc executable.
+ executeFile cmd False args Nothing
+#endif
getGhcArgs :: [String] -> ([String], [String])
getGhcArgs args
diff --git a/utils/runghc/runghc.cabal.in b/utils/runghc/runghc.cabal.in
index efef5ec..2253292 100644
--- a/utils/runghc/runghc.cabal.in
+++ b/utils/runghc/runghc.cabal.in
@@ -30,3 +30,6 @@ Executable runghc
directory >= 1 && < 1.3,
process >= 1 && < 1.5,
filepath
+
+ if !os(windows)
+ build-depends: unix
\ No newline at end of file
More information about the ghc-commits
mailing list