[MLton] Bug in CML mailbox.sml

[Ray Racine]

The small program at the bottom fails as follows:

[ray@gan common]$ mlton mbox.mlb
[ray@gan common]$ ./mbox
Msg::0
Msg::1
Msg::2
Msg::3
Msg::4
unhandled exception: Fail: Thread.atomicEnd with no atomicBegin


What happens is if the mbox is used as in the context of a revcEvt and
the mailbox queue does not have a credit of msgs, but has a debit of at
least one waiting thread the above happens.

Either the queued receiving thread is in the wrong atomic context or the
switch to the queued thread assumes the wrong context.   

The one line fix below assumes the latter.  Not sure if this is THE fix
however.

In CML's mailbox.sml source file, send () function, on or about line 63.

case !state of 
  EMPTY q => (case (cleanAndDeque q) of
    (NONE, _) => 
	(let val q = Q.new ()
	in state := NONEMPTY (1, Q.enque (q, x))
	end
	; debug' "send(3a)"
	; S.atomicEnd())
	| (SOME (transId', t'), q') =>
	    (  debug' "send(3b)";
(** FIX is change to S.readyAndSwitch **)
        S.atomicReadyAndSwitch
	   (fn () =>
		(state := EMPTY q'
		; TransID.force transId'
		; S.prepVal (t', x)))))       			    
		| NONEMPTY (p, q) => 
.....

------ BUG Creating Program -----

structure Main =
struct

  datatype tmsg = Msg of int
		| Timeout
		  
  val mbox = Mailbox.mailbox ()

  fun write s = 
      (
       TextIO.output ( TextIO.stdOut, s );
       TextIO.flushOut TextIO.stdOut
      )
            
  structure Consumer = 
  struct
    
    fun recv () = 
	let fun handleMsg m = 
		MLton.Thread.atomically
		    ( fn () =>					     
			 case m of
			     Msg n => write ( concat [ "Msg::", 
						       Int.toString n, 
						       "\n" ] )
			   | Timeout => write "Timeout rec\n" )
	in
	    CML.select [ CML.wrap ( Mailbox.recvEvt 
					mbox, 
				    handleMsg ),
			 CML.wrap ( CML.timeOutEvt 
					( Time.fromSeconds 3 ), 
				    ( fn () =>  
					 handleMsg Timeout ) ) ];
	    recv ()
	end
	
    fun run () = CML.spawn recv
		 
  end

  structure Producer = 
  struct

    fun send n = let val n' = n + 1
		 in
		    Mailbox.send ( mbox, Msg n );
		    CML.sync ( CML.timeOutEvt 
				   ( Time.fromSeconds 1 ) );
		    send n'
		 end

    fun run () = CML.spawn ( fn () => send 0 )

  end

  fun run () =
      (
       Producer.run ();
       CML.sync ( CML.timeOutEvt 
		      ( Time.fromSeconds 5 ) );
       Consumer.run ()
      )

  fun main () =
      RunCML.doit ( ignore o run , NONE )

end

val _ = Main.main ()