[MLton-commit] r7207
Wesley Terpstra
wesley at mlton.org
Sat Jul 4 12:28:13 PDT 2009
Fixed test-{spawn,create} on MinGW:
* Removed cwait in favour of implementing waitpid
* waitpid supports WNOHANG
* catch waitpid (pid <= 0) in stub-mingw.sml
* Implemented kill
* removed from stub-mingw.sml
* Use the high bit of exit status to indicate termination by a signal
* Reimplement WIFEXITED/etc macros
* I have no idea where the old code is from, but it was wrong
* Make use of the high bit from kill to distinguish WIFSIGNALLED
----------------------------------------------------------------------
U mlton/trunk/basis-library/posix/process.sml
U mlton/trunk/basis-library/posix/stub-mingw.sml
U mlton/trunk/basis-library/primitive/basis-ffi.sml
U mlton/trunk/runtime/basis-ffi.h
U mlton/trunk/runtime/gen/basis-ffi.def
U mlton/trunk/runtime/gen/basis-ffi.h
U mlton/trunk/runtime/gen/basis-ffi.sml
U mlton/trunk/runtime/platform/mingw.c
U mlton/trunk/runtime/platform/mingw.h
U mlton/trunk/runtime/platform/nonwin.c
U mlton/trunk/runtime/platform/windows.c
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/posix/process.sml
===================================================================
--- mlton/trunk/basis-library/posix/process.sml 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/basis-library/posix/process.sml 2009-07-04 19:28:11 UTC (rev 7207)
@@ -102,9 +102,6 @@
val status: C_Status.t ref = ref (C_Status.fromInt 0)
fun wait (wa, status, flags) =
let
- val useCwait =
- Primitive.MLton.Platform.OS.host = Primitive.MLton.Platform.OS.MinGW
- andalso case wa of W_CHILD _ => true | _ => false
val pid =
case wa of
W_ANY_CHILD => C_PId.castFromFixedInt ~1
@@ -116,10 +113,7 @@
(PId.fromRep o SysCall.simpleResultRestart')
({errVal = C_PId.castFromFixedInt ~1}, fn () =>
let
- val pid =
- if useCwait
- then PrimitiveFFI.MLton.Process.cwait (pid, status)
- else Prim.waitpid (pid, status, flags)
+ val pid = Prim.waitpid (pid, status, flags)
in
pid
end)
Modified: mlton/trunk/basis-library/posix/stub-mingw.sml
===================================================================
--- mlton/trunk/basis-library/posix/stub-mingw.sml 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/basis-library/posix/stub-mingw.sml 2009-07-04 19:28:11 UTC (rev 7207)
@@ -89,11 +89,12 @@
val exece = stub ("exece", exece)
val execp = stub ("execp", execp)
- (*val exit = stub ("exit", exit)*)
val fork = stub ("fork", fork)
- val kill = stub ("kill", kill)
val pause = stub ("pause", pause)
- val waitpid = stub ("waitpid", waitpid)
+ val waitpid = fn (args as (pid, _, _)) =>
+ if pid <= 0
+ then stub ("waitpid", waitpid) args
+ else waitpid args
end
structure SysDB =
Modified: mlton/trunk/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/trunk/basis-library/primitive/basis-ffi.sml 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/basis-library/primitive/basis-ffi.sml 2009-07-04 19:28:11 UTC (rev 7207)
@@ -81,7 +81,6 @@
end
structure Process =
struct
-val cwait = _import "MLton_Process_cwait" private : C_PId.t * (C_Status.t) ref -> (C_PId.t) C_Errno.t;
val spawne = _import "MLton_Process_spawne" private : NullString8.t * (NullString8.t) array * (NullString8.t) array -> (C_PId.t) C_Errno.t;
val spawnp = _import "MLton_Process_spawnp" private : NullString8.t * (NullString8.t) array -> (C_PId.t) C_Errno.t;
end
Modified: mlton/trunk/runtime/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/basis-ffi.h 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/basis-ffi.h 2009-07-04 19:28:11 UTC (rev 7207)
@@ -52,7 +52,6 @@
PRIVATE extern const C_Int_t MLton_Itimer_REAL;
PRIVATE C_Errno_t(C_Int_t) MLton_Itimer_set(C_Int_t,C_Time_t,C_SUSeconds_t,C_Time_t,C_SUSeconds_t);
PRIVATE extern const C_Int_t MLton_Itimer_VIRTUAL;
-PRIVATE C_Errno_t(C_PId_t) MLton_Process_cwait(C_PId_t,Ref(C_Status_t));
PRIVATE C_Errno_t(C_PId_t) MLton_Process_spawne(NullString8_t,Array(NullString8_t),Array(NullString8_t));
PRIVATE C_Errno_t(C_PId_t) MLton_Process_spawnp(NullString8_t,Array(NullString8_t));
PRIVATE extern const C_Int_t MLton_Rlimit_AS;
Modified: mlton/trunk/runtime/gen/basis-ffi.def
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.def 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/gen/basis-ffi.def 2009-07-04 19:28:11 UTC (rev 7207)
@@ -42,7 +42,6 @@
MLton.Itimer.REAL = _const : C_Int.t
MLton.Itimer.VIRTUAL = _const : C_Int.t
MLton.Itimer.set = _import PRIVATE : C_Int.t * C_Time.t * C_SUSeconds.t * C_Time.t * C_SUSeconds.t -> C_Int.t C_Errno.t
-MLton.Process.cwait = _import PRIVATE : C_PId.t * C_Status.t ref -> C_PId.t C_Errno.t
MLton.Process.spawne = _import PRIVATE : NullString8.t * NullString8.t array * NullString8.t array -> C_PId.t C_Errno.t
MLton.Process.spawnp = _import PRIVATE : NullString8.t * NullString8.t array -> C_PId.t C_Errno.t
MLton.Rlimit.AS = _const : C_Int.t
Modified: mlton/trunk/runtime/gen/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.h 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/gen/basis-ffi.h 2009-07-04 19:28:11 UTC (rev 7207)
@@ -52,7 +52,6 @@
PRIVATE extern const C_Int_t MLton_Itimer_REAL;
PRIVATE C_Errno_t(C_Int_t) MLton_Itimer_set(C_Int_t,C_Time_t,C_SUSeconds_t,C_Time_t,C_SUSeconds_t);
PRIVATE extern const C_Int_t MLton_Itimer_VIRTUAL;
-PRIVATE C_Errno_t(C_PId_t) MLton_Process_cwait(C_PId_t,Ref(C_Status_t));
PRIVATE C_Errno_t(C_PId_t) MLton_Process_spawne(NullString8_t,Array(NullString8_t),Array(NullString8_t));
PRIVATE C_Errno_t(C_PId_t) MLton_Process_spawnp(NullString8_t,Array(NullString8_t));
PRIVATE extern const C_Int_t MLton_Rlimit_AS;
Modified: mlton/trunk/runtime/gen/basis-ffi.sml
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.sml 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/gen/basis-ffi.sml 2009-07-04 19:28:11 UTC (rev 7207)
@@ -81,7 +81,6 @@
end
structure Process =
struct
-val cwait = _import "MLton_Process_cwait" private : C_PId.t * (C_Status.t) ref -> (C_PId.t) C_Errno.t;
val spawne = _import "MLton_Process_spawne" private : NullString8.t * (NullString8.t) array * (NullString8.t) array -> (C_PId.t) C_Errno.t;
val spawnp = _import "MLton_Process_spawnp" private : NullString8.t * (NullString8.t) array -> (C_PId.t) C_Errno.t;
end
Modified: mlton/trunk/runtime/platform/mingw.c
===================================================================
--- mlton/trunk/runtime/platform/mingw.c 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/platform/mingw.c 2009-07-04 19:28:11 UTC (rev 7207)
@@ -847,11 +847,13 @@
die ("fork not implemented");
}
-
-__attribute__ ((noreturn))
-int kill (__attribute__ ((unused)) pid_t pid,
- __attribute__ ((unused)) int sig) {
- die ("kill not implemented");
+int kill (pid_t pid, int sig) {
+ HANDLE h = (HANDLE)pid;
+ unless (TerminateProcess (h, SIGNALLED_BIT | sig)) {
+ errno = ECHILD;
+ return -1;
+ }
+ return 0;
}
int nanosleep (const struct timespec *req, struct timespec *rem) {
@@ -876,11 +878,31 @@
die ("wait not implemented");
}
-__attribute__ ((noreturn))
-pid_t waitpid (__attribute__ ((unused)) pid_t pid,
- __attribute__ ((unused)) int *status,
- __attribute__ ((unused)) int options) {
- die ("waitpid not implemented");
+pid_t waitpid (pid_t pid, int *status, int options) {
+ HANDLE h;
+ DWORD delay;
+
+ /* pid <= 0 is handled in stub-mingw.sml */
+ h = (HANDLE)pid;
+
+ delay = ((options & WNOHANG) != 0) ? 0 : INFINITE;
+
+ switch (WaitForSingleObject (h, delay)) {
+ case WAIT_OBJECT_0: /* process has exited */
+ break;
+ case WAIT_TIMEOUT: /* process has not exited */
+ return 0;
+ default: /* some sort of error */
+ errno = ECHILD;
+ return -1;
+ }
+
+ unless (GetExitCodeProcess (h, (DWORD*)status)) {
+ errno = ECHILD;
+ return -1;
+ }
+
+ return pid;
}
/* ------------------------------------------------- */
@@ -1131,18 +1153,6 @@
}
/* ------------------------------------------------- */
-/* Process */
-/* ------------------------------------------------- */
-
-C_PId_t MLton_Process_cwait (C_PId_t pid, Pointer status) {
- HANDLE h;
-
- h = (HANDLE)pid;
- /* -1 on error, the casts here are due to bad types on both sides */
- return _cwait ((int*)status, (_pid_t)h, 0);
-}
-
-/* ------------------------------------------------- */
/* Socket */
/* ------------------------------------------------- */
Modified: mlton/trunk/runtime/platform/mingw.h
===================================================================
--- mlton/trunk/runtime/platform/mingw.h 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/platform/mingw.h 2009-07-04 19:28:11 UTC (rev 7207)
@@ -831,15 +831,16 @@
#define EXECVP(file, args) execvp (file, (const char* const*) args)
#define SPAWN_MODE _P_NOWAIT
-/* A status looks like:
- <2 bytes info> <2 bytes code>
+/* Windows exit status comes from:
+ * 1. ExitProcess (used by return from main and exit)
+ * 2. TerminateProcess (used by a remote process to 'kill')
+ *
+ * Windows does NOT differentiate between these two cases.
+ * The waitpid API expects us to be able to tell the difference,
+ * so we will emulate this difference by setting high 31st bit
+ * whenever we 'kill' a process.
+ */
- <code> == 0, child has exited, info is the exit value
- <code> == 1..7e, child has exited, info is the signal number.
- <code> == 7f, child has stopped, info was the signal number.
- <code> == 80, there was a core dump.
-*/
-
#ifndef WNOHANG
#define WNOHANG 1
#endif
@@ -848,24 +849,26 @@
#define WUNTRACED 2
#endif
+#define SIGNALLED_BIT 0x80000000UL
+
#ifndef WIFEXITED
-#define WIFEXITED(w) (((w) & 0xff) == 0)
+#define WIFEXITED(w) (((w) & SIGNALLED_BIT) == 0)
#endif
#ifndef WIFSIGNALED
-#define WIFSIGNALED(w) (((w) & 0x7f) > 0 && (((w) & 0x7f) < 0x7f))
+#define WIFSIGNALED(w) (((w) & SIGNALLED_BIT) != 0)
#endif
#ifndef WIFSTOPPED
-#define WIFSTOPPED(w) (((w) & 0xff) == 0x7f)
+#define WIFSTOPPED(w) 0
#endif
#ifndef WEXITSTATUS
-#define WEXITSTATUS(w) (((w) >> 8) & 0xff)
+#define WEXITSTATUS(w) ((w) & 0xff)
#endif
#ifndef WTERMSIG
-#define WTERMSIG(w) ((w) & 0x7f)
+#define WTERMSIG(w) ((w) & 0xff)
#endif
#ifndef WSTOPSIG
Modified: mlton/trunk/runtime/platform/nonwin.c
===================================================================
--- mlton/trunk/runtime/platform/nonwin.c 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/platform/nonwin.c 2009-07-04 19:28:11 UTC (rev 7207)
@@ -11,13 +11,3 @@
void Posix_IO_settext (__attribute__ ((unused)) C_Fd_t fd) {
die("Posix_IO_settext not implemented");
}
-
-/* ------------------------------------------------- */
-/* Process */
-/* ------------------------------------------------- */
-
-__attribute__ ((noreturn))
-C_Errno_t(C_PId_t) MLton_Process_cwait (__attribute__ ((unused)) C_PId_t pid,
- __attribute__ ((unused)) Ref(C_Status_t) status) {
- die("MLton_Process_cwait not implemented");
-}
Modified: mlton/trunk/runtime/platform/windows.c
===================================================================
--- mlton/trunk/runtime/platform/windows.c 2009-07-04 16:55:26 UTC (rev 7206)
+++ mlton/trunk/runtime/platform/windows.c 2009-07-04 19:28:11 UTC (rev 7207)
@@ -423,7 +423,7 @@
HANDLE h;
h = (HANDLE)pid;
- unless (TerminateProcess (h, sig)) {
+ unless (TerminateProcess (h, 0x80000000UL | sig)) {
errno = ECHILD;
return -1;
}
More information about the MLton-commit
mailing list