Commit 1da063cd authored by Tamar Christina's avatar Tamar Christina Committed by Ben Gamari

Inline process changes.

parent 1a819932
......@@ -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 ->
......
{-# 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 */
......@@ -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
......@@ -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
......
......@@ -53,6 +53,7 @@ Executable hsc2hs
UtilsCodegen
Compat.ResponseFile
Compat.TempFile
Compat.Process
Paths_hsc2hs
c-sources:
......
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