[MLton] cvs commit: critical sections during thread switch

Matthew Fluet fluet@mlton.org
Thu, 1 Apr 2004 18:49:53 -0800


fluet       04/04/01 18:49:52

  Modified:    basis-library/mlton cont.sml thread.sig thread.sml
               include  c-main.h x86-main.h
               mlton/backend ssa-to-rssa.fun
               runtime  gc.c
               runtime/basis Thread.c
  Log:
  MAIL critical sections during thread switch
  
  Added an implicit canHandle-- to GC_switchToThread.  This meant
  adjusting a lot of the atomicBegin/End calls in thread.sml and
  cont.sml.  I've annotated the code with the expected atomic state;
  (technically, the least value of the atomic state; everything should
  be fine if the calls are nested within an outer critical section; upon
  returning to user code, the atomic state should be the same as upon
  entry).
  
  Rather than having two separate switchTo calls, I just put an extra
  atomicBegin when switching to a New thread; this prevents switching
  threads at the implicit canHandle-- in GC_switchToThread; once the new
  thread is copied and ready to run, we atomicEnd.
  
  While I was at it, I modified the ssa-to-rssa translation to force a
  collection when atomicEnd drops the atomic state to 0 and a signal is
  pending.

Revision  Changes    Path
1.11      +1 -2      mlton/basis-library/mlton/cont.sml

Index: cont.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/cont.sml,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- cont.sml	29 Dec 2002 01:22:58 -0000	1.10
+++ cont.sml	2 Apr 2004 02:49:51 -0000	1.11
@@ -1,7 +1,6 @@
 structure MLtonCont:> MLTON_CONT =
 struct
 
-structure Thread' = MLtonThread
 structure Thread = Primitive.Thread
 
 (* This mess with dummy is so that if callcc is ever used anywhere in the
@@ -17,7 +16,7 @@
 
 fun callcc (f: 'a t -> 'a): 'a =
    (dummy ()
-    ; if Thread'.amInSignalHandler ()
+    ; if MLtonThread.amInSignalHandler ()
 	 then die "callcc can not be used in a signal handler\n"
       else 
 	 let



1.10      +38 -2     mlton/basis-library/mlton/thread.sig

Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- thread.sig	30 Mar 2004 01:44:13 -0000	1.9
+++ thread.sig	2 Apr 2004 02:49:51 -0000	1.10
@@ -6,11 +6,17 @@
  *)
 signature MLTON_THREAD =
    sig
-      type 'a t
-
+      structure AtomicState :
+	 sig
+	    datatype t = NonAtomic | Atomic of int
+	 end
       val atomicBegin: unit -> unit
       val atomicEnd: unit -> unit
       val atomically: (unit -> 'a) -> 'a
+      val atomicState: unit -> AtomicState.t
+
+      type 'a t
+
       (* new f creates a new thread that will apply f to whatever is thrown
        * to the thread.  f must terminate by throwing to another thread or
        * exiting the process.
@@ -32,6 +38,36 @@
        * place).
        *)
       val switch': ('a t -> 'b t * (unit -> 'b)) -> 'a
+      (* atomicSwitch and atomicSwitch' are as above,
+       * but assume an atomic calling context.
+       *)
+      val atomicSwitch': ('a t -> 'b t * (unit -> 'b)) -> 'a
+      val atomicSwitch: ('a t -> 'b t * 'b) -> 'a
+
+      (*
+      (* One-shot continuations. *)
+      (* capture f
+       * Applies f to the current thread.
+       * If f returns or raises, then it implicitly escapes to the
+       * current thread.
+       *)
+      val capture: ('a t -> 'a) -> 'a
+      (* escape (t, x)
+       * Switch to t with argument x.
+       * It is illegal for another thread to later escape to t.
+       *)
+      val escape: 'a t * 'a -> 'b
+      (* escape' (t, th)
+       * Generalization of escape that evaluates the thunk th in the
+       * context of t (i.e., t's stack and exception handlers are in
+       * place).
+       *)
+      val escape': 'a t * (unit -> 'a) -> 'b
+
+      val atomicCapture: ('a t -> 'a) -> 'a
+      val atomicEscape: 'a t * 'a -> 'b
+      val atomicEscape': 'a t * (unit -> 'a) -> 'b
+      *)
    end
 
 signature MLTON_THREAD_EXTRA =



1.24      +230 -120  mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- thread.sml	30 Mar 2004 01:44:13 -0000	1.23
+++ thread.sml	2 Apr 2004 02:49:51 -0000	1.24
@@ -9,11 +9,20 @@
 
 structure Prim = Primitive.Thread
 
+structure AtomicState =
+   struct
+      datatype t = NonAtomic | Atomic of int
+   end
+
 local
    open Prim
 in
    val atomicBegin = atomicBegin
    val atomicEnd = atomicEnd
+   val atomicState = fn () =>
+      case canHandle () of
+	 0 => AtomicState.NonAtomic
+       | n => AtomicState.Atomic n
 end
 
 fun atomically f =
@@ -31,77 +40,167 @@
    let
       val t =
 	 case !r of
-	    Dead => raise Fail "Thread.prepend"
+	    Dead => raise Fail "prepend to a Dead thread"
 	  | New g => New (g o f)
 	  | Paused (g, t) => Paused (fn h => g (f o h), t)
    in r := Dead
       ; T (ref t)
    end
 
-datatype state =
-   Normal
- | InHandler
-    
-val state: state ref = ref Normal
-
-fun amInSignalHandler () = InHandler = !state
-
 fun new f = T (ref (New f))
 
 local
-   val func: (unit -> unit) option ref = ref NONE
-   val base: Prim.preThread =
-      (Prim.copyCurrent ()
-       ; (case !func of
-	     NONE => Prim.savedPre ()
-	   | SOME x =>
-		(* This branch never returns. *)
-		(func := NONE
-		 (* Close the atomicBegin of the thread that switched to me. *)
-		 ; 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)
+   local
+      val func: (unit -> unit) option ref = ref NONE
+      val base: Prim.preThread =
+	 let
+	    val () = Prim.copyCurrent ()
+	 in
+	    case !func of
+	       NONE => Prim.savedPre ()
+	     | SOME x =>
+		  (* This branch never returns. *)
+		  let
+		     (* Atomic 1 *)
+		     val () = func := NONE
+		     val () = atomicEnd ()
+		     (* Atomic 0 *)
+		  in
+		     (x () handle e => MLtonExn.topLevelHandler e)
+		     ; die "Thread didn't exit properly.\n"
+		  end
+	 end
+   in
+      fun newThread (f: unit -> unit) : Prim.thread =
+	 let
+	    (* Atomic 2 *)
+	    val () = func := SOME f
+	 in
+	    Prim.copy base
+	 end
+   end
    val switching = ref false
 in
-   fun ('a, 'b) switch'NoAtomicBegin (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+   fun ('a, 'b) atomicSwitch' (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+      (* Atomic 1 *)
       if !switching
-	 then (atomicEnd ()
-	       ; raise Fail "nested Thread.switch")
+	 then let
+		 val () = atomicEnd ()
+		 (* Atomic 0 *)
+	      in
+		 raise Fail "nested Thread.switch"
+	      end
       else
 	 let
 	    val _ = switching := true
-	    val r: (unit -> 'a) option ref = ref NONE
+	    val r : (unit -> 'a) ref = 
+	       ref (fn () => die "Thread.atomicSwitch' didn't set r.\n")
 	    val t: 'a thread ref =
-	       ref (Paused (fn x => r := SOME x, Prim.current ()))
+	       ref (Paused (fn x => r := x, Prim.current ()))
 	    fun fail e = (t := Dead
 			  ; switching := false
 			  ; atomicEnd ()
-			  ; raise e)
+			  ; raise e)	
 	    val (T t': 'b t, x: unit -> 'b) = f (T t) handle e => fail e
 	    val primThread =
-	       case !t' before (t' := Dead; switching := false) of
+	       case !t' before t' := Dead of
 		  Dead => fail (Fail "switch to a Dead thread")
-		| New g => newThread (g o x)
+		| New g => (atomicBegin (); newThread (g o x))
 		| Paused (f, t) => (f x; t)
-	    val _ = Prim.switchTo primThread
-	    (* Close the atomicBegin of the thread that switched to me. *)
-	    val _ = atomicEnd ()
+	    val _ = switching := false
+	    (* Atomic 1 when Paused, Atomic 2 when New *)
+	    val _ = Prim.switchTo primThread (* implicit atomicEnd() *)
+	    (* Atomic 0 when resuming *)
 	 in
-	    case !r of
-	       NONE => die "Thread.switch didn't set r.\n"
-	     | SOME v => (r := NONE; v ())
+	    !r ()
 	 end
+
    fun switch' f =
       (atomicBegin ()
-       ; switch'NoAtomicBegin f)
+       ; atomicSwitch' f)
+
+(* 
+   (* One-shot continuations. *)
+   fun 'a atomicEscape' (T t : 'a t, x : unit -> 'a) : 'b =
+      let
+	 val switchee : Prim.thread =
+	    case !t before t := Dead of
+	       Dead => raise (Fail "escape to a Dead thread")
+	     | New g => (atomicBegin (); newThread (g o x))
+	     | Paused (f, t) => (f x; t)
+      in
+	 Prim.switchTo switchee
+	 ; die "Thread.atomicEscape' reached impossible.\n"
+      end
+   fun 'a atomicEscape (t : 'a t, v : 'a) : 'b =
+      atomicEscape' (t, fn () => v)
+   fun escape' (t, x) =
+      (atomicBegin ()
+       ; atomicEscape' (t, x))
+   fun escape (t, x) =
+      (atomicBegin ()
+       ; atomicEscape (t, x))
+
+   fun 'a atomicCapture (f: 'a t -> 'a) : 'a =
+      let
+	 val r : (unit -> 'a) ref = 
+	    ref (fn () => die "Thread.atomicCapture didn't set r.\n")
+	 val t : 'a t = 
+	    T (ref (Paused (fn x => r := x, Prim.current ())))
+	 val switcher : Prim.thread =
+	    (atomicBegin ()
+	     ; newThread (fn () => 
+			  let val v = f t
+			  in escape (t, v)
+			  end 
+			  handle e =>
+			     escape' (t, fn () => raise e)))
+	 val _ = Prim.switchTo switcher
+      in
+	 !r ()
+      end
+   fun capture f =
+      (atomicBegin ()
+       ; atomicCapture f)
+
+   fun ('a, 'b) atomicSwitch' (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+      if !switching
+	 then (atomicEnd ()
+	       ; raise Fail "nested Thread.switch")
+      else
+	 let
+	    val () = switching := true
+	    fun finish v () = (switching := false; atomicEnd (); v ())
+	    fun fail e = finish (fn () => raise e) ()
+	    val v = capture (fn t => 
+			     let val (t', v') = f t
+			     in escape' (t', finish v')
+			     end)
+	            handle e => fail e
+	 in
+	    v
+	 end
+*)
 end
 
+fun atomicSwitch f =
+   atomicSwitch' (fn t => let val (t, x) = f t
+			  in (t, fn () => x)
+			  end)
 fun switch f =
-   switch' (fn t => let val (t, x) = f t
-		    in (t, fn () => x)
-		    end)
+   (atomicBegin ()
+    ; atomicSwitch f)
+
+
+fun fromPrimitive (t: Prim.thread): unit t =
+   let
+      fun f x =
+	 x ()
+	 handle _ => 
+	    die "Asynchronous exceptions are not allowed.\n"
+   in
+      T(ref(Paused (f,t)))
+   end
 
 fun toPrimitive (t as T r : unit t): Prim.thread =
    case !r of
@@ -111,94 +210,105 @@
 	  ; f (fn () => ()) 
 	  ; t)
     | New _ =>
-	 switch' (fn cur: Prim.thread t =>
-		  (t, fn () => switch (fn t => (cur, toPrimitive t))))
+	 switch' 
+	 (fn cur: Prim.thread t =>
+	  (t: unit t, fn () => 
+	   switch 
+	   (fn t : unit t => 
+	    (cur, toPrimitive t))))
 
-fun fromPrimitive (t: Prim.thread): unit t =
-   T (ref (Paused
-	   (fn f => ((atomicEnd (); f ())
-		     handle _ =>
-			die "Asynchronous exceptions are not allowed.\n"),
-	    t)))
 
-val signalHandler: Prim.thread option ref = ref NONE
+local
+   val signalHandler: Prim.thread option ref = ref NONE
+   datatype state = Normal | InHandler
+   val state: state ref = ref Normal
+in
+   fun amInSignalHandler () = InHandler = !state
    
-fun setHandler (f: unit t -> unit t): unit =
-   let
-      val _ = Primitive.installSignalHandler ()
-      fun loop () =
-	 let
-	    (* s->canHandle == 1 *)
-	    val _ = state := InHandler
-	    val t = f (fromPrimitive (Prim.saved ()))
-	    val _ = state := Normal
-	    val _ = Prim.finishHandler ()
-	    val _ =
-	       switch'NoAtomicBegin
-	       (fn (T r) =>
-		let
-		   val _ =
-		      case !r of
-			 Paused (f, _) => f (fn () => ())
-		       | _ => raise Fail "setHandler saw strange Paused"
-		in
-		   (t, fn () => ())
-		end)
-	 in
-	    loop ()
-	 end
-      val p =
-	 toPrimitive
-	 (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
-      val _ = signalHandler := SOME p
-   in
-      Prim.setHandler p
-   end
+   fun setHandler (f: unit t -> unit t): unit =
+      let
+	 val _ = Primitive.installSignalHandler ()
+	 fun loop (): unit =
+	    let
+	       (* Atomic 1 *)
+	       val _ = state := InHandler
+	       val t = f (fromPrimitive (Prim.saved ()))
+	       val _ = state := Normal
+	       val _ = Prim.finishHandler ()
+	       val _ =
+		  atomicSwitch'
+		  (fn (T r) =>
+		   let
+		      val _ =
+			 case !r of
+			    Paused (f, _) => f (fn () => ())
+			  | _ => raise Fail "setHandler saw strange thread"
+		   in
+		      (t, fn () => ())
+		   end) (* implicit atomicEnd () *)
+	    in
+	       loop ()
+	    end
+	 val p =
+	    toPrimitive
+	    (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
+	 val _ = signalHandler := SOME p
+      in
+	 Prim.setHandler p
+      end
+
+   fun switchToHandler () =
+      let
+	 (* Atomic 0 *)
+	 val () = Prim.startHandler () (* implicit atomicBegin() *)
+         (* Atomic 1 *)
+	 val () = atomicBegin ()
+         (* Atomic 2 *)
+      in
+	 case !signalHandler of
+	    NONE => raise Fail "no signal handler installed"
+	  | SOME t => Prim.switchTo t (* implicit atomicEnd() *)
+      end
+end
 
-val register: int * (unit -> unit) -> unit =
-   let
-      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 () =>
+
+local
+
+in
+   val register: int * (unit -> unit) -> unit =
+      let
+	 val exports = Array.array (Primitive.FFI.numExports, fn () =>
+				    raise Fail "undefined export")
+	 fun loop (): unit =
+	    let
+	       (* Atomic 2 *)
+	       val t = Prim.saved ()
+	       fun doit () =
 		  let
+		     (* Atomic 1 *)
 		     val _ = 
+			(* atomicEnd() after getting args *)
 			(Array.sub (exports, Primitive.FFI.getOp ()) ())
-			handle e => (TextIO.output
-				     (TextIO.stdErr,
-				      "Call from C to SML raised exception.\n")
-				     ; MLtonExn.topLevelHandler e)
+			handle e => 
+			   (TextIO.output 
+			    (TextIO.stdErr, "Call from C to SML raised exception.\n")
+			    ; MLtonExn.topLevelHandler e)
+			(* atomicBegin() before putting res *)
+		     (* Atomic 1 *)
 		     val _ = Prim.setSaved t
-		     val _ = Prim.returnToC ()
+		     val _ = Prim.returnToC () (* implicit atomicEnd() *)
 		  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 (fn () =>
-						     (atomicBegin ()
-						      ; loop ()))))
-   in
-      fn (i, f) => Array.update (exports, i, f)
-   end
-
-fun switchToHandler () =
-   (Prim.startHandler ()
-    ; (case !signalHandler of
-	  NONE => raise Fail "no signal handler installed"
-	| SOME t => Prim.switchTo t))
-
+		  end
+	       val _ = Prim.switchTo (toPrimitive (new doit)) (* implicit atomicEnd() *)
+	    in
+	       loop ()
+	    end
+	 val p = toPrimitive (new (fn () => loop ()))
+	 val _ = Prim.setCallFromCHandler p
+      in
+	 fn (i, f) => Array.update (exports, i, f)
+      end
 end
 
+end



1.8       +1 -2      mlton/include/c-main.h

Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- c-main.h	29 Aug 2003 00:25:20 -0000	1.7
+++ c-main.h	2 Apr 2004 02:49:52 -0000	1.8
@@ -16,7 +16,7 @@
 		fprintf (stderr, "MLton_callFromC() starting\n");	\
 	s = &gcState;							\
 	s->savedThread = s->currentThread;				\
-	s->canHandle += 2;						\
+	s->canHandle += 3;						\
 	/* Switch to the C Handler thread. */				\
 	GC_switchToThread (s, s->callFromCHandler);			\
 	nextFun = *(int*)(s->stackTop - WORD_SIZE);			\
@@ -26,7 +26,6 @@
  		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
 	} while (not returnToC);					\
 	GC_switchToThread (s, s->savedThread);				\
-	s->canHandle--;							\
  	s->savedThread = BOGUS_THREAD;					\
 	if (DEBUG_CCODEGEN)						\
 		fprintf (stderr, "MLton_callFromC done\n");		\



1.11      +1 -2      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-main.h	29 Aug 2003 00:25:20 -0000	1.10
+++ x86-main.h	2 Apr 2004 02:49:52 -0000	1.11
@@ -75,13 +75,12 @@
 		fprintf (stderr, "MLton_callFromC() starting\n");	\
 	s = &gcState;							\
 	s->savedThread = s->currentThread;				\
-	s->canHandle += 2;						\
+	s->canHandle += 3;						\
 	/* Return to the C Handler thread. */				\
 	GC_switchToThread (s, s->callFromCHandler);			\
 	jump = *(pointer*)(s->stackTop - WORD_SIZE);			\
 	MLton_jumpToSML(jump);						\
 	GC_switchToThread (s, s->savedThread);				\
-	s->canHandle--;							\
 	s->savedThread = BOGUS_THREAD;					\
 	if (DEBUG_X86CODEGEN)						\
 		fprintf (stderr, "MLton_callFromC() done\n");		\



1.65      +49 -34    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.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- ssa-to-rssa.fun	19 Mar 2004 04:40:07 -0000	1.64
+++ ssa-to-rssa.fun	2 Apr 2004 02:49:52 -0000	1.65
@@ -859,7 +859,10 @@
 	     | Type.Real s => c (Const.real (RealX.zero s))
 	     | Type.Word s => c (Const.word (WordX.zero s))
 	 end
-      val handlesSignals = ref false
+      val handlesSignals = 
+	 S.Program.hasPrim 
+	 (program, fn p => 
+	  Prim.name p = Prim.Name.MLton_installSignalHandler)
       fun translateStatementsTransfer (statements, ss, transfer) =
 	 let
 	    fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -1237,9 +1240,7 @@
 				    (case targ () of
 					NONE => move (Operand.bool true)
 				      | SOME _ => primApp prim)
-			       | MLton_installSignalHandler =>
-				    (handlesSignals := true
-				     ; none ())
+			       | MLton_installSignalHandler => none ()
 			       | MLton_touch => none ()
 			       | Pointer_getInt s => pointerGet (Type.Int s)
 			       | Pointer_getPointer =>
@@ -1271,11 +1272,9 @@
 				    (Vector.new1 (a 0),
 				     refRep (Vector.sub (targs, 0)))
 			       | Thread_atomicBegin =>
-				    (* assert (s->canHandle >= 0);
-				     * s->canHandle++;
-				     * if (s->signalIsPending)
-				     *         s->limit = s->limitPlusSlop
-				     *                    - LIMIT_SLOP;
+				    (* gcState.canHandle++;
+				     * if (gcState.signalIsPending)
+				     *   gcState.limit = gcState.limitPlusSlop - LIMIT_SLOP;
 				     *)
 				    split
 				    (Vector.new0 (), Kind.Jump, ss, fn l =>
@@ -1309,39 +1308,50 @@
 							{args = Vector.new0 (),
 							 dst = l})}
 				     in
-					(bumpCanHandle 1,
-					 Transfer.ifInt
-					 (Operand.Runtime SignalIsPending,
-					  {falsee = l,
-					   truee = l'}))
+					if handlesSignals 
+					   then (bumpCanHandle 1,
+						 Transfer.ifInt
+						 (Operand.Runtime SignalIsPending,
+						  {falsee = l,
+						   truee = l'}))
+					   else (bumpCanHandle 1,
+						 Transfer.Goto
+						 {args = Vector.new0 (),
+						  dst = l})
 				     end)
 			       | Thread_atomicEnd =>
 				    (* gcState.canHandle--;
-				     * assert(gcState.canHandle >= 0);
 				     * if (gcState.signalIsPending
 				     *     and 0 == gcState.canHandle)
-				     *         gcState.limit = 0;
+				     *   gc;
 				     *)
 				    split
 				    (Vector.new0 (), Kind.Jump, ss, fn l =>
 				     let
 					datatype z = datatype GCField.t
-					val statements =
-					   Vector.new1
-					   (Statement.Move
-					    {dst = Operand.Runtime Limit,
-					     src =
-					     Operand.word
-					     (WordX.zero (WordSize.pointer ()))})
+					val func = CFunction.gc {maySwitchThreads = true}
+					val args = 
+					   Vector.new5
+					   (Operand.GCState,
+					    Operand.int (IntX.zero IntSize.default),
+					    Operand.bool false,
+					    Operand.File,
+					    Operand.Line)
+					val l''' = 
+					   newBlock
+					   {args = Vector.new0 (),
+					    kind = Kind.CReturn {func = func},
+					    statements = Vector.new0 (),
+					    transfer = Goto {args = Vector.new0 (),
+							     dst = l}}
 					val l'' =
 					   newBlock
 					   {args = Vector.new0 (),
 					    kind = Kind.Jump,
-					    statements = statements,
-					    transfer =
-					    Transfer.Goto
-					    {args = Vector.new0 (),
-					     dst = l}}
+					    statements = Vector.new0 (),
+					    transfer = Transfer.CCall {args = args,
+								       func = func,
+								       return = SOME l'''}}
 					val l' =
 					   newBlock
 					   {args = Vector.new0 (),
@@ -1353,11 +1363,16 @@
 					     {falsee = l'',
 					      truee = l})}
 				     in
-					(bumpCanHandle ~1,
-					 Transfer.ifInt
-					 (Operand.Runtime SignalIsPending,
-					  {falsee = l,
-					   truee = l'}))
+					if handlesSignals 
+					   then (bumpCanHandle ~1,
+						 Transfer.ifInt
+						 (Operand.Runtime SignalIsPending,
+						  {falsee = l,
+						   truee = l'}))
+					   else (bumpCanHandle ~1,
+						 Transfer.Goto
+						 {args = Vector.new0 (),
+						  dst = l})
 				     end)
 			       | Thread_canHandle =>
 				    move (Operand.Runtime GCField.CanHandle)
@@ -1517,7 +1532,7 @@
 	  end
       val functions = List.revMap (functions, translateFunction)
       val p = Program.T {functions = functions,
-			 handlesSignals = !handlesSignals,
+			 handlesSignals = handlesSignals,
 			 main = main,
 			 objectTypes = objectTypes}
       val _ = Program.clear p



1.172     +28 -24    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.171
retrieving revision 1.172
diff -u -r1.171 -r1.172
--- gc.c	29 Mar 2004 01:08:38 -0000	1.171
+++ gc.c	2 Apr 2004 02:49:52 -0000	1.172
@@ -655,13 +655,13 @@
 			(uint) s->frontier,
 			s->frontier - s->nursery,
 			s->limitPlusSlop - s->frontier);
-	fprintf (stream, "\tcanHandle = %d\n", s->canHandle);
+	fprintf (stream, "\tcanHandle = %d\n\tsignalsIsPending = %d\n", s->canHandle, s->signalIsPending);
 	fprintf (stderr, "\tcurrentThread = 0x%08x\n", (uint) s->currentThread);
-	fprintf (stream, "\tstackBottom = 0x%08x\nstackTop - stackBottom = %u\nstackLimit - stackTop = %u\n",
+	fprintf (stream, "\tstackBottom = 0x%08x\n\tstackTop - stackBottom = %u\n\tstackLimit - stackTop = %u\n",
 			(uint)s->stackBottom,
 			s->stackTop - s->stackBottom,
 			(s->stackLimit - s->stackTop));
-	fprintf (stream, "\texnStack = %u  bytesNeeded = %u  reserved = %u  used = %u\n",
+	fprintf (stream, "\texnStack = %u\n\tbytesNeeded = %u\n\treserved = %u\n\tused = %u\n",
 			s->currentThread->exnStack,
 			s->currentThread->bytesNeeded,
 			s->currentThread->stack->reserved,
@@ -3059,10 +3059,28 @@
 	assert (s->currentThread->bytesNeeded <= s->limitPlusSlop - s->frontier);
 }
 
+static void startHandler (GC_state s) {
+	/* Switch to the signal handler thread. */
+	if (DEBUG_SIGNALS) {
+		fprintf (stderr, "switching to signal handler\n");
+		GC_display (s, stderr);
+	}
+	assert (0 == s->canHandle);
+	assert (s->signalIsPending);
+	s->signalIsPending = FALSE;
+	s->inSignalHandler = TRUE;
+	s->savedThread = s->currentThread;
+	/* Set s->canHandle to 1 when switching to the signal handler thread, 
+	 * which will then run atomically and will finish by switching to 
+	 * the thread to continue with, which will decrement s->canHandle to 0.
+ 	 */
+	s->canHandle = 1;
+}
+
 void GC_switchToThread (GC_state s, GC_thread t) {
 	if (DEBUG_THREADS)
 		fprintf (stderr, "GC_switchToThread (0x%08x)\n", (uint)t);
-	if (FALSE) {
+	if (TRUE) {
 		/* This branch is slower than the else branch, especially 
 		 * when debugging is turned on, because it does an invariant
 		 * check on every thread switch.
@@ -3070,6 +3088,11 @@
 		 */
 	 	enter (s);
 	  	switchToThread (s, t);
+		s->canHandle--;
+		if (0 == s->canHandle and s->signalIsPending) {
+			startHandler(s);
+			switchToThread(s, s->signalHandler);
+		}
 	 	leave (s);
 	} else {
 		s->currentThread->stack->used = currentStackUsed (s);
@@ -3085,25 +3108,6 @@
 	assert (s->currentThread->bytesNeeded <= s->limitPlusSlop - s->frontier);
 }
 
-static void startHandler (GC_state s) {
-	/* Switch to the signal handler thread. */
-	if (DEBUG_SIGNALS) {
-		fprintf (stderr, "switching to signal handler\n");
-		GC_display (s, stderr);
-	}
-	assert (0 == s->canHandle);
-	assert (s->signalIsPending);
-	s->signalIsPending = FALSE;
-	s->inSignalHandler = TRUE;
-	s->savedThread = s->currentThread;
-	/* Set s->canHandle to 2, which will be decremented to 1
-	 * when switching to the signal handler thread, which will then
- 	 * run atomically and will finish by switching to the thread
-	 * to continue with, which will decrement s->canHandle to 0.
- 	 */
-	s->canHandle = 2;
-}
-
 /* GC_startHandler does not do an enter()/leave(), even though it is exported.
  * The basis library uses it via _ffi, not _prim, and so does not treat it as a
  * runtime call -- so the invariant in enter would fail miserably. It simulates
@@ -4536,7 +4540,7 @@
  */
 void GC_handler (GC_state s, int signum) {
 	if (DEBUG_SIGNALS)
-		fprintf (stderr, "GC_handler  signum = %d\n", signum);
+		fprintf (stderr, "GC_handler signum = %d\n", signum);
 	assert (sigismember (&s->signalsHandled, signum));
 	if (0 == s->canHandle)
 		s->limit = 0;



1.12      +7 -2      mlton/runtime/basis/Thread.c

Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- Thread.c	5 Jul 2003 23:30:26 -0000	1.11
+++ Thread.c	2 Apr 2004 02:49:52 -0000	1.12
@@ -9,7 +9,12 @@
 };
 
 Thread Thread_current () {
-	return (Thread)gcState.currentThread;
+	Thread t;
+
+	t = (Thread)gcState.currentThread;
+	if (DEBUG_THREAD)
+		fprintf (stderr, "0x%08x = Thread_current ()\n", (uint)t);
+	return t;
 }
 
 void Thread_finishHandler () {
@@ -47,7 +52,7 @@
 void Thread_switchTo (Thread thread, Word ensureBytesFree) {
 	GC_state s;
 
-	if (FALSE)
+	if (DEBUG_THREAD)
 		fprintf (stderr, "Thread_switchTo (0x%08x, %u)\n",
 				(uint)thread, (uint)ensureBytesFree);
 	s = &gcState;