[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