1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #include <caml/mlvalues.h>
17 #include <caml/alloc.h>
18 #include <caml/memory.h>
19 #include <caml/signals.h>
20 #include "unixsupport.h"
21 #include <windows.h>
22 #include <sys/types.h>
23
alloc_process_status(HANDLE pid,int status)24 static value alloc_process_status(HANDLE pid, int status)
25 {
26 value res, st;
27
28 st = caml_alloc(1, 0);
29 Field(st, 0) = Val_int(status);
30 Begin_root (st);
31 res = caml_alloc_small(2, 0);
32 Field(res, 0) = Val_long((intnat) pid);
33 Field(res, 1) = st;
34 End_roots();
35 return res;
36 }
37
38 enum { CAML_WNOHANG = 1, CAML_WUNTRACED = 2 };
39
40 static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED };
41
win_waitpid(value vflags,value vpid_req)42 CAMLprim value win_waitpid(value vflags, value vpid_req)
43 {
44 int flags;
45 DWORD status, retcode;
46 HANDLE pid_req = (HANDLE) Long_val(vpid_req);
47 DWORD err = 0;
48
49 flags = caml_convert_flag_list(vflags, wait_flag_table);
50 if ((flags & CAML_WNOHANG) == 0) {
51 caml_enter_blocking_section();
52 retcode = WaitForSingleObject(pid_req, INFINITE);
53 if (retcode == WAIT_FAILED) err = GetLastError();
54 caml_leave_blocking_section();
55 if (err) {
56 win32_maperr(err);
57 uerror("waitpid", Nothing);
58 }
59 }
60 if (! GetExitCodeProcess(pid_req, &status)) {
61 win32_maperr(GetLastError());
62 uerror("waitpid", Nothing);
63 }
64 if (status == STILL_ACTIVE)
65 return alloc_process_status((HANDLE) 0, 0);
66 else {
67 CloseHandle(pid_req);
68 return alloc_process_status(pid_req, status);
69 }
70 }
71