[MLton] Finished (?) MLton.Child

Wesley W. Terpstra terpstra@gkec.tu-darmstadt.de
Sun, 28 Nov 2004 00:27:09 +0100


--nFreZHaLTZJo0R7j
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

On Thu, Nov 25, 2004 at 11:53:50AM -0800, Stephen Weeks wrote:
> > carrot:~$ mlton test.sml
> > call to system failed with Function not implemented:
> > gcc -c -I/usr/lib/mlton/include -O1 ....
> > 
> > Any ideas? It's stopping me from testing the current CVS.
> 
> Whoops.  I switched the test on forkIsEnabled in posix/process.sml.
> I've checked in a fix.

Now when I rebuild cvs/HEAD mlton under cygwin for cygwin I still get an
unusable compiler (with default options):

call to system failed with exit status 80:
gcc -c -I/home/terpstra/src/mlton/head/build/bin/../lib/include -O1
-fno-strict-aliasing -fomit-frame-pointer -w -fno-strength-reduce
-fschedule-insns -fschedule-insns2 -malign-functions=5 -malign-jumps=2
-malign-loops=2 -mcpu=pentiumpro -o /tmp/fileE2X1rE.o /tmp/fileieAdg1.1.c

Using 'mlton @MLton use-mmap -- test.sml' does succeed in building.
It also now works in linux again.

Why is system() and/or spawn() broken?
My patch did not touch these.

Using mlton+mmap compiles, but the resulting binary is also FUBAR'd.
When run with '@MLton use-mmap --' I get:
unhandled exception: SysErr: Function not implemented [nosys]
What function is unimplemented? 
This is cygwin+mmap! This worked with my patch.

I have not tried mingw at all since it takes me about three hours to rebuild
mlton under windows and I got quite frustrated after repeated problems.

I don't understand what is going on! The patch I sent you did not cause any
of these problems on my systems and I tested it very thoroughly.

I was trying to prepare a patch to make cygwin+VirtualAlloc+CreateProcess
work. However, I am unable to test it because the cvs compiler is unusable 
under cygwin. I have attached it in case your compiler still works.

-- 
Wesley W. Terpstra <wesley@terpstra.ca>

--nFreZHaLTZJo0R7j
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="cygwin-cp.patch"

? tmp.c
? mlton/1548.sml
? mlton/2112.sml
? mlton/2272
? mlton/2272.sml
? mlton/2380.sml
? mlton/2496.sml
? mlton/256.sml
? mlton/2764.sml
? mlton/3040.sml
? mlton/3728.sml
? mlton/3840.sml
? mlton/692.sml
? mlton/mlton-compile.stackdump
Index: basis-library/misc/primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.132
diff -u -r1.132 primitive.sml
--- basis-library/misc/primitive.sml	25 Nov 2004 04:39:58 -0000	1.132
+++ basis-library/misc/primitive.sml	27 Nov 2004 22:52:08 -0000
@@ -927,6 +927,12 @@
 		  val create = 
 		     _import "MLton_Process_create"
 		     : NullString.t * NullString.t * int * int * int -> Pid.t;
+                  val terminate =
+                     _import "MLton_Process_terminate"
+                     : Pid.t * int -> int;
+                  val cwait =
+                     _import "MLton_Process_cwait"
+                     : Pid.t * int ref -> Pid.t;
 		  val spawne =
 		     _import "MLton_Process_spawne"
 		     : (NullString.t * NullString.t array * NullString.t array
Index: basis-library/mlton/process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/process.sml,v
retrieving revision 1.17
diff -u -r1.17 process.sml
--- basis-library/mlton/process.sml	25 Nov 2004 04:39:58 -0000	1.17
+++ basis-library/mlton/process.sml	27 Nov 2004 22:52:08 -0000
@@ -186,7 +186,27 @@
 	 in
 	    DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all)
 	 end
-
+      
+      local
+         fun sys (pid, status) =
+           SysCall.syscall
+	   (fn () =>
+            let 
+	       val p = Prim.cwait (pid, status)
+	       val p' = Pid.toInt p
+	    in
+	       (p', fn () => p)
+	    end)
+      in
+         fun cwait pid =
+            let
+               val status: int ref = ref 0
+               val pid = sys (pid, status)
+            in
+               (pid, Process.fromStatus (Exit.Status.fromInt (!status)))
+            end
+      end
+      
       fun reap (T {pid, status, stderr, stdin, stdout}) =
 	 case !status of
 	    NONE => 
@@ -195,18 +215,28 @@
 		  (* protect is probably too much; typically, one
 		   * would only mask SIGINT, SIGQUIT and SIGHUP
 		   *)
-		  val (_, st) = protect Process.waitpid (Process.W_CHILD pid, [])
+		  val (_, st) = 
+		    if useWindowsProcess
+		    then cwait pid
+		    else protect Process.waitpid (Process.W_CHILD pid, [])
 		  val () = status := SOME st
 	       in
 		  st
 	       end
 	  | SOME status => status
 	 
+      fun terminate (pid, s) =
+         SysCall.simple
+         (fn () => Prim.terminate (pid, PosixSignal.toInt s))
+
       fun kill (p as T {pid, status, ...}, signal) =
         case !status of
 	   NONE =>
 	      let
-		 val () = Process.kill (Process.K_PROC pid, signal)
+		 val () = 
+		   if useWindowsProcess
+		   then terminate (pid, signal)
+		   else Process.kill (Process.K_PROC pid, signal)
 	      in
 		 ignore (reap p)
 	      end
Index: runtime/platform.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform.h,v
retrieving revision 1.11
diff -u -r1.11 platform.h
--- runtime/platform.h	25 Nov 2004 04:39:59 -0000	1.11
+++ runtime/platform.h	27 Nov 2004 22:52:11 -0000
@@ -392,8 +392,12 @@
 /*           MLton.Process            */
 /* ---------------------------------- */
 
+/* these are different pids are should stick together */
 Pid MLton_Process_create (NullString cmds, NullString envs,
 				Fd in, Fd out, Fd err);
+Int MLton_Process_terminate(Pid p, Int s);
+Pid MLton_Process_cwait(Pid p, Pointer s);
+
 Int MLton_Process_spawne (NullString p, Pointer a, Pointer e);
 Int MLton_Process_spawnp (NullString p, Pointer a);
 
Index: runtime/platform/create.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/create.c,v
retrieving revision 1.1
diff -u -r1.1 create.c
--- runtime/platform/create.c	25 Nov 2004 01:35:49 -0000	1.1
+++ runtime/platform/create.c	27 Nov 2004 22:52:11 -0000
@@ -1,7 +1,7 @@
 static HANDLE dupHandle (int fd) {
 	HANDLE raw, dupd;
 	
-	raw = (HANDLE)_get_osfhandle (fd);
+	raw = (HANDLE)GET_OSFHANDLE(fd);
 	if (raw == (HANDLE)-1 || raw == 0) {
 		errno = EBADF;
 		return 0;
@@ -79,3 +79,17 @@
 	return result;
 }
 
+Int MLton_Process_terminate(Pid pid, Int sig) {
+	HANDLE h;
+	
+	h = (HANDLE)pid;
+	/* We terminate with 'sig' for the _return_ code + 0x80
+	 * Then in the basis library I test for this to decide W_SIGNALED.
+	 * Perhaps not the best choice, but I have no better idea.
+	 */
+        unless (TerminateProcess (h, sig | 0x80)) {
+		errno = ECHILD;
+		return -1;
+	}
+	return 0;
+}
Index: runtime/platform/cygwin.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/cygwin.c,v
retrieving revision 1.5
diff -u -r1.5 cygwin.c
--- runtime/platform/cygwin.c	25 Nov 2004 04:39:59 -0000	1.5
+++ runtime/platform/cygwin.c	27 Nov 2004 22:52:11 -0000
@@ -1,5 +1,6 @@
 #include "platform.h"
 
+#include "create.c"
 #include "getrusage.c"
 #include "mkdir2.c"
 #include "mmap.c"
@@ -36,4 +37,12 @@
 void Posix_IO_settext (Fd fd) {
 	/* cygwin has a different method for working with its fds */
 	setmode (fd, O_TEXT);
+}
+
+Pid MLton_Process_cwait(Pid 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, (int)h, 0);
 }
Index: runtime/platform/cygwin.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/cygwin.h,v
retrieving revision 1.7
diff -u -r1.7 cygwin.h
--- runtime/platform/cygwin.h	25 Nov 2004 04:39:59 -0000	1.7
+++ runtime/platform/cygwin.h	27 Nov 2004 22:52:11 -0000
@@ -31,6 +31,7 @@
 #define HAS_TIME_PROFILING FALSE
 #define HAS_WEAK 0
 #define USE_VIRTUAL_ALLOC TRUE
+#define GET_OSFHANDLE get_osfhandle
 
 #define _SC_BOGUS 0xFFFFFFFF
 #define _SC_2_FORT_DEV _SC_BOGUS
Index: runtime/platform/mingw.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/mingw.c,v
retrieving revision 1.8
diff -u -r1.8 mingw.c
--- runtime/platform/mingw.c	25 Nov 2004 04:39:59 -0000	1.8
+++ runtime/platform/mingw.c	27 Nov 2004 22:52:12 -0000
@@ -427,18 +427,7 @@
 }
 
 int kill (pid_t pid, int sig) {
-	HANDLE h;
-	
-	h = (HANDLE)pid;
-	/* We terminate with 'sig' for the _return_ code + 0x80
-	 * Then in the basis library I test for this to decide W_SIGNALED.
-	 * Perhaps not the best choice, but I have no better idea.
-	 */
-        unless (TerminateProcess (h, sig | 0x80)) {
-		errno = ECHILD;
-		return -1;
-	}
-	return 0;
+	return MLton_Process_terminate(pid, sig);
 }
 
 int pause (void) {
@@ -454,12 +443,16 @@
 	die ("wait not implemented");
 }
 
-pid_t waitpid (pid_t pid, int *status, int options) {
+pid_t MLton_Process_cwait(pid_t pid, int* status) {
 	HANDLE h;
-
+	
 	h = (HANDLE)pid;
 	/* -1 on error, the casts here are due to bad types on both sides */
-	return _cwait (status, (_pid_t)h, 0);
+	return _cwait(status, (_pid_t)h, 0);
+}
+
+pid_t waitpid (pid_t pid, int *status, int options) {
+	return MLton_Process_cwait(pid, status);
 }
 
 /* ------------------------------------------------- */
Index: runtime/platform/mingw.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/mingw.h,v
retrieving revision 1.9
diff -u -r1.9 mingw.h
--- runtime/platform/mingw.h	25 Nov 2004 01:35:49 -0000	1.9
+++ runtime/platform/mingw.h	27 Nov 2004 22:52:12 -0000
@@ -20,6 +20,7 @@
 #define HAS_TIME_PROFILING FALSE
 #define HAS_WEAK FALSE
 #define USE_VIRTUAL_ALLOC TRUE
+#define GET_OSFHANDLE _get_osfhandle
 
 #define MLton_Platform_OS_host "mingw"
 

--nFreZHaLTZJo0R7j--