Common.hs

@@ -3,6 +3,7 @@ module Common where
 
 import qualified Control.Exception as Exception
 import qualified Compat.TempFile as Compat
+import qualified Compat.Process  as Proc
 import Control.Monad            ( when )
 import Data.Char                ( isSpace )
 import Data.List                ( foldl' )
@@ -11,8 +12,8 @@ import System.IO
 import Control.Concurrent       ( threadDelay )
 import System.IO.Error          ( isPermissionError )
 #endif
-import System.Process           ( createProcess, waitForProcess
-                                , proc, CreateProcess(..), StdStream(..) )
+import System.Process           ( createProcess, proc, CreateProcess(..)
+                                , StdStream(..) )
 import System.Exit              ( ExitCode(..), exitWith )
 import System.Directory         ( removeFile )
 
@@ -43,7 +44,7 @@ rawSystemL outDir outBase action flg prog args = withResponseFile outDir outBase
     , use_process_jobs = True
 #endif
     }
-  exitStatus <- waitForProcess ph
+  exitStatus <- Proc.waitForProcess ph
   case exitStatus of
     ExitFailure exitCode ->
       do errdata <- maybeReadHandle progerr
@@ -71,7 +72,7 @@ rawSystemWithStdOutL outDir outBase action flg prog args outFile = withResponseF
          , use_process_jobs = True
 #endif
          }
-  exitStatus <- waitForProcess process
+  exitStatus <- Proc.waitForProcess process
   hClose hOut
   case exitStatus of
     ExitFailure exitCode ->

Compat/Process.hs

+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 704
+{-# LANGUAGE Safe #-}
+#endif
+
+#if (!MIN_VERSION_process(1,6,7) \
+    && defined(mingw32_HOST_OS) \
+    && MIN_VERSION_process(1,5,0))
+#define NEEDS_PROCESS_WORKAROUND 1
+#else
+#define NEEDS_PROCESS_WORKAROUND 0
+#endif
+
+#if NEEDS_PROCESS_WORKAROUND
+{-# LANGUAGE InterruptibleFFI #-}
+#endif
+
+-- This module backports `waitForProcess` from version 1.6.6.1 of the process
+-- library in order to fix an issue with processes calling spawn or execv not
+-- being waited on correctly on Windows when using older versions of hsc2hs.
+--
+-- See also https://gitlab.haskell.org/ghc/ghc/issues/10731
+--
+-- When hsc2hs supports process 1.6.6.1 as minimum then this module can be
+-- removed.
+module Compat.Process (
+    waitForProcess
+  ) where
+
+#if NEEDS_PROCESS_WORKAROUND
+import Control.Concurrent
+import Data.Maybe
+
+import Foreign.C
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+
+import System.Process.Internals hiding (waitForJobCompletion)
+import System.Exit      ( ExitCode(..) )
+
+#else
+import qualified System.Process as Process
+import System.Process (ProcessHandle)
+import System.Exit      ( ExitCode() )
+#endif
+
+-- ----------------------------------------------------------------------------
+-- waitForProcess
+
+{- | Waits for the specified process to terminate, and returns its exit code.
+
+GHC Note: in order to call @waitForProcess@ without blocking all the
+other threads in the system, you must compile the program with
+@-threaded@.
+
+(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@
+indicates that the child was terminated by signal @/signum/@.
+The signal numbers are platform-specific, so to test for a specific signal use
+the constants provided by "System.Posix.Signals" in the @unix@ package.
+Note: core dumps are not reported, use "System.Posix.Process" if you need this
+detail.
+
+-}
+waitForProcess
+  :: ProcessHandle
+  -> IO ExitCode
+#if !NEEDS_PROCESS_WORKAROUND
+waitForProcess ph = Process.waitForProcess ph
+#else
+waitForProcess ph = lockWaitpid $ do
+  p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_)
+  case p_ of
+    OpenExtHandle _ job iocp ->
+        maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite
+      where mkExitCode code | code == 0 = ExitSuccess
+                            | otherwise = ExitFailure $ fromIntegral code
+    _  -> error "Only supports waiting for process jobs. Use process directly."
+  where
+    -- If more than one thread calls `waitpid` at a time, `waitpid` will
+    -- return the exit code to one of them and (-1) to the rest of them,
+    -- causing an exception to be thrown.
+    -- Cf. https://github.com/haskell/process/issues/46, and
+    -- https://github.com/haskell/process/pull/58 for further discussion
+    lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m
+
+waitForJobCompletion :: PHANDLE
+                     -> PHANDLE
+                     -> CUInt
+                     -> IO (Maybe CInt)
+waitForJobCompletion job io timeout =
+            alloca $ \p_exitCode -> do
+              items <- newMVar $ []
+              setter <- mkSetter (insertItem items)
+              getter <- mkGetter (getItem items)
+              ret <- c_waitForJobCompletion job io timeout p_exitCode setter getter
+              if ret == 0
+                 then Just <$> peek p_exitCode
+                 else return Nothing
+
+insertItem :: MVar [(k, v)] -> k -> v -> IO ()
+insertItem env_ k v = modifyMVar_ env_ (return . ((k, v):))
+
+getItem :: Eq k => MVar [(k, v)] -> k -> IO v
+getItem env_ k = withMVar env_ (\m -> return $ fromJust $ lookup k m)
+
+-- ----------------------------------------------------------------------------
+-- Interface to C bits
+
+type SetterDef = CUInt -> Ptr () -> IO ()
+type GetterDef = CUInt -> IO (Ptr ())
+
+foreign import ccall "wrapper"
+  mkSetter :: SetterDef -> IO (FunPtr SetterDef)
+foreign import ccall "wrapper"
+  mkGetter :: GetterDef -> IO (FunPtr GetterDef)
+
+foreign import ccall interruptible "__waitForJobCompletion" -- NB. safe - can block
+  c_waitForJobCompletion
+        :: PHANDLE
+        -> PHANDLE
+        -> CUInt
+        -> Ptr CInt
+        -> FunPtr (SetterDef)
+        -> FunPtr (GetterDef)
+        -> IO CInt
+#endif /* NEEDS_TEMP_WORKAROUND */

Compat/TempFile.hs

@@ -14,8 +14,12 @@ module Compat.TempFile (
     openTempFile
   ) where
 
-#define NEEDS_TEMP_WORKAROUND (!MIN_VERSION_base(4,14,0) \
-                               && defined(mingw32_HOST_OS))
+#if (!MIN_VERSION_base(4,14,0) \
+     && defined(mingw32_HOST_OS))
+#define NEEDS_TEMP_WORKAROUND 1
+#else
+#define NEEDS_TEMP_WORKAROUND 0
+#endif
 
 #if NEEDS_TEMP_WORKAROUND
 import Data.Bits
@@ -148,4 +152,4 @@ output_flags = std_flags
 std_flags, output_flags, rw_flags :: CInt
 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 rw_flags     = output_flags .|. o_RDWR
-#endif /* NEEDS_TEMP_WORKAROUND */
\ No newline at end of file
+#endif /* NEEDS_TEMP_WORKAROUND */

cbits/utils.c

@@ -73,4 +73,109 @@ bool __get_temp_file_name (wchar_t* pathName, wchar_t* prefix,
 
   return success;
 }
+
+typedef void(*setterDef)(DWORD, HANDLE);
+typedef HANDLE(*getterDef)(DWORD);
+typedef PHANDLE ProcHandle;
+
+/* Copied from cbits/runProcess.c in version 1.6.6.1 of the process library
+   Check there for any bugfixes first and please keep in sync when making
+   changes.  Drop this when that version is the minimal supported process
+   version.  */
+
+static int
+waitForProcess (ProcHandle handle, int *pret)
+{
+    DWORD retCode;
+
+    if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0)
+    {
+        if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0)
+        {
+            maperrno();
+            return -1;
+        }
+        *pret = retCode;
+        return 0;
+    }
+
+    maperrno();
+    return -1;
+}
+
+
+int
+__waitForJobCompletion ( HANDLE hJob, HANDLE ioPort, DWORD timeout,
+                         int *pExitCode, setterDef set, getterDef get )
+{
+    DWORD CompletionCode;
+    ULONG_PTR CompletionKey;
+    LPOVERLAPPED Overlapped;
+    *pExitCode = 0;
+
+    // We have to loop here. It's a blocking call, but
+    // we get notified on each completion event. So if it's
+    // not one we care for we should just block again.
+    // If all processes are finished before this call is made
+    // then the initial call will return false.
+    // List of events we can listen to:
+    // https://msdn.microsoft.com/en-us/library/windows/desktop/ms684141(v=vs.85).aspx
+    while (GetQueuedCompletionStatus (ioPort, &CompletionCode,
+                                      &CompletionKey, &Overlapped, timeout)) {
+
+        // If event wasn't meant of us, keep listening.
+        if ((HANDLE)CompletionKey != hJob)
+          continue;
+
+        switch (CompletionCode)
+        {
+            case JOB_OBJECT_MSG_NEW_PROCESS:
+            {
+                // A new child process is born.
+                // Retrieve and save the process handle from the process id.
+                // We'll need it for later but we can't retrieve it after the
+                // process has exited.
+                DWORD pid    = (DWORD)(uintptr_t)Overlapped;
+                HANDLE pHwnd = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION,
+                                           TRUE, pid);
+                set(pid, pHwnd);
+            }
+            break;
+            case JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS:
+            case JOB_OBJECT_MSG_EXIT_PROCESS:
+            {
+                // A child process has just exited.
+                // Read exit code, We assume the last process to exit
+                // is the process whose exit code we're interested in.
+                HANDLE pHwnd = get((DWORD)(uintptr_t)Overlapped);
+                if (GetExitCodeProcess(pHwnd, (DWORD *)pExitCode) == 0)
+                {
+                    maperrno();
+                    return 1;
+                }
+
+                // Check to see if the child has actually exited.
+                if (*(DWORD *)pExitCode == STILL_ACTIVE)
+                  waitForProcess ((ProcHandle)pHwnd, pExitCode);
+            }
+            break;
+            case JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO:
+                // All processes in the tree are done.
+                return 0;
+            default:
+                break;
+        }
+    }
+
+    // Check to see if a timeout has occurred or that the
+    // all processes in the job were finished by the time we
+    // got to the loop.
+    if (Overlapped == NULL && (HANDLE)CompletionKey != hJob)
+    {
+        // Timeout occurred.
+        return -1;
+    }
+
+    return 0;
+}
 #endif
\ No newline at end of file

changelog.md

@@ -3,6 +3,8 @@
  - Fix race condition when using response files (#30)
  - Add extra diagnostics when hsc2hs sub-process fails
    and make TempFile creation fully atomic on Windows. See (#33)
+ - Inline part of the process library in order to make Windows wait correctly
+   for the termination of a process when execv or spawn are used. See (#39)
 
 ## 0.68.6
 

hsc2hs.cabal

@@ -53,6 +53,7 @@ Executable hsc2hs
         UtilsCodegen
         Compat.ResponseFile
         Compat.TempFile
+        Compat.Process
         Paths_hsc2hs
 
     c-sources: