Commit 42f1d867 authored by Michael Snoyman's avatar Michael Snoyman Committed by Ben Gamari
Browse files

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 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:
parent 4d2b15d5
......@@ -22,3 +22,6 @@ T11247:
# ""
-'$(RUNGHC)' foo.
-'$(RUNGHC)' T-signals-child.hs --runghc '$(RUNGHC)'
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,
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
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"
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)
......@@ -8,3 +8,8 @@ test('T11247', [req_interp, expect_broken(11247)], run_command,
['$MAKE --no-print-directory -s T11247'])
test('T6132', [], compile, [''])
[when(opsys('mingw32'), skip), req_interp],
['$MAKE --no-print-directory -s T-signals-child'])
......@@ -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
import System.Posix.Process (executeFile)
#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
-- 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
getGhcArgs :: [String] -> ([String], [String])
getGhcArgs args
......@@ -30,3 +30,6 @@ Executable runghc
directory >= 1 && < 1.3,
process >= 1 && < 1.5,
if !os(windows)
build-depends: unix
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment