(* threads.sml *)

(* an implementation of threads, using continuations as threads, and
   an interval timer and signal handling to do context-switching *)

(* Running this code on 110.45 sometimes leads to

     sml: Fatal error -- Uncaught exception Fail with "inconsistent state HANDLER(mask=1<>0) for signal 14" raised at Basis/Implementation/NJ/internal-signals.sml:299.16-299.24

   Signal 14 is the ALRM signal used for preemptive scheduling.  I'm
   not sure whose bug this is. *)

structure Threads :> THREADS =
struct

structure C   = SMLofNJ.Cont
structure Q   = Queue
structure IT  = SMLofNJ.IntervalTimer
structure Sig = Signals

(* keep track of some statistics *)

val switchesRef                = ref 0
val delayedSwitchesRef         = ref 0
val duplicateSwitchRequestsRef = ref 0
val spawnsRef                  = ref 0
val exitsRef                   = ref 0

(* val print : string -> unit

   if a signal happens during an I/O operation, that operation will
   fail; thus we mask signals while doing a print

   when we unmask signals, any signals that occured while signals were
   masked will be delivered (but only one instance of each kind of
   signal) *)

fun print s =
      (Sig.maskSignals Sig.MASKALL;
       TextIO.print s;
       Sig.unmaskSignals Sig.MASKALL)

(* a thread is represented by a continuation of type unit *)

type thread = unit C.cont

(* once a main thread is started, this will contain SOME k, where k is
   the unit continuation that should be invoked to shutdown the
   program *)

val terminationContOptRef : unit C.cont option ref = ref NONE

(* the ready queue *)

val readyQueue : thread Q.queue = Q.mkQueue()

(* val switch : thread -> thread *)

fun switch k = (Q.enqueue(readyQueue, k); Q.dequeue readyQueue)

datatype atomic = NonAtomic | Atomic | AtomicAndSwitchDue

(* if !atomicRef is NonAtomic, then the current thread is not
   in an atomic region

   if it's Atomic, then the current thread is in an atomic region, and
   a context-switch is not overdue

   if it's AtomicAndSwitchDue, then the current thread is in an atomic
   region, and a context-switch is overdue *)

val atomicRef : atomic ref = ref NonAtomic

(* val atomicBegin : unit -> unit

   !atomicRef will be NonAtomic

   the assignment to atomicRef is atomic *)

fun atomicBegin() = atomicRef := Atomic

(* val atomicEnd : unit -> unit

   !atomicRef will be Atomic or AtomicAndSwitchDue

   because of the way code is generated, signals won't be checked for
   between finding out that !atomicRef is not AtomicAndSwitchDue and
   the setting of atomicRef's contents to NonAtomic; this avoids a
   race condition *)

fun atomicEnd() =
      if !atomicRef = AtomicAndSwitchDue
      then C.callcc(fn k : unit C.cont =>
                         let val k' = switch k
                         in switchesRef := !switchesRef + 1;
                            atomicRef := NonAtomic;
                            C.throw k' ()
                         end)
      else atomicRef := NonAtomic

(* val handler : 'a * 'b * thread -> thread *)

fun handler(_, _, k) =
      case !atomicRef of
           NonAtomic          => (switchesRef := !switchesRef + 1; switch k)
         | Atomic             =>
             (delayedSwitchesRef := !delayedSwitchesRef + 1;
              atomicRef := AtomicAndSwitchDue; k)
         | AtomicAndSwitchDue =>
              (duplicateSwitchRequestsRef := !duplicateSwitchRequestsRef + 1;
               k)

(* val exit : unit -> 'a *)

fun exit() =
      (atomicBegin();
       exitsRef := !exitsRef + 1;
       if Q.isEmpty readyQueue
       then C.throw (valOf(!terminationContOptRef)) ()
       else let val k = Q.dequeue readyQueue
            in atomicEnd(); C.throw k () end)

(* BEGIN MODIFIED CODE *)

(* val spawn : (unit -> unit) -> unit *)

fun spawn f =
      (atomicBegin();
       spawnsRef := !spawnsRef + 1;
       C.callcc(fn k : unit C.cont =>
                     (Q.enqueue(readyQueue, k);
                      atomicEnd();
                      f() handle _ => ();
                      exit())))

(* END MODIFIED CODE *)

fun run f =
      let val slice = Time.fromMilliseconds 30  (* time slice in millisecs *)
      in C.callcc
         (fn terminationCont =>
               (terminationContOptRef := SOME terminationCont;
                Q.clear readyQueue;
                atomicRef := NonAtomic;
                switchesRef := 0; delayedSwitchesRef := 0;
                duplicateSwitchRequestsRef := 0; spawnsRef := 0; exitsRef := 0;
                Sig.setHandler(Sig.sigALRM, Sig.HANDLER handler);
                IT.setIntTimer(SOME slice);
                f();
                exit()));
         IT.setIntTimer NONE;
         Sig.setHandler(Sig.sigALRM, Sig.DEFAULT);
         print "context switches: "; print(Int.toString(!switchesRef));
         print "\n";
         print "delayed context switches: ";
         print(Int.toString(!delayedSwitchesRef)); print "\n";
         print "duplicate context switch requests: ";
         print(Int.toString(!duplicateSwitchRequestsRef)); print "\n";
         print "spawns: "; print(Int.toString(!spawnsRef)); print "\n";
         print "exits: "; print(Int.toString(!exitsRef)); print "\n"
      end

end;