[MLton-devel] cvs commit: calling SML from C

Stephen Weeks MLton@mlton.org
Mon, 24 Mar 2003 20:31:25 -0800


sweeks      03/03/24 20:31:25

  Modified:    basis-library/libs build
               basis-library/misc primitive.sml
               basis-library/mlton mlton.sig mlton.sml thread.sig
                        thread.sml
               include  ccodegen.h
               lib/mlton-stubs mlton.sig mlton.sml sources.cm thread.sig
               mlton/atoms prim.fun prim.sig
               mlton/backend c-function.fun c-function.sig limit-check.fun
                        ssa-to-rssa.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-generate-transfers.fun
                        x86-jump-info.fun x86-mlton.fun x86.fun
               runtime  gc.c gc.h
               runtime/basis Thread.c
  Added:       basis-library/mlton ffi.sig ffi.sml
               lib/mlton-stubs ffi.sig
  Log:
  This checkin includes a simple mechanism for calling SML from C.
  Warning: it only works with -native false for now.  The interface is
  as follows.  On the SML side, we export a single function that allows
  one to set the "handler" that runs when a call to SML is made from C:
  
  	val MLton.FFI.handleCallFromC: (unit -> unit) -> unit
  
  On the C side, we export a single function that allows us to call back
  to SML:
  
  	void MLton_callFromC ();
  
  This interface and implementation is only intended to handle the
  situation where SML is the main program and calls C functions that may
  need to call back to SML, which is the case for mGTK.  It is easy
  enough to use this primitive interface to implement the ability to
  call multiple SML functions with wrappers around MLton_callFromC that
  set a global integer and dispatch inside handleCallFromC that tests
  the integer.  It is also easy enough to pass arguments to the SML
  functions, again by setting globals in the C wrapper and fetching them
  (with _ffi) on the SML side.  So, it is my hope that this interface
  will be sufficient for the mGTK guys.
  
  This interface is not intended to allow creation of SML libraries as
  .o files.  But it's hopefully a step in that direction.
  
  The implementation is based on Matthew's suggestion of using threads
  to handle callbacks and is very similar to how MLton handles signals.
  There is a new field, gcState.callFromCHandler, that points to the
  thread that is to be run when C calls MLton_callFromC ().  There is
  also one new primitive, Thread_returnToC, that the callFromCHandler
  calls when it is done.  Calling MLton_callFromC () switches to the
  callFromCHandlerThread, and then runs the SML until it calls
  Thread_returnToC.  It then switches back to the thread that was
  "interrupted" by the C call, and returns to C.
  
  One major impact of allowing C to call back to SML is that it changes
  the assumptions that the optimizer can make about C calls.  Namely, it
  used to be a safe assumption that anything declared by _ffi didn't
  modify the frontier or the stackTop and didn't GC.  Now, that is no
  longer true, since any _ffi might call back to C, which could do any
  of those things.  There are two ways to solve this problem.
  
  1. If the program handles C calls, then assume that all _ffi's may
     modify the frontier or the stackTop and may GC.
  
  2. Introduce an annotation on _ffi declarations that allows the
     programmer to indicate the functions that may callback.
  
  3. Introduce an annotation on _ffi declarations that allows the
     programmer to indicate the functions that don't callback.
  
  For now I've chosen (1), but only because it was easier to implement.
  In looking at this, I see that we go to a lot of trouble in the
  backend and codegen to keep track of all of these properties of C
  functions (modifiesFrontier, mayGC, ...) in the backend so that the
  codegens can optimize C calls.  It might make our lives a lot easier,
  and the compiler more obviously correct, to simply make worst case
  assumptions for some of these.  I don't know much that will hurt
  performance.  It's probably worth running some experiments to check.
  
  Warning: this checkin only supports calling SML from C with the C
  codegen.  To get it to work with the native codegen, two things must
  be done:
  
  1. Add an implementation of MLton_callFromC to x86codegen.h.  It
     shouldn't be too hard to pattern match off of MLton_callFromC in
     ccodegen.h and main in x86codegen.h.
  
  2. Implement C calls to Thread_returnToC in the x86 codegen.  Again,
     the semantics are in the C codegen.
  
  Matthew, can you look into those two things?

Revision  Changes    Path
1.10      +2 -0      mlton/basis-library/libs/build

Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- build	8 Feb 2003 23:29:37 -0000	1.9
+++ build	25 Mar 2003 04:31:22 -0000	1.10
@@ -195,6 +195,8 @@
 mlton/bin-io.sig
 mlton/itimer.sig
 mlton/itimer.sml
+mlton/ffi.sig
+mlton/ffi.sml
 mlton/gc.sig
 mlton/gc.sml
 mlton/int-inf.sig



