runghc: use executeFile to run ghc process on POSIX
authorMichael Snoyman <michael@snoyman.com>
Sun, 2 Oct 2016 01:24:05 +0000 (21:24 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sun, 2 Oct 2016 18:57:44 +0000 (14:57 -0400)
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

testsuite/tests/runghc/Makefile
testsuite/tests/runghc/T-signals-child.hs [new file with mode: 0644]
testsuite/tests/runghc/T7859.stderr
testsuite/tests/runghc/all.T
utils/runghc/Main.hs
utils/runghc/runghc.cabal.in

index c414f84..25c2600 100644 (file)
@@ -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 (file)
index 0000000..21c1b64
--- /dev/null
@@ -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"
index f784874..59348de 100644 (file)
@@ -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)
index 7c4fad2..0fd1e76 100644 (file)
@@ -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'])
index 001d902..bcf77e7 100644 (file)
@@ -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
index efef5ec..2253292 100644 (file)
@@ -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