[MLton-devel] cvs commit: _export bugfix and improvements

Stephen Weeks sweeks@users.sourceforge.net
Sat, 05 Jul 2003 16:30:27 -0700


sweeks      03/07/05 16:30:26

  Modified:    basis-library/misc primitive.sml
               basis-library/mlton ffi.sml thread.sig thread.sml
               doc/examples/ffi Makefile export.sml ffi-export.c
               include  c-main.h x86-main.h
               mlton/atoms type-ops.fun type-ops.sig
               mlton/codegen/c-codegen c-codegen.fun
               mlton/control control.sig control.sml
               mlton/elaborate elaborate-core.fun
               mlton/main compile.sml main.sml
               runtime/basis Thread.c
  Log:
  Fixed the bug Ken Larsen triggered with mgtk.  It was due to broken
  use of atomic{Begin,End} in MLtonThread.sml.  The reason the bug
  didn't get caught in testing is that there is an optimization in the
  basis library that turns atomic{Begin,End} into noops if signals
  aren't handled by the program (because there can be no preemptive
  thread switching).  The only testing I had done with _export had been
  with a single-threaded program and hence the critical sections hadn't
  been tested at all.  But mgtk uses MLton.Finalizable, which uses
  signals, which triggered the bug.
  
  First off, I decided to eliminate that optimization.  Partly because
  of this problem, and partly because there are various places in the
  runtime and basis where you want to do asserts on canHandle, but these
  won't be right if atomic{Begin,End} are turned into noops.
  
  I moved the implementation of MLton.FFI.register into MLton.Thread,
  since it was the only user of MLton.Thread.setCallFromCHandler.  That
  cleaned things up some.  Modulo that change, the bugfix was to insert
  an extra atomicBegin in the C code that switches to the handler, as
  well as an extra atomicBegin in the SML code to counteract an
  atomicEnd that happens the first time the handler is started.
  
  Added option
  
  	-export-header {false|true}   output header file for _export's
  
  Now, the header file for _exports is not created automatically.
  Instead, you must call mlton with -export-header true, which will
  output the header to stdout and exit.  This way, if you are creating a
  library with _exports, you can create the header once and for all, and
  users of your library don't have to know about it.
  
  Added an example of mutually recursive C and SML functions to
  doc/examples/ffi/export.sml.
  
  Added support to allow values of type MLton.pointer to be passed
  between C and SML.

Revision  Changes    Path
1.62      +4 -10     mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- primitive.sml	26 Jun 2003 03:28:19 -0000	1.61
+++ primitive.sml	5 Jul 2003 23:30:25 -0000	1.62
@@ -984,18 +984,12 @@
 	    type preThread = preThread
 	    type thread = thread
 
-	    fun atomicBegin () =
-	       if handlesSignals
-		  then _prim "Thread_atomicBegin": unit -> unit; ()
-	       else ()
+	    val atomicBegin = _prim "Thread_atomicBegin": unit -> unit;
 	    val canHandle = _prim "Thread_canHandle": unit -> int;
 	    fun atomicEnd () =
-	       if handlesSignals
-		  then
-		     if Int.<= (canHandle (), 0)
-			then raise Fail "Thread.atomicEnd with no atomicBegin"
-		     else _prim "Thread_atomicEnd": unit -> unit; ()
-	       else ()
+	       if Int.<= (canHandle (), 0)
+		  then raise Fail "Thread.atomicEnd with no atomicBegin"
+	       else _prim "Thread_atomicEnd": unit -> unit; ()
 	    val copy = _prim "Thread_copy": preThread -> thread;
 	    (* copyCurrent's result is accesible via savedPre ().
 	     * It is not possible to have the type of copyCurrent as



1.6       +1 -13     mlton/basis-library/mlton/ffi.sml

Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ffi.sml	5 Jul 2003 21:14:33 -0000	1.5
+++ ffi.sml	5 Jul 2003 23:30:25 -0000	1.6
@@ -7,18 +7,6 @@
 
 val atomicBegin = MLtonThread.atomicBegin
 val atomicEnd = MLtonThread.atomicEnd
-
-val msg = Primitive.Stdio.print
-   
-val register: int * (unit -> unit) -> unit =
-   let
-      val exports = Array.array (Prim.numExports, fn () =>
-				 raise Fail "undefined export\n")
-      val _ =
-	 MLtonThread.setCallFromCHandler
-	 (fn () => Array.sub (exports, Prim.getOp ()) ())
-   in
-      fn (i, f) => Array.update (exports, i, f)
-   end
+val register = MLtonThread.register
    
 end



1.8       +1 -6      mlton/basis-library/mlton/thread.sig

Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- thread.sig	19 Jun 2003 19:21:28 -0000	1.7
+++ thread.sig	5 Jul 2003 23:30:25 -0000	1.8
@@ -32,12 +32,7 @@
       include MLTON_THREAD
 
       val amInSignalHandler: unit -> bool
-      (* setCallFromCHandler f
-       * Installs f as the handler for calls from C into SML.
-       * f should start in a critical section and
-       * and should return in a critical section.
-       *)
-      val setCallFromCHandler: (unit -> unit) -> unit
+      val register: int * (unit -> unit) -> unit
       val setHandler: (unit t -> unit t) -> unit
       val switchToHandler: unit -> unit
    end



1.21      +37 -29    mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- thread.sml	19 Jun 2003 19:21:28 -0000	1.20
+++ thread.sml	5 Jul 2003 23:30:25 -0000	1.21
@@ -52,6 +52,8 @@
 		 ; atomicEnd ()
 		 ; (x () handle e => MLtonExn.topLevelHandler e)
 		 ; die "Thread didn't exit properly.\n")))
+   fun newThread (f: unit -> unit) =
+      (func := SOME f; Prim.copy base)
    val switching = ref false
 in
    fun ('a, 'b) switch'NoAtomicBegin (f: 'a t -> 'b t * (unit -> 'b)): 'a =
@@ -72,8 +74,7 @@
 	    val primThread =
 	       case !t' before (t' := Dead; switching := false) of
 		  Dead => fail (Fail "switch to a Dead thread")
-		| New g => (func := SOME (g o x)
-			    ; Prim.copy base)
+		| New g => newThread (g o x)
 		| Paused (f, t) => (f x; t)
 	    val _ = Prim.switchTo primThread
 	    (* Close the atomicBegin of the thread that switched to me. *)
@@ -145,36 +146,43 @@
       Prim.setHandler p
    end
 
-val msg = Primitive.Stdio.print
-   
-val setCallFromCHandler =
+val register: int * (unit -> unit) -> unit =
    let
-      val r: (unit -> unit) ref =
-	 ref (fn () => raise Fail "no handler for C calls")
+      val exports = Array.array (Primitive.FFI.numExports, fn () =>
+				 raise Fail "undefined export\n")
+      fun loop (): unit =
+	 let
+	    val t = Prim.saved ()
+	    val _ =
+	       Prim.switchTo
+	       (toPrimitive
+		(new
+		 (fn () =>
+		  let
+		     val _ = 
+			(Array.sub (exports, Primitive.FFI.getOp ()) ())
+			handle e => (TextIO.output
+				     (TextIO.stdErr,
+				      "Call from C to SML raised exception.\n")
+				     ; MLtonExn.topLevelHandler e)
+		     val _ = Prim.setSaved t
+		     val _ = Prim.returnToC ()
+		  in
+		     ()
+		  end)))
+	 in
+	    loop ()
+	 end
+      (* For some reason that I never figured out, the first time the handler
+       * is started, it does an extra atomicEnd (three instead of two).  So, I
+       * inserted an extra atomicBegin before entering the loop.
+       *)
       val _ =
-	 Prim.setCallFromCHandler
-	 (toPrimitive
-	  (new (let
-		   fun loop (): unit =
-		      let
-			 val t = Prim.saved ()
-			 val _ =
-			    Prim.switchTo
-			    (toPrimitive
-			     (new (fn () => 
-				   (let in
-				      (!r) ()
-				      ; Prim.setSaved t
-				      ; Prim.returnToC ()
-				   end))))
-		      in
-			 loop ()
-		      end
-		in
-		   loop
-		end)))
+	 Prim.setCallFromCHandler (toPrimitive (new (fn () =>
+						     (atomicBegin ()
+						      ; loop ()))))
    in
-      fn f => r := f
+      fn (i, f) => Array.update (exports, i, f)
    end
 
 fun switchToHandler () =



1.6       +3 -1      mlton/doc/examples/ffi/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Makefile	24 Jun 2003 20:14:21 -0000	1.5
+++ Makefile	5 Jul 2003 23:30:25 -0000	1.6
@@ -4,7 +4,9 @@
 all: import export
 
 export: export.sml ffi-export.c
-	$(mlton) export.sml ffi-export.c
+	$(mlton) -export-header true >export.h export.sml
+	gcc -c -I/usr/lib/mlton/self/include ffi-export.c
+	$(mlton) -debug true -native false export.sml ffi-export.o
 
 import: import.sml ffi-import.o
 	$(mlton) import.sml ffi-import.o



1.4       +7 -10     mlton/doc/examples/ffi/export.sml

Index: export.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/export.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- export.sml	26 Jun 2003 19:12:27 -0000	1.3
+++ export.sml	5 Jul 2003 23:30:25 -0000	1.4
@@ -1,31 +1,28 @@
 val e = _export "f": int * real -> char;
