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

6 files changed, 143 insertions, 7 deletions

diff --git a/testsuite/tests/runghc/Makefile b/testsuite/tests/runghc/Makefile
index c414f84ed4..25c2600f45 100644
--- a/testsuite/tests/runghc/Makefile
+++ b/testsuite/tests/runghc/Makefile
@@ -22,3 +22,6 @@ T11247:
 	# "foo.bar"
 	-'$(RUNGHC)' foo.
 	-'$(RUNGHC)' foo.bar
+
+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 0000000000..21c1b646ae
--- /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 f784874848..59348de4d2 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 7c4fad251f..0fd1e76c3c 100644
--- a/testsuite/tests/runghc/all.T
+++ b/testsuite/tests/runghc/all.T
@@ -8,3 +8,8 @@ test('T11247', [req_interp, expect_broken(11247)], run_command,
      ['$MAKE --no-print-directory -s T11247'])
 
 test('T6132', [], compile, [''])
+
+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 001d902f80..bcf77e7b8a 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 efef5ec4db..2253292cf0 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