Skip to content

Commit

Permalink
Use jobs when calling subprocesses
Browse files Browse the repository at this point in the history
Many toolchain tools written for POSIX systems rely on the exec system
call. Unfortunately, it is not possible to implement `exec` in a
POSIX-compliant manner on Windows. In particular, the semantics of the
`exec` implementation provided by the widely-used `msvcrt` C runtime
will cause process's waiting on the `exec`'ing process to incorrectly
conclude that the process has successfully terminated when in fact it is
still running in another process.

For this reason, the `process` library exposes the `use_process_jobs`
flag to use a more strict (although still not POSIX-compliant) mechanism
for tracking process completion. This is explained in this comment [2].

Unfortunately, job support in the `process` library is currently quite
broken and was only recently fixed [1]. Consequently, we only enable job
object support for process releases >= 1.6.8.

[1] haskell/process#168
[2] https://github.com/haskell/process/blob/master/System/Process.hs#L399
  • Loading branch information
bgamari committed Feb 7, 2020
1 parent 1a31242 commit 8085f6a
Showing 1 changed file with 48 additions and 2 deletions.
50 changes: 48 additions & 2 deletions Cabal/Distribution/Simple/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -234,9 +234,9 @@ import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Control.Exception (IOException, evaluate, throwIO, fromException)
import Numeric (showFFloat)
import qualified System.Process as Process
( CreateProcess(..), StdStream(..), proc)
( CreateProcess(..), StdStream(..), proc, createProcess )
import System.Process
( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
( ProcessHandle, rawSystem
, showCommandForUser, waitForProcess)

import qualified GHC.IO.Exception as GHC
Expand Down Expand Up @@ -680,6 +680,52 @@ maybeExit cmd = do
res <- cmd
unless (res == ExitSuccess) $ exitWith res

-- | Enable process jobs to ensure accurate determination of process completion
-- in the presence of @exec(3)@ on Windows.
--
-- Unfortunately the process job support is badly broken in @process@ releases
-- prior to 1.6.8, so we disable it in these versions, despite the fact that
-- this means we may see sporatic build failures without jobs.
enableProcessJobs :: CreateProces -> CreateProcess
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,6,8)
enableProcessJobs cp = cp {Process.use_process_jobs = True}
#else
enableProcessJobs cp = cp
#endif
#else
enableProcessJobs cp = cp
#endif

-- | 'System.Process.createProcess' with process jobs enabled when appropriate.
-- See 'enableProcessJobs'.
createProcess :: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess = Process.createProcess . enableProcessJobs

-- | 'System.Process.rawSystem' with process jobs enabled when appropriate.
-- See 'enableProcessJobs'.
rawSystem :: String -> [String] -> IO ExitCode
rawSystem cmd args = do
(_,_,_,p) <- createProcess (proc cmd args) { delegate_ctlc = True }
waitForProcess p

-- | 'System.Process.runInteractiveProcess' with process jobs enabled when
-- appropriate. See 'enableProcessJobs'.
runInteractiveProcess
:: FilePath -- ^ Filename of the executable (see 'RawCommand' for details)
-> [String] -- ^ Arguments to pass to the executable
-> Maybe FilePath -- ^ Optional path to the working directory
-> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
-> IO (Handle,Handle,Handle,ProcessHandle)
runInteractiveProcess cmd args mb_cwd mb_env = do
(mb_in, mb_out, mb_err, p) <-
createProcess fun
cmd{ std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe }
return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)

printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args = withFrozenCallStack $
printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing
Expand Down

0 comments on commit 8085f6a

Please sign in to comment.