-
 val _ = e (fn (i, r) =>
 	   (print (concat ["i = ", Int.toString i,
 			   "  r = ", Real.toString r, "\n"])
 	    ; #"g"))
-
-
 val g = _ffi "g": unit -> unit;
 val _ = g ()
 val _ = g ()
    
 val e = _export "f2": Word8.word -> word array;
-
 val _ = e (fn w => Array.tabulate (10, fn _ => Word8.toLargeWord w))
-
 val g2 = _ffi "g2": unit -> word array;
-
 val a = g2 ()
-
 val _ = print (concat ["0wx", Word.toString (Array.sub (a, 0)), "\n"])
 
 val e = _export "f3": unit -> unit;
-
 val _ = e (fn () => print "hello\n");
-
 val g3 = _ffi "g3": unit -> unit;
-
 val _ = g3 ()
 
+(* This example demonstrates mutual recursion between C and SML. *)
+val e = _export "f4": int -> unit;
+val g4 = _ffi "g4": int -> unit;
+val _ = e (fn i => if i = 0 then () else g4 (i - 1))
+val _ = g4 13
+   
 val _ = print "success\n"
+



1.3       +5 -0      mlton/doc/examples/ffi/ffi-export.c

Index: ffi-export.c
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/ffi-export.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ffi-export.c	24 Jun 2003 22:58:39 -0000	1.2
+++ ffi-export.c	5 Jul 2003 23:30:25 -0000	1.3
@@ -22,3 +22,8 @@
 	f3 ();
 	fprintf (stderr, "g3 done\n");
 }
+
+void g4 (Int i) {
+	fprintf (stderr, "g4 (%d)\n", i);
+	f4 (i);
+}



1.6       +2 -2      mlton/include/c-main.h

Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-main.h	23 Jun 2003 04:58:54 -0000	1.5
+++ c-main.h	5 Jul 2003 23:30:25 -0000	1.6
@@ -16,8 +16,8 @@
 		fprintf (stderr, "MLton_callFromC() starting\n");	\
 	s = &gcState;							\
 	s->savedThread = s->currentThread;				\
-	s->canHandle++;							\
-	/* Return to the C Handler thread. */				\
+	s->canHandle += 2;						\
+	/* Switch to the C Handler thread. */				\
 	GC_switchToThread (s, s->callFromCHandler);			\
 	nextFun = *(int*)(s->stackTop - WORD_SIZE);			\
 	cont.nextChunk = nextChunks[nextFun];				\



1.6       +1 -1      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- x86-main.h	23 Jun 2003 04:58:54 -0000	1.5
+++ x86-main.h	5 Jul 2003 23:30:25 -0000	1.6
@@ -71,7 +71,7 @@
 		fprintf (stderr, "MLton_callFromC() starting\n");	\
 	s = &gcState;							\
 	s->savedThread = s->currentThread;				\
-	s->canHandle++;							\
+	s->canHandle += 2;						\
 	/* Return to the C Handler thread. */				\
 	GC_switchToThread (s, s->callFromCHandler);			\
 	jump = *(pointer*)(s->stackTop - WORD_SIZE);			\



1.7       +1 -0      mlton/mlton/atoms/type-ops.fun

Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-ops.fun	23 Jun 2003 04:58:55 -0000	1.6
+++ type-ops.fun	5 Jul 2003 23:30:25 -0000	1.7
@@ -29,6 +29,7 @@
    val exn = nullary Tycon.exn
    val int = IntSize.memoize (fn s => nullary (Tycon.int s))
    val intInf = nullary Tycon.intInf
+   val pointer = nullary Tycon.pointer
    val preThread = nullary Tycon.preThread
    val real = RealSize.memoize (fn s => nullary (Tycon.real s))
    val thread = nullary Tycon.thread



1.7       +1 -0      mlton/mlton/atoms/type-ops.sig

Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-ops.sig	23 Jun 2003 04:58:55 -0000	1.6
+++ type-ops.sig	5 Jul 2003 23:30:25 -0000	1.7
@@ -60,6 +60,7 @@
       val isTuple: t -> bool
       val list: t -> t
       val nth: t * int -> t
+      val pointer: t
       val preThread: t
       val real: realSize -> t
       val reff: t -> t



1.59      +2 -12     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.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- c-codegen.fun	24 Jun 2003 20:14:22 -0000	1.58
+++ c-codegen.fun	5 Jul 2003 23:30:26 -0000	1.59
@@ -242,18 +242,8 @@
    let
       fun declareExports () =
 	 if Ffi.numExports () > 0
-	    then
-	       let
-		  val _ = Ffi.declareExports {print = print}
-		  val {print, done} = outputH ()
-		  val _ = print "#include \"types.h\"\n"
-		  val _ = Ffi.declareHeaders {print = print}
-		  val _ = done ()
-	       in
-		  ()
-	       end
-	 else
-	    ()
+	    then Ffi.declareExports {print = print}
+	 else ()
       fun declareLoadSaveGlobals () =
 	 let
 	    val _ =



1.76      +3 -1      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- control.sig	18 Jun 2003 17:40:50 -0000	1.75
+++ control.sig	5 Jul 2003 23:30:26 -0000	1.76
@@ -50,8 +50,10 @@
       (* whether optimization passes should eliminate useless overflow tests *)
       val eliminateOverflow: bool ref
 
-      val exnHistory: bool ref
+      val exportHeader: bool ref
 	 
+      val exnHistory: bool ref
+
       (* *)
       datatype gcCheck =
 	 Limit



1.92      +5 -0      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -r1.91 -r1.92
--- control.sml	18 Jun 2003 17:40:50 -0000	1.91
+++ control.sml	5 Jul 2003 23:30:26 -0000	1.92
@@ -80,6 +80,11 @@
    control {name = "eliminate overflow",
 	    default = true,
 	    toString = Bool.toString}
+
+val exportHeader =
+   control {name = "export header",
+	    default = false,
+	    toString = Bool.toString}
    
 val exnHistory = control {name = "exn history",
 			  default = false,



1.21      +2 -1      mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- elaborate-core.fun	26 Jun 2003 19:17:30 -0000	1.20
+++ elaborate-core.fun	5 Jul 2003 23:30:26 -0000	1.21
@@ -336,7 +336,8 @@
 	       
 	    val nullary =
 	       [(Bool, Ctype.bool),
-		(Char, Ctype.con (Tycon.char, Vector.new0 ()))]
+		(Char, Ctype.con (Tycon.char, Vector.new0 ())),
+		(Pointer, Ctype.pointer)]
 	       @ List.map (IntSize.all, fn s => (Int s, Ctype.int s))
 	       @ List.map (RealSize.all, fn s => (Real s, Ctype.real s))
 	       @ List.map (WordSize.all, fn s => (Word s, Ctype.word s))



1.56      +14 -2     mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- compile.sml	26 Jun 2003 19:17:30 -0000	1.55
+++ compile.sml	5 Jul 2003 23:30:26 -0000	1.56
@@ -347,9 +347,20 @@
 			     (Elaborate.Env.layoutUsed basisEnv,
 			      Out.standard)
 		       in
-			 Process.succeed ()
+			  Process.succeed ()
 		       end
 	       else parseAndElaborateFiles (input, basisEnv)
+	    val _ =
+	       if not (!Control.exportHeader)
+		  then ()
+	       else 
+		  let
+		     val _ = Ffi.declareExports {print = fn _ => ()}
+		     val _ = print "#include \"types.h\"\n"
+		     val _ = Ffi.declareHeaders {print = print}
+		  in
+		     Process.succeed ()
+		  end
 	    val user = Decs.appends [prefix, input, suffix]
 	    val _ = parseElabMsg ()
 	    val basis = Decs.toList basis
@@ -501,7 +512,8 @@
 			     outputH = outputH}
       val _ = Control.message (Control.Detail, PropertyList.stats)
       val _ = Control.message (Control.Detail, HashSet.stats)
-   in ()
+   in
+      ()
    end
    
 end



1.140     +3 -0      mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.139
retrieving revision 1.140
diff -u -r1.139 -r1.140
--- main.sml	24 Jun 2003 20:14:22 -0000	1.139
+++ main.sml	5 Jul 2003 23:30:26 -0000	1.140
@@ -167,6 +167,9 @@
        (Expert, "expert", " {false|true}",
 	"enable expert status",
 	boolRef expert),
+       (Normal, "export-header", " {false|true}",
+	"output header file for _export's",
+	boolRef exportHeader),
        (Expert, "gc-check", " {limit|first|every}", "force GCs",
 	SpaceString (fn s =>
 		     gcCheck :=



1.11      +2 -0      mlton/runtime/basis/Thread.c

Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- Thread.c	19 Apr 2003 17:12:16 -0000	1.10
+++ Thread.c	5 Jul 2003 23:30:26 -0000	1.11
@@ -31,6 +31,8 @@
 }
 
 void Thread_setSaved (Thread t) {
+	if (DEBUG_THREAD)
+		fprintf (stderr, "Thread_setSaved (0x%08x)\n", (uint)t);
 	gcState.savedThread = (GC_thread)t;
 }
 





-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100006ave/direct;at.asp_061203_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel