Skip to content

Commit cb1d1a6

Browse files
bgamaribgamari
authored
Merge pull request #177 from Mistuke/wip/new-io-manager-support
Add support for WinIO to process.
2 parents b19dd3d + b790744 commit cb1d1a6

File tree

8 files changed

+1316
-957
lines changed

8 files changed

+1316
-957
lines changed

‎System/Process/Common.hs

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,13 @@ module System.Process.Common
2626
#else
2727
, CGid
2828
#endif
29+
30+
-- WINIO is only available on GHC 8.12 and up.
31+
#if defined(__IO_MANAGER_WINIO__)
32+
, HANDLE
33+
, mbHANDLE
34+
, mbPipeHANDLE
35+
#endif
2936
) where
3037

3138
import Control.Concurrent
@@ -39,6 +46,10 @@ import GHC.IO.Exception
3946
import GHC.IO.Encoding
4047
import qualified GHC.IO.FD as FD
4148
import GHC.IO.Device
49+
#if defined(__IO_MANAGER_WINIO__)
50+
import GHC.IO.Handle.Windows
51+
import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
52+
#endif
4253
import GHC.IO.Handle.FD
4354
import GHC.IO.Handle.Internals
4455
import GHC.IO.Handle.Types hiding (ClosedHandle)
@@ -51,6 +62,9 @@ import System.IO (IOMode)
5162
#ifdef WINDOWS
5263
import Data.Word (Word32)
5364
import System.Win32.DebugApi (PHANDLE)
65+
#if defined(__IO_MANAGER_WINIO__)
66+
import System.Win32.Types (HANDLE)
67+
#endif
5468
#else
5569
import System.Posix.Types
5670
#endif
@@ -258,3 +272,25 @@ pfdToHandle pfd mode = do
258272
let enc = localeEncoding
259273
#endif
260274
mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc)
275+
276+
#if defined(__IO_MANAGER_WINIO__)
277+
-- It is not completely safe to pass the values -1 and -2 as HANDLE as it's an
278+
-- unsigned type. -1 additionally is also the value for INVALID_HANDLE. However
279+
-- it should be safe in this case since an invalid handle would be an error here
280+
-- anyway and the chances of us getting a handle with a value of -2 is
281+
-- astronomical. However, sometime in the future process should really use a
282+
-- proper structure here.
283+
mbHANDLE :: HANDLE -> StdStream -> IO HANDLE
284+
mbHANDLE _std CreatePipe = return $ intPtrToPtr (-1)
285+
mbHANDLE std Inherit = return std
286+
mbHANDLE _std NoStream = return $ intPtrToPtr (-2)
287+
mbHANDLE _std (UseHandle hdl) = handleToHANDLE hdl
288+
289+
mbPipeHANDLE :: StdStream -> Ptr HANDLE -> IOMode -> IO (Maybe Handle)
290+
mbPipeHANDLE CreatePipe pfd mode =
291+
do raw_handle <- peek pfd
292+
let hwnd = fromHANDLE raw_handle :: Io NativeHandle
293+
ident = "hwnd:" ++ show raw_handle
294+
Just <$> mkHandleFromHANDLE hwnd Stream ident mode Nothing
295+
mbPipeHANDLE _std _pfd _mode = return Nothing
296+
#endif

‎System/Process/Windows.hsc

Lines changed: 169 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,11 @@ import System.IO.Unsafe
3030

3131
import System.Posix.Internals
3232
import GHC.IO.Exception
33+
##if defined(__IO_MANAGER_WINIO__)
34+
import GHC.IO.SubSystem
35+
import Graphics.Win32.Misc
36+
import qualified GHC.Event.Windows as Mgr
37+
##endif
3338
import GHC.IO.Handle.FD
3439
import GHC.IO.Handle.Types hiding (ClosedHandle)
3540
import System.IO.Error
@@ -91,19 +96,77 @@ createProcess_Internal
9196
-> CreateProcess
9297
-> IO ProcRetHandles
9398

94-
createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
95-
cwd = mb_cwd,
96-
env = mb_env,
97-
std_in = mb_stdin,
98-
std_out = mb_stdout,
99-
std_err = mb_stderr,
100-
close_fds = mb_close_fds,
101-
create_group = mb_create_group,
102-
delegate_ctlc = _ignored,
103-
detach_console = mb_detach_console,
104-
create_new_console = mb_create_new_console,
105-
new_session = mb_new_session,
106-
use_process_jobs = use_job }
99+
##if defined(__IO_MANAGER_WINIO__)
100+
createProcess_Internal = createProcess_Internal_mio <!> createProcess_Internal_winio
101+
##else
102+
createProcess_Internal = createProcess_Internal_mio
103+
##endif
104+
105+
createProcess_Internal_mio
106+
:: String -- ^ function name (for error messages)
107+
-> CreateProcess
108+
-> IO ProcRetHandles
109+
110+
createProcess_Internal_mio fun def@CreateProcess{
111+
std_in = mb_stdin,
112+
std_out = mb_stdout,
113+
std_err = mb_stderr,
114+
close_fds = mb_close_fds,
115+
create_group = mb_create_group,
116+
delegate_ctlc = _ignored,
117+
detach_console = mb_detach_console,
118+
create_new_console = mb_create_new_console,
119+
new_session = mb_new_session,
120+
use_process_jobs = use_job }
121+
= createProcess_Internal_wrapper fun def $
122+
\pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline -> do
123+
fdin <- mbFd fun fd_stdin mb_stdin
124+
fdout <- mbFd fun fd_stdout mb_stdout
125+
fderr <- mbFd fun fd_stderr mb_stderr
126+
127+
-- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,
128+
-- because otherwise there is a race condition whereby one thread
129+
-- has created some pipes, and another thread spawns a process which
130+
-- accidentally inherits some of the pipe handles that the first
131+
-- thread has created.
132+
--
133+
-- An MVar in Haskell is the best way to do this, because there
134+
-- is no way to do one-time thread-safe initialisation of a mutex
135+
-- the C code. Also the MVar will be cheaper when not running
136+
-- the threaded RTS.
137+
proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
138+
throwErrnoIfBadPHandle fun $
139+
c_runInteractiveProcess pcmdline pWorkDir pEnv
140+
fdin fdout fderr
141+
pfdStdInput pfdStdOutput pfdStdError
142+
((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
143+
.|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)
144+
.|.(if mb_detach_console then RUN_PROCESS_DETACHED else 0)
145+
.|.(if mb_create_new_console then RUN_PROCESS_NEW_CONSOLE else 0)
146+
.|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))
147+
use_job
148+
hJob
149+
150+
hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode
151+
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
152+
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
153+
154+
return (proc_handle, hndStdInput, hndStdOutput, hndStdError)
155+
156+
157+
createProcess_Internal_wrapper
158+
:: Storable a => String -- ^ function name (for error messages)
159+
-> CreateProcess
160+
-> (Ptr a -> Ptr a -> Ptr a -> Ptr PHANDLE -> Ptr CWString -> CWString
161+
-> CWString -> IO (PHANDLE, Maybe Handle, Maybe Handle, Maybe Handle))
162+
-> IO ProcRetHandles
163+
164+
createProcess_Internal_wrapper _fun CreateProcess{
165+
cmdspec = cmdsp,
166+
cwd = mb_cwd,
167+
env = mb_env,
168+
delegate_ctlc = _ignored }
169+
action
107170
= do
108171
let lenPtr = sizeOf (undefined :: WordPtr)
109172
(cmd, cmdline) <- commandToProcess cmdsp
@@ -116,9 +179,43 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
116179
maybeWith withCWString mb_cwd $ \pWorkDir -> do
117180
withCWString cmdline $ \pcmdline -> do
118181

119-
fdin <- mbFd fun fd_stdin mb_stdin
120-
fdout <- mbFd fun fd_stdout mb_stdout
121-
fderr <- mbFd fun fd_stderr mb_stderr
182+
(proc_handle, hndStdInput, hndStdOutput, hndStdError)
183+
<- action pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline
184+
185+
phJob <- peek hJob
186+
ph <- mkProcessHandle proc_handle phJob
187+
return ProcRetHandles { hStdInput = hndStdInput
188+
, hStdOutput = hndStdOutput
189+
, hStdError = hndStdError
190+
, procHandle = ph
191+
}
192+
193+
##if defined(__IO_MANAGER_WINIO__)
194+
createProcess_Internal_winio
195+
:: String -- ^ function name (for error messages)
196+
-> CreateProcess
197+
-> IO ProcRetHandles
198+
199+
createProcess_Internal_winio fun def@CreateProcess{
200+
std_in = mb_stdin,
201+
std_out = mb_stdout,
202+
std_err = mb_stderr,
203+
close_fds = mb_close_fds,
204+
create_group = mb_create_group,
205+
delegate_ctlc = _ignored,
206+
detach_console = mb_detach_console,
207+
create_new_console = mb_create_new_console,
208+
new_session = mb_new_session,
209+
use_process_jobs = use_job }
210+
= createProcess_Internal_wrapper fun def $
211+
\pfdStdInput pfdStdOutput pfdStdError hJob pEnv pWorkDir pcmdline -> do
212+
213+
_stdin <- getStdHandle sTD_INPUT_HANDLE
214+
_stdout <- getStdHandle sTD_OUTPUT_HANDLE
215+
_stderr <- getStdHandle sTD_ERROR_HANDLE
216+
hwnd_in <- mbHANDLE _stdin mb_stdin
217+
hwnd_out <- mbHANDLE _stdout mb_stdout
218+
hwnd_err <- mbHANDLE _stderr mb_stderr
122219

123220
-- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,
124221
-- because otherwise there is a race condition whereby one thread
@@ -132,8 +229,8 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
132229
-- the threaded RTS.
133230
proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
134231
throwErrnoIfBadPHandle fun $
135-
c_runInteractiveProcess pcmdline pWorkDir pEnv
136-
fdin fdout fderr
232+
c_runInteractiveProcessHANDLE pcmdline pWorkDir pEnv
233+
hwnd_in hwnd_out hwnd_err
137234
pfdStdInput pfdStdOutput pfdStdError
138235
((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
139236
.|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)
@@ -143,17 +240,20 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
143240
use_job
144241
hJob
145242

146-
hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode
147-
hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
148-
hndStdError <- mbPipe mb_stderr pfdStdError ReadMode
243+
-- Attach the handle to the I/O manager's CompletionPort. This allows the
244+
-- I/O manager to service requests for this Handle.
245+
Mgr.associateHandle' =<< peek pfdStdInput
246+
Mgr.associateHandle' =<< peek pfdStdOutput
247+
Mgr.associateHandle' =<< peek pfdStdError
149248

150-
phJob <- peek hJob
151-
ph <- mkProcessHandle proc_handle phJob
152-
return ProcRetHandles { hStdInput = hndStdInput
153-
, hStdOutput = hndStdOutput
154-
, hStdError = hndStdError
155-
, procHandle = ph
156-
}
249+
-- Create the haskell mode handles as files.
250+
hndStdInput <- mbPipeHANDLE mb_stdin pfdStdInput WriteMode
251+
hndStdOutput <- mbPipeHANDLE mb_stdout pfdStdOutput ReadMode
252+
hndStdError <- mbPipeHANDLE mb_stderr pfdStdError ReadMode
253+
254+
return (proc_handle, hndStdInput, hndStdOutput, hndStdError)
255+
256+
##endif
157257

158258
{-# NOINLINE runInteractiveProcess_lock #-}
159259
runInteractiveProcess_lock :: MVar ()
@@ -224,6 +324,24 @@ foreign import ccall unsafe "runInteractiveProcess"
224324
-> Ptr PHANDLE -- Handle to Job
225325
-> IO PHANDLE
226326

327+
##if defined(__IO_MANAGER_WINIO__)
328+
foreign import ccall unsafe "runInteractiveProcessHANDLE"
329+
c_runInteractiveProcessHANDLE
330+
:: CWString
331+
-> CWString
332+
-> Ptr CWString
333+
-> HANDLE
334+
-> HANDLE
335+
-> HANDLE
336+
-> Ptr HANDLE
337+
-> Ptr HANDLE
338+
-> Ptr HANDLE
339+
-> CInt -- flags
340+
-> Bool -- useJobObject
341+
-> Ptr PHANDLE -- Handle to Job
342+
-> IO PHANDLE
343+
##endif
344+
227345
commandToProcess
228346
:: CmdSpec
229347
-> IO (FilePath, String)
@@ -299,7 +417,14 @@ isDefaultSignal :: CLong -> Bool
299417
isDefaultSignal = const False
300418

301419
createPipeInternal :: IO (Handle, Handle)
302-
createPipeInternal = do
420+
##if defined(__IO_MANAGER_WINIO__)
421+
createPipeInternal = createPipeInternalPosix <!> createPipeInternalHANDLE
422+
##else
423+
createPipeInternal = createPipeInternalPosix
424+
##endif
425+
426+
createPipeInternalPosix :: IO (Handle, Handle)
427+
createPipeInternalPosix = do
303428
(readfd, writefd) <- createPipeInternalFd
304429
(do readh <- fdToHandle readfd
305430
writeh <- fdToHandle writefd
@@ -313,6 +438,21 @@ createPipeInternalFd = do
313438
writefd <- peekElemOff pfds 1
314439
return (readfd, writefd)
315440

441+
##if defined(__IO_MANAGER_WINIO__)
442+
createPipeInternalHANDLE :: IO (Handle, Handle)
443+
createPipeInternalHANDLE =
444+
alloca $ \ pfdStdInput ->
445+
alloca $ \ pfdStdOutput -> do
446+
throwErrnoIf_ (==False) "c_mkNamedPipe" $
447+
c_mkNamedPipe pfdStdInput True pfdStdOutput True
448+
Just hndStdInput <- mbPipeHANDLE CreatePipe pfdStdInput WriteMode
449+
Just hndStdOutput <- mbPipeHANDLE CreatePipe pfdStdOutput ReadMode
450+
return (hndStdInput, hndStdOutput)
451+
452+
453+
foreign import ccall "mkNamedPipe" c_mkNamedPipe ::
454+
Ptr HANDLE -> Bool -> Ptr HANDLE -> Bool -> IO Bool
455+
##endif
316456

317457
close' :: CInt -> IO ()
318458
close' = throwErrnoIfMinus1_ "_close" . c__close

0 commit comments

Comments
 (0)