(* Mini-CML *)

signature CONCUR_ML =
  sig

  (** threads **)
    type thread_id
    val spawn : (unit -> unit) -> thread_id
    val yield : unit -> unit
    val exit: unit -> 'a

  (** channels **)
    type 'a chan
    val channel : unit -> 'a chan

  (** events **)
    type 'a event

    val sync : 'a event -> 'a
    val choose : 'a event list -> 'a event
    val wrap : ('a event * ('a -> 'b)) -> 'b event

    val ALWAYS : unit event

    val sendEvt : ('a chan * 'a) -> unit event
    val recvEvt : 'a chan -> 'a event

  end
functor ConcurML () : CONCUR_ML =  struct

type 'a cont = 'a SMLofNJ.Cont.cont
val callcc   = SMLofNJ.Cont.callcc
val throw    = SMLofNJ.Cont.throw

datatype thread_id = TID of {
  id : int,
  isDead : bool ref,
  waiters : (thread_id * bool ref * unit cont) list ref}

datatype 'a queue_t = Q of {front : 'a list ref,
			    rear : 'a list ref}

fun queueNew () = Q{front = ref [], rear = ref []}
fun queueIns (Q{rear, ...}) x = (rear := x :: !rear)
exception EmptyQ
fun queueRem (Q{front=ref[], rear=ref[]}) = 
          raise EmptyQ
  | queueRem (Q{front as (ref []), rear as (ref l)}) =
          let val (x::r) = rev l
           in front := r; rear := []; x
          end
  | queueRem (Q{front as (ref(x::r)), ...}) = 
          (front := r; x)

(* generate new thread ids *)
val nextId = ref 0
fun newId () = let val id = !nextId
                in nextId := id + 1;
                   TID{id = id, isDead = ref false, 
      		       waiters = ref []}
       	       end
val currentThread = ref (newId())

(* the thread ready queue *)
val rdyQ : (thread_id * unit cont) queue_t = queueNew()
val enqueue = queueIns rdyQ

fun dispatch () = let val (id,kont) = queueRem rdyQ
    		   in currentThread := id; throw kont ()
    		  end

fun yield() = callcc(fn k =>(enqueue(!currentThread, k);
			     dispatch()))
                   (** Channels **)

type 'a chanq = (bool ref * 'a) queue_t

datatype 'a chan = CHAN of
     {inq	: (thread_id * 'a cont) chanq,
      outq	: (thread_id * 'a * unit cont) chanq}

(** Channel queue routines **)
fun insert (q : 'a chanq, flg, item) = 
                           queueIns q (flg, item)
fun remove (q : 'a chanq) = 
       let val (flg, item) = queueRem q
        in flg := true; 
	   item
       end

(* Clean a channel of satisfied transactions.	 
   We do this incrementally to give an amortized 
   constant cost.  Return true if the resulting queue
   is non-empty. *)

fun clean(q as Q{front as ref((ref true,_)::rest),...})=
                 (front := rest; clean q)
  | clean(q as Q{front as ref nil, rear=ref nil}) = 
                 false
  | clean(q as Q{front as ref nil, rear as ref r}) = 
                 (front := rev r; rear := nil; clean q)
  | clean _ = true

fun channel() = CHAN{inq= queueNew(), outq= queueNew()}

fun spawn f = 
       let val id = newId()
        in callcc (fn parent_k => (
             enqueue(!currentThread, parent_k);
             currentThread := id;
             f ();
             dispatch()));
           id
       end
fun exit() = dispatch()
                 (** Events **)

type 'a base_evt = {pollfn : unit -> bool,
                    dofn : unit -> 'a,
		    blockfn : bool ref -> 'a}

type 'a event = 'a base_evt list

fun sublist p nil = nil
  | sublist p (x::r) = if p x then x :: sublist p r 
      			      else sublist p r

(* Generate index numbers for "non-deterministic" 
   selection.  We use a round-robin style policy. *)
val cnt = ref 0
fun random i = let val j = !cnt in cnt := j+1; (j mod i)
	       end

exception Escape

fun sync el =
     case sublist (fn{pollfn,...}=>pollfn()) el
      of [] => callcc (fn sync_k => 
	   let val evtflg = ref false
      	       fun log[] = dispatch()
      	         | log(({blockfn,...}:'a base_evt)::r) =
      	               (blockfn evtflg) 
		       handle Escape => log r
      	    in log el
      	   end)
          | [{dofn,...}] => dofn()
          | l => #dofn(List.nth(l, random(length l))) ()

fun wrap (el, f) =
      map (fn {pollfn, dofn, blockfn} =>
	   {pollfn=pollfn, dofn=(f o dofn), 
	    blockfn=(f o blockfn)})
          el

  fun choose [] = []
    | choose (evts :: el) = evts @ choose el
             (** Base events **)

val ALWAYS = [{pollfn = (fn () => true),
	       dofn = (fn () => ()),
	       blockfn = (fn _ => raise Escape)}]

fun sendEvt (CHAN{inq, outq}, msg) =
     [{pollfn= fn()=>clean inq,
       dofn= fn()=>let val (rid, rkont) = remove inq
      	            in callcc (fn k => (
      	                 enqueue(!currentThread,k);
      	                 currentThread := rid;
      	                 throw rkont msg))
      	           end,
       blockfn= fn flg => callcc (fn k => (
            clean outq;
	    insert(outq, flg, (!currentThread, msg, k));
      	    raise Escape))}]

  fun recvEvt (CHAN{inq, outq}) = 
     [{pollfn= fn () => clean outq,
       dofn= fn()=>let val (sid,msg,skont) = remove outq
      	            in enqueue (sid, skont);
      	               msg
      	           end,
       blockfn= fn flg => callcc (fn k => (
	  clean inq;
      	  insert (inq, flg, (!currentThread, k));
      	  raise Escape))}]

end (* functor ConcurML *)

structure CML = ConcurML()