1.46      +4 -0      mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- primitive.sml	3 Jan 2003 06:14:13 -0000	1.45
+++ primitive.sml	25 Mar 2003 04:31:22 -0000	1.46
@@ -754,9 +754,13 @@
 	    val copyCurrent = _prim "Thread_copyCurrent": unit -> unit;
 	    val current = _ffi "Thread_current": unit -> thread;
 	    val finishHandler = _ffi "Thread_finishHandler": unit -> unit;
+	    val returnToC = _prim "Thread_returnToC": unit -> unit;
 	    val saved = _ffi "Thread_saved": unit -> thread;
 	    val savedPre = _ffi "Thread_saved": unit -> preThread;
+	    val setCallFromCHandler =
+	       _ffi "Thread_setCallFromCHandler": thread -> unit;
 	    val setHandler = _ffi "Thread_setHandler": thread -> unit;
+	    val setSaved = _ffi "Thread_setSaved": thread -> unit;
 	    val startHandler = _ffi "Thread_startHandler": unit -> unit;
 	    val switchTo = _prim "Thread_switchTo": thread -> unit;
 	 end      



1.18      +1 -0      mlton/basis-library/mlton/mlton.sig

Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton.sig	3 Jan 2003 06:14:13 -0000	1.17
+++ mlton.sig	25 Mar 2003 04:31:22 -0000	1.18
@@ -28,6 +28,7 @@
       structure BinIO: MLTON_BIN_IO
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
+      structure FFI: MLTON_FFI
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF
       structure Itimer: MLTON_ITIMER



1.18      +1 -0      mlton/basis-library/mlton/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton.sml	3 Jan 2003 06:14:13 -0000	1.17
+++ mlton.sml	25 Mar 2003 04:31:23 -0000	1.18
@@ -52,6 +52,7 @@
    end
 structure Cont = MLtonCont
 structure Exn = MLtonExn
+structure FFI = MLtonFFI
 structure GC = MLtonGC
 structure IntInf = IntInf
 structure Itimer = MLtonItimer



1.5       +1 -0      mlton/basis-library/mlton/thread.sig

Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- thread.sig	22 Jul 2002 03:37:31 -0000	1.4
+++ thread.sig	25 Mar 2003 04:31:23 -0000	1.5
@@ -32,6 +32,7 @@
       include MLTON_THREAD
 
       val amInSignalHandler: unit -> bool
+      val setCallFromCHandler: (unit -> unit) -> unit
       val setHandler: (unit t -> unit t) -> unit
       val switchToHandler: unit -> unit
    end



1.15      +26 -1     mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- thread.sml	29 Dec 2002 01:22:58 -0000	1.14
+++ thread.sml	25 Mar 2003 04:31:23 -0000	1.15
@@ -139,10 +139,35 @@
 	    loop ()
 	 end
       val p =
-	 toPrimitive (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
+	 toPrimitive
+	 (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
       val _ = signalHandler := SOME p
    in
       Prim.setHandler p
+   end
+
+val setCallFromCHandler =
+   let
+      val r: (unit -> unit) ref =
+	 ref (fn () => raise Fail "no handler for C calls")
+      val _ =
+	 Prim.setCallFromCHandler
+	 (toPrimitive
+	  (new (let
+		   fun loop (): unit =
+		      let
+			 val t = Prim.saved ()
+		      in
+			 !r () handle e => MLtonExn.topLevelHandler e
+			 ; Prim.setSaved t
+			 ; Prim.returnToC ()
+			 ; loop ()
+		      end
+		in
+		   loop
+		end)))
+   in
+      fn f => r := f
    end
 
 fun switchToHandler () =



1.1                  mlton/basis-library/mlton/ffi.sig

Index: ffi.sig
===================================================================
signature MLTON_FFI =
   sig
      val handleCallFromC: (unit -> unit) -> unit
   end



1.1                  mlton/basis-library/mlton/ffi.sml

Index: ffi.sml
===================================================================
structure MLtonFFI =
struct

val handleCallFromC = MLtonThread.setCallFromCHandler
   
end



1.51      +34 -1     mlton/include/ccodegen.h

Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- ccodegen.h	28 Jan 2003 06:56:14 -0000	1.50
+++ ccodegen.h	25 Mar 2003 04:31:23 -0000	1.51
@@ -81,7 +81,7 @@
 			leaveChunk:					\
 				FlushFrontier();			\
 				FlushStackTop();			\
-				return(cont);				\
+				return cont;				\
 		} /* end switch (l_nextFun) */				\
 		} /* end while (1) */					\
 	} /* end chunk */
@@ -90,7 +90,40 @@
 /*                       main                        */
 /* ------------------------------------------------- */
 
+static bool returnToC;
+
+#define Thread_returnToC()						\
+	do {								\
+		if (DEBUG_CCODEGEN)					\
+			fprintf (stderr, "%d  Thread_returnToC()\n",	\
+					__LINE__);			\
+		returnToC = TRUE;					\
+		return cont;						\
+	} while (0)
+
+
 #define Main(cs, mg, mfs, mlw, mmc, ps, mc, ml)				\
+void MLton_callFromC () {						\
+	struct cont cont;						\
+	GC_state s;							\
+									\
+	if (DEBUG_CCODEGEN)						\
+		fprintf (stderr, "MLton_callFromC() starting\n");	\
+	s = &gcState;							\
+	s->savedThread = s->currentThread;				\
+	/* Return to the C Handler thread. */				\
+	GC_switchToThread (s, s->callFromCHandler);			\
+	nextFun = *(int*)(s->stackTop - WORD_SIZE);			\
+	cont.nextChunk = nextChunks[nextFun];				\
+	returnToC = FALSE;						\
+	do {								\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+	} while (not returnToC);					\
+	GC_switchToThread (s, s->savedThread);				\
+	s->savedThread = BOGUS_THREAD;					\
+	if (DEBUG_CCODEGEN)						\
+		fprintf (stderr, "MLton_callFromC done\n");		\
+}									\
 int main (int argc, char **argv) {					\
 	struct cont cont;						\
 	gcState.native = FALSE;						\



1.8       +1 -0      mlton/lib/mlton-stubs/mlton.sig

Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton.sig	31 Oct 2002 19:30:13 -0000	1.7
+++ mlton.sig	25 Mar 2003 04:31:23 -0000	1.8
@@ -28,6 +28,7 @@
       structure BinIO: MLTON_BIN_IO
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
+      structure FFI: MLTON_FFI
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF
       structure Itimer: MLTON_ITIMER



1.13      +5 -0      mlton/lib/mlton-stubs/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton.sml	11 Feb 2003 22:13:28 -0000	1.12
+++ mlton.sml	25 Mar 2003 04:31:23 -0000	1.13
@@ -92,6 +92,11 @@
 	    val topLevelHandler = fn _ => raise Fail "Exn.topLevelHandler"
 	 end
 
+      structure FFI =
+	 struct
+	    val handleCallFromC = fn _ => raise Fail "FFI.handleCallFromC"
+	 end
+      
       structure GC =
 	 struct
 	    fun collect _ = ()



1.6       +1 -0      mlton/lib/mlton-stubs/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm	30 Jan 2003 04:43:15 -0000	1.5
+++ sources.cm	25 Mar 2003 04:31:23 -0000	1.6
@@ -65,6 +65,7 @@
 bin-io.sml
 cont.sig
 exn.sig
+ffi.sig
 gc.sig
 int-inf.sig
 int-inf.sml



1.4       +1 -0      mlton/lib/mlton-stubs/thread.sig

Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/thread.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- thread.sig	6 Aug 2002 03:19:19 -0000	1.3
+++ thread.sig	25 Mar 2003 04:31:23 -0000	1.4
@@ -32,6 +32,7 @@
       include MLTON_THREAD
 
       val amInSignalHandler: unit -> bool
+      val setCallFromCHandler: (unit -> unit) -> unit
       val setHandler: (unit t -> unit t) -> unit
       val switchToHandler: unit -> unit
    end



1.1                  mlton/lib/mlton-stubs/ffi.sig

Index: ffi.sig
===================================================================
signature MLTON_FFI =
   sig
      val handleCallFromC: (unit -> unit) -> unit
   end



1.45      +2 -0      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- prim.fun	28 Jan 2003 05:22:27 -0000	1.44
+++ prim.fun	25 Mar 2003 04:31:23 -0000	1.45
@@ -152,6 +152,7 @@
        | Thread_canHandle
        | Thread_copy
        | Thread_copyCurrent
+       | Thread_returnToC
        | Thread_switchTo
        | Vector_fromArray
        | Vector_length
@@ -372,6 +373,7 @@
 	  (Thread_canHandle, DependsOnState, "Thread_canHandle"),
 	  (Thread_copy, Moveable, "Thread_copy"),
 	  (Thread_copyCurrent, SideEffect, "Thread_copyCurrent"),
+	  (Thread_returnToC, SideEffect, "Thread_returnToC"),
 	  (Thread_switchTo, SideEffect, "Thread_switchTo"),
 	  (Vector_fromArray, DependsOnState, "Vector_fromArray"),
 	  (Vector_length, Functional, "Vector_length"),



1.35      +1 -0      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- prim.sig	7 Dec 2002 02:21:51 -0000	1.34
+++ prim.sig	25 Mar 2003 04:31:23 -0000	1.35
@@ -157,6 +157,7 @@
 	     | Thread_canHandle (* implemented in backend *)
 	     | Thread_copy
 	     | Thread_copyCurrent
+	     | Thread_returnToC
 	     (* switchTo has to be a _prim because we have to know that it
 	      * enters the runtime -- because everything must be saved
 	      * on the stack.



1.11      +14 -0     mlton/mlton/backend/c-function.fun

Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- c-function.fun	23 Jan 2003 03:34:36 -0000	1.10
+++ c-function.fun	25 Mar 2003 04:31:24 -0000	1.11
@@ -17,6 +17,10 @@
 		   modifiesStackTop: bool,
 		   name: string,
 		   returnTy: Type.t option}
+
+val make = T
+
+fun dest (T r) = r
    
 fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
 	       modifiesFrontier, modifiesStackTop, name, returnTy}) =
@@ -109,4 +113,14 @@
 val size = vanilla {name = "MLton_size",
 		    returnTy = SOME Type.int}
 
+val returnToC =
+   T {bytesNeeded = NONE,
+      ensuresBytesFree = false,
+      modifiesFrontier = true,
+      modifiesStackTop = true,
+      mayGC = true,
+      maySwitchThreads = true,
+      name = "Thread_returnToC",
+      returnTy = NONE}
+   
 end



1.8       +31 -16    mlton/mlton/backend/c-function.sig

Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- c-function.sig	23 Jan 2003 03:34:36 -0000	1.7
+++ c-function.sig	25 Mar 2003 04:31:24 -0000	1.8
@@ -17,29 +17,38 @@
    sig
       include C_FUNCTION_STRUCTS
 
-      datatype t = T of {(* bytesNeeded = SOME i means that the i'th
-			  * argument to the function is a word that
-			  * specifies the number of bytes that must be
-			  * free in order for the C function to succeed.
-			  * Limit check insertion is responsible for
-			  * making sure that the bytesNeeded is available.
-			  *)
-			 bytesNeeded: int option,
-			 ensuresBytesFree: bool,
-			 modifiesFrontier: bool,
-			 modifiesStackTop: bool,
-			 mayGC: bool,
-			 maySwitchThreads: bool,
-			 name: string,
-			 returnTy: Type.t option}
-
+      type t
+	 
       val bug: t
       val bytesNeeded: t -> int option
+      val dest: t -> {bytesNeeded: int option,
+		      ensuresBytesFree: bool,
+		      modifiesFrontier: bool,
+		      modifiesStackTop: bool,
+		      mayGC: bool,
+		      maySwitchThreads: bool,
+		      name: string,
+		      returnTy: Type.t option}
       val ensuresBytesFree: t -> bool
       val equals: t * t -> bool
       val gc: {maySwitchThreads: bool} -> t
       val isOk: t -> bool
       val layout: t -> Layout.t
+      val make: {(* bytesNeeded = SOME i means that the i'th
+		  * argument to the function is a word that
+		  * specifies the number of bytes that must be
+		  * free in order for the C function to succeed.
+		  * Limit check insertion is responsible for
+		  * making sure that the bytesNeeded is available.
+		  *)
+		 bytesNeeded: int option,
+		 ensuresBytesFree: bool,
+		 modifiesFrontier: bool,
+		 modifiesStackTop: bool,
+		 mayGC: bool,
+		 maySwitchThreads: bool,
+		 name: string,
+		 returnTy: Type.t option} -> t
       val mayGC: t -> bool
       val maySwitchThreads: t -> bool
       val modifiesFrontier: t -> bool
@@ -48,6 +57,12 @@
       val profileEnter: t
       val profileInc: t
       val profileLeave: t
+      (* returnToC is not really a C function.  Calls to it must be handled
+       * specially by each codegen to ensure that the C stack is handled
+       * correctly.  However, for the purposes of the backend it looks like a
+       * call to C.
+       *)
+      val returnToC: t
       val returnTy: t -> Type.t option
       val size: t
       val vanilla: {name: string, returnTy: Type.t option} -> t



1.37      +28 -25    mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- limit-check.fun	12 Feb 2003 05:11:24 -0000	1.36
+++ limit-check.fun	25 Mar 2003 04:31:24 -0000	1.37
@@ -85,10 +85,13 @@
       fun caseBytes (t: t, {big: Operand.t -> 'a,
 			    small: word -> 'a}): 'a =
 	 case t of
-	    CCall {args, func = CFunction.T {bytesNeeded = SOME i, ...}, ...} =>
-	       Operand.caseBytes (Vector.sub (args, i),
-				  {big = big,
-				   small = small})
+	    CCall {args, func, ...} =>
+	       (case CFunction.bytesNeeded func of
+		   NONE => small 0w0
+		 | SOME i =>
+		      Operand.caseBytes (Vector.sub (args, i),
+					 {big = big,
+					  small = small}))
 	  | _ => small 0w0
    end
 
@@ -126,14 +129,14 @@
 		     val l = Label.newNoname ()
 		     val _ = r := SOME l
 		     val cfunc =
-			CFunction.T {bytesNeeded = NONE,
-				     ensuresBytesFree = false,
-				     mayGC = false,
-				     maySwitchThreads = false,
-				     modifiesFrontier = false,
-				     modifiesStackTop = false,
-				     name = "MLton_allocTooLarge",
-				     returnTy = NONE}
+			CFunction.make {bytesNeeded = NONE,
+					ensuresBytesFree = false,
+					mayGC = false,
+					maySwitchThreads = false,
+					modifiesFrontier = false,
+					modifiesStackTop = false,
+					name = "MLton_allocTooLarge",
+					returnTy = NONE}
 		     val _ =
 			newBlocks :=
 			Block.T {args = Vector.new0 (),
@@ -155,10 +158,8 @@
 	  let
 	     val transfer = 
 		case transfer of
-		   Transfer.CCall {args,
-				   func as CFunction.T {ensuresBytesFree, ...},
-				   return} =>
-		      (if ensuresBytesFree
+		   Transfer.CCall {args, func, return} =>
+		      (if CFunction.ensuresBytesFree func
 			  then 
 			     Transfer.CCall
 			     {args = (Vector.map
@@ -487,18 +488,20 @@
 	     val b =
 		case kind of
 		   Cont _ => true
-		 | CReturn {func = CFunction.T {ensuresBytesFree, mayGC, ...}} =>
-		      mayGC andalso not ensuresBytesFree
+		 | CReturn {func, ...} =>
+		      CFunction.mayGC func
+		      andalso not (CFunction.ensuresBytesFree func)
 		 | Handler => true
 		 | Jump =>
 		      (case transfer of
-			  Transfer.CCall
-			  {args,
-			   func = CFunction.T {bytesNeeded = SOME i, ...},
-			   ...} => (case Vector.sub (args, i) of
-				       Operand.Const c => false
-				     | _ => true)
-			 | _ => false)
+			  Transfer.CCall {args, func, ...} =>
+			     (case CFunction.bytesNeeded func of
+				 NONE => true
+			       | SOME i => 
+				    (case Vector.sub (args, i) of
+					Operand.Const c => false
+				      | _ => true))
+			| _ => false)
 	  in
 	     b orelse isBigAlloc ()
 	  end)



1.37      +65 -51    mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- ssa-to-rssa.fun	2 Feb 2003 03:17:08 -0000	1.36
+++ ssa-to-rssa.fun	25 Mar 2003 04:31:24 -0000	1.37
@@ -42,14 +42,14 @@
 
       local
 	 fun make (name, i) =
-	    T {bytesNeeded = SOME i,
-	       ensuresBytesFree = false,
-	       mayGC = false,
-	       maySwitchThreads = false,
-	       modifiesFrontier = true,
-	       modifiesStackTop = false,
-	       name = name,
-	       returnTy = SOME Type.pointer}
+	    CFunction.make {bytesNeeded = SOME i,
+			    ensuresBytesFree = false,
+			    mayGC = false,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = false,
+			    name = name,
+			    returnTy = SOME Type.pointer}
       in
 	 val intInfAdd = make ("IntInf_do_add", 2)
 	 val intInfAndb = make ("IntInf_do_andb", 2)
@@ -76,27 +76,27 @@
       end
  
       val copyCurrentThread =
-	 T {bytesNeeded = NONE,
-	    ensuresBytesFree = false,
-	    mayGC = true,
-	    maySwitchThreads = false,
-	    modifiesFrontier = true,
-	    modifiesStackTop = true,
-	    name = "GC_copyCurrentThread",
-	    returnTy = NONE}
+	 make {bytesNeeded = NONE,
+	       ensuresBytesFree = false,
+	       mayGC = true,
+	       maySwitchThreads = false,
+	       modifiesFrontier = true,
+	       modifiesStackTop = true,
+	       name = "GC_copyCurrentThread",
+	       returnTy = NONE}
 
       val copyThread =
-	 T {bytesNeeded = NONE,
-	    ensuresBytesFree = false,
-	    mayGC = true,
-	    maySwitchThreads = false,
-	    modifiesFrontier = true,
-	    modifiesStackTop = true,
-	    name = "GC_copyThread",
-	    returnTy = SOME Type.pointer}
+	 make {bytesNeeded = NONE,
+	       ensuresBytesFree = false,
+	       mayGC = true,
+	       maySwitchThreads = false,
+	       modifiesFrontier = true,
+	       modifiesStackTop = true,
+	       name = "GC_copyThread",
+	       returnTy = SOME Type.pointer}
 
       val exit =
-	 T {bytesNeeded = NONE,
+	 make {bytesNeeded = NONE,
 	    ensuresBytesFree = false,
 	    mayGC = false,
 	    maySwitchThreads = false,
@@ -106,32 +106,32 @@
 	    returnTy = NONE}
 
       val gcArrayAllocate =
-	 T {bytesNeeded = NONE,
-	    ensuresBytesFree = true,
-	    mayGC = true,
-	    maySwitchThreads = false,
-	    modifiesFrontier = true,
-	    modifiesStackTop = true,
-	    name = "GC_arrayAllocate",
-	    returnTy = SOME Type.pointer}
-
-      local
-	 fun make name =
-	    T {bytesNeeded = NONE,
-	       ensuresBytesFree = false,
+	 make {bytesNeeded = NONE,
+	       ensuresBytesFree = true,
 	       mayGC = true,
 	       maySwitchThreads = false,
 	       modifiesFrontier = true,
 	       modifiesStackTop = true,
-	       name = name,
-	       returnTy = NONE}
+	       name = "GC_arrayAllocate",
+	       returnTy = SOME Type.pointer}
+
+      local
+	 fun make name =
+	    CFunction.make {bytesNeeded = NONE,
+			    ensuresBytesFree = false,
+			    mayGC = true,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = true,
+			    name = name,
+			    returnTy = NONE}
       in
 	 val pack = make "GC_pack"
 	 val unpack = make "GC_unpack"
       end
 
       val threadSwitchTo =
-	 T {bytesNeeded = NONE,
+	 make {bytesNeeded = NONE,
 	    ensuresBytesFree = true,
 	    mayGC = true,
 	    maySwitchThreads = true,
@@ -141,14 +141,14 @@
 	    returnTy = NONE}
 
       val worldSave =
-	 T {bytesNeeded = NONE,
-	    ensuresBytesFree = false,
-	    mayGC = true,
-	    maySwitchThreads = false,
-	    modifiesFrontier = true,
-	    modifiesStackTop = true,
-	    name = "GC_saveWorld",
-	    returnTy = NONE}
+	 make {bytesNeeded = NONE,
+	       ensuresBytesFree = false,
+	       mayGC = true,
+	       maySwitchThreads = false,
+	       modifiesFrontier = true,
+	       modifiesStackTop = true,
+	       name = "GC_saveWorld",
+	       returnTy = NONE}
    end
 
 datatype z = datatype Operand.t
@@ -168,6 +168,11 @@
 fun convert (program as S.Program.T {functions, globals, main, ...})
    : Rssa.Program.t =
    let
+      val callsFromC =
+	 S.Program.hasPrim (program, fn p =>
+			    case Prim.name p of
+			       Prim.Name.Thread_returnToC => true
+			     | _ => false)
       val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
 	 Representation.compute program
       val conRep =
@@ -988,8 +993,14 @@
 				       then normal ()
 				    else
 				       simpleCCall
-				       (CFunction.vanilla
-					{name = name,
+				       (CFunction.make
+					{bytesNeeded = NONE,
+					 ensuresBytesFree = false,
+					 modifiesFrontier = callsFromC,
+					 modifiesStackTop = callsFromC,
+					 mayGC = callsFromC,
+					 maySwitchThreads = false,
+					 name = name,
 					 returnTy =
 					 Option.map
 					 (var, fn x =>
@@ -1170,6 +1181,9 @@
 						   [Vector.new1 Operand.GCState,
 						    vos args]),
 					   func = CFunction.copyThread}
+			       | Thread_returnToC =>
+				    ccall {args = vos args,
+					   func = CFunction.returnToC}
 			       | Thread_switchTo =>
 				    ccall {args = (Vector.new2
 						   (varOp (a 0),



1.47      +10 -13    mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- c-codegen.fun	25 Feb 2003 20:44:23 -0000	1.46
+++ c-codegen.fun	25 Mar 2003 04:31:24 -0000	1.47
@@ -49,7 +49,7 @@
       fun isEntry (k: t): bool =
 	 case k of
 	    Cont _ => true
-	  | CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
+	  | CReturn {func, ...} => CFunction.mayGC func
 	  | Func => true
 	  | Handler _ => true
 	  | _ => false
@@ -518,9 +518,8 @@
 		    case transfer of
 		       Arith {overflow, success, ...} =>
 			  (jump overflow; jump success)
-		     | CCall {func = CFunction.T {maySwitchThreads, ...},
-			      return, ...} =>
-			  if maySwitchThreads
+		     | CCall {func, return, ...} =>
+			  if CFunction.maySwitchThreads func
 			     then ()
 			  else Option.app (return, jump)
 		     | Call {label, ...} => jump label
@@ -716,16 +715,14 @@
 			   ; gotoLabel success 
 			   ; maybePrintLabel overflow
 			end
-		   | CCall {args,
-			    frameInfo,
-			    func = CFunction.T {maySwitchThreads,
-						modifiesFrontier,
-						modifiesStackTop,
-						name,
-						returnTy,
-						...},
-			    return} =>
+		   | CCall {args, frameInfo, func, return} =>
 			let
+			   val {maySwitchThreads,
+				modifiesFrontier,
+				modifiesStackTop,
+				name,
+				returnTy,
+				...} = CFunction.dest func
 			   val (args, afterCall) =
 			      case frameInfo of
 				 NONE =>



1.39      +7 -13     mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun

Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86-generate-transfers.fun	23 Jan 2003 03:34:37 -0000	1.38
+++ x86-generate-transfers.fun	25 Mar 2003 04:31:24 -0000	1.39
@@ -506,11 +506,7 @@
 		       = case entry
 			   of Jump {label}
 			    => near label
-			    | CReturn {dst, 
-				       frameInfo,
-				       func = CFunction.T {maySwitchThreads,
-							   ...},
-				       label}
+			    | CReturn {dst, frameInfo, func, label}
 			    => let
 				 fun getReturn ()
 				   = case dst 
@@ -569,7 +565,7 @@
 					    Assembly.label label],
 					   AppendList.fromList
 					   (ProfileLabel.toAssemblyOpt profileLabel),
-					   if maySwitchThreads
+					   if CFunction.maySwitchThreads func
 					     then (* entry from far assumptions *)
 					          farEntry finish
 					     else (* near entry & live transfer assumptions *)
@@ -1077,14 +1073,12 @@
 			 {target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
 			  absolute = true})))
 		    end
-	        | CCall {args, dstsize,
-			 frameInfo,
-			 func = CFunction.T {maySwitchThreads,
-					     modifiesFrontier,
-					     modifiesStackTop,
-					     name, ...},
-			 return, target}
+	        | CCall {args, dstsize, frameInfo, func, return, target}
 		=> let
+		     val {maySwitchThreads,
+			  modifiesFrontier,
+			  modifiesStackTop,
+			  name, ...} = CFunction.dest func
 		     val stackTopMinusWordDeref
 		       = x86MLton.gcState_stackTopMinusWordDerefOperand ()
 		     val {dead, ...}



1.11      +2 -5      mlton/mlton/codegen/x86-codegen/x86-jump-info.fun

Index: x86-jump-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-jump-info.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-jump-info.fun	11 Jul 2002 02:16:49 -0000	1.10
+++ x86-jump-info.fun	25 Mar 2003 04:31:25 -0000	1.11
@@ -65,11 +65,8 @@
 	       | Entry.Func {label, ...} => forceNear (jumpInfo, label)
 	       | Entry.Cont {label, ...} => forceNear (jumpInfo, label)
 	       | Entry.Handler {label, ...} => forceNear (jumpInfo, label)
-	       | Entry.CReturn {label, 
-				func = Runtime.CFunction.T {maySwitchThreads, 
-							    ...}, 
-				...} 
-	       => if maySwitchThreads
+	       | Entry.CReturn {label, func, ...}
+	       => if Runtime.CFunction.maySwitchThreads func
 		    then forceNear (jumpInfo, label)
 		    else ();
 	    List.foreach



1.42      +2 -1      mlton/mlton/codegen/x86-codegen/x86-mlton.fun

Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- x86-mlton.fun	20 Jan 2003 16:28:33 -0000	1.41
+++ x86-mlton.fun	25 Mar 2003 04:31:25 -0000	1.42
@@ -1314,10 +1314,11 @@
 
   fun ccall {args: (x86.Operand.t * x86.Size.t) vector,
 	     frameInfo,
-	     func as CFunction.T {name, returnTy, ...},
+	     func,
 	     return: x86.Label.t option,
 	     transInfo: transInfo}
     = let
+	val {name, returnTy, ...} = CFunction.dest func
 	val dstsize = Option.map (returnTy, toX86Size)
 	val comment_begin
 	  = if !Control.Native.commented > 0



1.36      +3 -3      mlton/mlton/codegen/x86-codegen/x86.fun

Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86.fun	20 Jan 2003 16:28:38 -0000	1.35
+++ x86.fun	25 Mar 2003 04:31:25 -0000	1.36
@@ -3707,8 +3707,8 @@
       val creturn = CReturn
 
       val isNear = fn Jump _ => true
-	            | CReturn {func = CFunction.T {maySwitchThreads, ... }, ...} 
-	            => not maySwitchThreads
+	            | CReturn {func, ...} 
+	            => not (CFunction.maySwitchThreads func)
 	            | _ => false
     end
 
@@ -4017,7 +4017,7 @@
 	   | NonTail {return,handler,...} => return::(case handler 
 							of NONE => nil
 							 | SOME handler => [handler])
-	   | CCall {return, func = CFunction.T {maySwitchThreads, ...}, ...} 
+	   | CCall {return, ...} 
 	   => (case return of
 		 NONE => []
 	       | SOME l => [l])



1.126     +4 -2      mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.125
retrieving revision 1.126
diff -u -r1.125 -r1.126
--- gc.c	11 Feb 2003 17:21:54 -0000	1.125
+++ gc.c	25 Mar 2003 04:31:25 -0000	1.126
@@ -60,7 +60,6 @@
 
 enum {
 	BOGUS_EXN_STACK = 0xFFFFFFFF,
-	BOGUS_POINTER = 0x1,
 	COPY_CHUNK_SIZE = 0x800000,
 	CURRENT_SOURCE_UNDEFINED = 0xFFFFFFFF,
 	DEBUG = FALSE,
@@ -86,7 +85,6 @@
 	UNMARK_MODE,
 } MarkMode;
 
-#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
 #define STACK_HEADER GC_objectHeader (STACK_TYPE_INDEX)
 #define STRING_HEADER GC_objectHeader (STRING_TYPE_INDEX)
 #define THREAD_HEADER GC_objectHeader (THREAD_TYPE_INDEX)
@@ -771,6 +769,7 @@
 	}
 	if (DEBUG_DETAILED)
 		fprintf (stderr, "foreachGlobal threads\n");
+	maybeCall (f, s, (pointer*)&s->callFromCHandler);
 	maybeCall (f, s, (pointer*)&s->currentThread);
 	maybeCall (f, s, (pointer*)&s->savedThread);
 	maybeCall (f, s, (pointer*)&s->signalHandler);
@@ -3635,6 +3634,7 @@
 		die ("Invalid world: wrong magic number.");
 	oldGen = (pointer) sfreadUint (file);
 	s->oldGenSize = sfreadUint (file);
+	s->callFromCHandler = (GC_thread) sfreadUint (file);
 	s->currentThread = (GC_thread) sfreadUint (file);
 	s->signalHandler = (GC_thread) sfreadUint (file);
        	heapCreate (s, &s->heap, heapDesiredSize (s, s->oldGenSize, 0),
@@ -3666,6 +3666,7 @@
 	s->bytesCopied = 0;
 	s->bytesCopiedMinor = 0;
 	s->bytesMarkCompacted = 0;
+	s->callFromCHandler = BOGUS_THREAD;
 	s->canHandle = 0;
 	s->cardSize = 0x1 << s->cardSizeLog2;
 	s->copyRatio = 4.0;
@@ -3993,6 +3994,7 @@
 	swriteUint (fd, s->magic);
 	swriteUint (fd, (uint)s->heap.start);
 	swriteUint (fd, (uint)s->oldGenSize);
+	swriteUint (fd, (uint)s->callFromCHandler);
 	swriteUint (fd, (uint)s->currentThread);
 	swriteUint (fd, (uint)s->signalHandler);
  	swrite (fd, s->heap.start, s->oldGenSize);



1.57      +4 -0      mlton/runtime/gc.h

Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- gc.h	23 Jan 2003 03:34:38 -0000	1.56
+++ gc.h	25 Mar 2003 04:31:25 -0000	1.57
@@ -63,6 +63,7 @@
 
 /* Sizes are (almost) always measured in bytes. */
 enum {
+	BOGUS_POINTER = 0x1,
 	WORD_SIZE = 		4,
 	COUNTER_MASK =		0x7FF00000,
 	COUNTER_SHIFT =		20,
@@ -84,6 +85,8 @@
 	WORD_VECTOR_TYPE_INDEX = 3,
 };
 
+#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
+
 #define TWOPOWER(n) (1 << (n))
 
 /* ------------------------------------------------- */
@@ -299,6 +302,7 @@
 	ullong bytesCopiedMinor;
 	int bytesLive; /* Number of bytes live at most recent major GC. */
 	ullong bytesMarkCompacted;
+	GC_thread callFromCHandler; /* For C calls. */
 	bool canMinor; /* TRUE iff there is space for a minor gc. */
 	pointer cardMap;
 	pointer cardMapForMutator;



1.8       +8 -0      mlton/runtime/basis/Thread.c

Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Thread.c	22 Jul 2002 03:37:31 -0000	1.7
+++ Thread.c	25 Mar 2003 04:31:25 -0000	1.8
@@ -20,6 +20,14 @@
 	return t;
 }
 
+void Thread_setCallFromCHandler (Thread t) {
+	gcState.callFromCHandler = (GC_thread)t;
+}
+
+Thread Thread_setSaved (Thread t) {
+	gcState.savedThread = (GC_thread)t;
+}
+
 void Thread_setHandler (Thread t) {
 	gcState.signalHandler = (GC_thread)t;
 }





-------------------------------------------------------
This SF.net email is sponsored by:
The Definitive IT and Networking Event. Be There!
NetWorld+Interop Las Vegas 2003 -- Register today!
http://ads.sourceforge.net/cgi-bin/redirect.pl?keyn0001en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel