Previous Up

B  Complete Source Code of the Implementations

B.1  System/VM preemptive scheduling

type α thread = α → unit
(∗let spawn t = ignore (Thread.create t ()); ()∗)
let dbg t = print_string t; print_newline()
let l = Mutex.create ()

let spawn t = ignore (Thread.create (fun () → Mutex.lock l; 
Mutex.unlock l; t ()) (); ())

let stop_event = Event.new_channel ()
let start () = Mutex.unlock l; Event.sync (Event.receive stop_event)
let stop () = Event.sync (Event.send stop_event ())

let halt = Thread.exit
let yield = Thread.yield

type α mvar = 
     { mutable v:α option; ch:α Event.channel; mutable read:bool; mutable write:bool }

let make_mvar () = 
   { v = None; ch = Event.new_channel (); read=false; write=false }

let ml = Mutex.create ()

let mvl () = Mutex.lock ml
let mvu () = Mutex.unlock ml

let put_mvar out v =
   mvl ();
   match out with
   ∣ { v=Some v′; ch=c; read=_; write=false } → out.write ← true; mvu ();
       Event.sync (Event.send c v)

   ∣ { v=None; ch=c; read=true; write=false } → mvu (); out.read ← false; Event.sync (Event.send c v)

   ∣ { v=None; ch=c; read=false; write=false } → out.v ← Some v; mvu ()

let take_mvar inp =
   mvl ();
   match inp with
   ∣ { v=Some v; ch=c; read=false; write=false } → inp.v ← None; mvu (); v

   ∣ { v=Some v; ch=c; read=false; write=true } → 
       inp.write ← false; mvu (); let v′ = Event.sync (Event.receive c) in
       mvl (); inp.v ← Some v′; mvu (); v

   ∣ { v=None; ch=c; read=false; write=_ } → 
       inp.read ← true; mvu (); Event.sync (Event.receive c)

   ∣ { v=None; ch=_; read=true; write=_ } → failwith "take_mvar2"

type α fifo = { q : α Queue.t; mutable w: α Event.channel option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f =
     if Queue.length f.q = 0 then
       let e = Event.new_channel () in
       f.w ← Some e;
       Event.sync (Event.receive e)
     else
       Queue.take f.q

let put_fifo f v =
     match f.w with
     ∣ None → Queue.add v f.q
     ∣ Some e → f.w ← None; Event.sync (Event.send e v)

Mutex.lock l

B.2  Capturing Continuations

open Callcc

type α t = α → unit

type queue_t = { mutable e:unit t; q:unit t Queue.t }

let q = { e = (fun()→()); q = Queue.create () }

let enqueue t = Queue.push t q.q
let dequeue () = try Queue.take q.q with Queue.Empty → q.e

let halt () = dequeue () ()

exception Stop
let stop () = raise Stop

let start () =
   try
     callcc (fun exitk →
       q.e ← (fun () → throw exitk ());
       dequeue () ())
   with Stop → ()

let yield () = 
   callcc (fun k → enqueue (fun () → throw k ()); dequeue () ())

let spawn p = enqueue (fun () → p (); halt ())

type α mvar = { mutable v:α option; 
                   mutable read: α t option;
                   mutable write: (unit t × α) option }

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v =
     match out with
     ∣ { v=Some v; read=_; write=None } →
         callcc (fun k → 
           out.write ← Some ((fun () → throw k ()),v); halt ())

     ∣ { v=None; read=Some r; write=None } → 
         out.read ← None; enqueue (fun () → r v)

     ∣ { v=None; read=None; write=None } → out.v ← Some v; ()

let take_mvar inp =
     match inp with
     ∣ { v=Some v; read=None; write=None } → inp.v ← None; v

     ∣ { v=Some v; read=None; write=Some(c, v′) } → 
         inp.v ← Some v′; inp.write ← None; enqueue c; v

     ∣ { v=None; read=None; write=_ } → 
         callcc (fun k →
           inp.read ← Some (fun v → throw k v);
           Obj.magic halt ())

type α fifo = { q : α Queue.t; mutable w: α t option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f =
   if Queue.length f.q = 0 then
     Callcc.callcc (fun k → f.w ← Some (fun v → Callcc.throw k v);
       Obj.magic halt ())
   else
     Queue.take f.q

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some k → enqueue (fun () → k (Queue.take f.q)); f.w ← None
   ∣ None → ()

B.3  Delimited Continuations

open Delimcc

type α t = α → unit

let runq = Queue.create ()
let enqueue t = Queue.push t runq
let dequeue () = Queue.take runq

let prompt = new_prompt ()

let yield () = shift0 prompt (fun f → enqueue f)

could use abort in halt, we just want to remove the prompt
let halt () = shift0 prompt (fun f → ())

enqueue a new t
let spawn p = enqueue (fun () → push_prompt prompt (fun () → p (); halt ()))

exception Stop
let stop () = raise Stop

let start () =
   try
     while true do
       dequeue () ()
     done
   with Queue.Empty ∣ Stop → ()

type α mvar = { mutable v:α option; 
                   mutable read: α t option; (∗ t blocked on take ∗)
                   mutable write: (unit t × α) option } (∗ ... on put ∗)

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v =
   match out with
   ∣ { v=Some v′; read=_; write=None } → 
       shift0 prompt (fun f → out.write ← Some (f,v))

   ∣ { v=None; read=Some r; write=None } → 
       out.read ← None; enqueue (fun () → r v)

   ∣ { v=None; read=None; write=None } → out.v ← Some v

let take_mvar inp =
   match inp with
   ∣ { v=Some v; read=None; write=None } → inp.v ← None; v

   ∣ { v=Some v; read=None; write=Some(c,v′) } → 
       inp.v ← Some v′; inp.write ← None; enqueue c; v

   ∣ { v=None; read=None; write=_ } → 
       shift0 prompt (fun f → inp.read ← Some(f))

type α fifo = { q : α Queue.t; mutable w: α t option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f =
   if Queue.length f.q = 0 then
     shift0 prompt (fun k → f.w ← Some k)
   else
     Queue.take f.q

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some k → enqueue (fun () → k (Queue.take f.q)); f.w ← None
   ∣ None → ()

B.4  Trampolined Style

type α thread = α → unit

let runq = Queue.create ()
let enqueue t = Queue.push t runq
let dequeue () = Queue.take runq

let skip k = k ()
let yield k = enqueue k
let halt () = ()
let spawn t = enqueue t

let close k = fun () → k (fun _ → ())

exception Stop
let stop () = raise Stop

let start () =
   try
     while true do
       dequeue () ()
     done
   with Queue.Empty ∣ Stop → ()

let (>>=) inst (k:α thread) : unit = inst k

type α mvar = { mutable v:α option; 
                   mutable read: α thread option;
                   mutable write: (unit thread × α) option }

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v k =
   match out with
   ∣ { v=Some v′; read=_; write=None } → out.write ← Some (k,v)

   ∣ { v=None; read=Some r; write=None } → 
         out.read ← None; enqueue (fun () → r v); k ()

   ∣ { v=None; read=None; write=None } → out.v ← Some v; k ()

let take_mvar inp k =
   match inp with
   ∣ { v=Some v; read=None; write=None } → inp.v ← None; k v

   ∣ { v=Some v; read=None; write=Some(c,v′) } → 
       inp.v ← Some v′; inp.write ← None; enqueue c; k v

   ∣ { v=None; read=None; write=_ } → inp.read ← Some(k)

type α fifo = { q : α Queue.t; mutable w: α thread option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f k =
   if Queue.length f.q = 0 then
     f.w ← Some k
   else
     k (Queue.take f.q)

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some k → enqueue (fun () → k (Queue.take f.q)); f.w ← None
   ∣ None → ()

B.5  Continuation Monad

type α t = (α → unit) → unit

let runq = Queue.create ()
let enqueue t = Queue.push t runq
let dequeue () = Queue.take runq

let return a : α t = fun k → k a

let skip = return ()
let yield () k = enqueue k
let halt () = return ()

let (>>=) (t:α t) (k2:α → β t) : β t = fun k → t (fun r → k2 r k)

let spawn (t:unit → unit t) = enqueue (fun () → t () (fun () → ()))

exception Stop
let stop () = raise Stop

let start () =
   try
     while true do
       dequeue () ()
     done
   with Queue.Empty ∣ Stop → ()

type α mvar = { mutable v:α option; 
                   mutable read: (α → unit) option;
                   mutable write: ((unit → unit) × α) option }

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v k =
   match out with
   ∣ { v=Some v′; read=_; write=None } → out.write ← Some (k,v)

   ∣ { v=None; read=Some r; write=None } → 
         out.read ← None; enqueue (fun () → r v); k ()

   ∣ { v=None; read=None; write=None } → out.v ← Some v; k ()

let take_mvar inp k =
   match inp with
   ∣ { v=Some v; read=None; write=None } → inp.v ← None; k v

   ∣ { v=Some v; read=None; write=Some(c,v′) } → 
       inp.v ← Some v′; inp.write ← None; enqueue c; k v

   ∣ { v=None; read=None; write=_ } → inp.read ← Some(k)

type α fifo = { q : α Queue.t; mutable w: (α → unit) option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f k =
   if Queue.length f.q = 0 then
     f.w ← Some k
   else
     k (Queue.take f.q)

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some k → enqueue (fun () → k (Queue.take f.q)); f.w ← None
   ∣ None → ()

B.6  Promise Monad

type α state =
   ∣ Ready of α
   ∣ Blocked of (α t → unit) list ref
   ∣ Link of α t

and α t = { mutable st : α state }

let rec repr t =
   match t.st with
   ∣ Link t′ → repr t′
   ∣ _ → t

let blocked () = { st = Blocked (ref [ ]) }
let ready v = { st = Ready v }
let return = ready

let runq = Queue.create ()
let enqueue t = Queue.push t runq
let dequeue () = Queue.take runq

let fullfill t v =
   let t = repr t in
   match t.st with
   ∣ Blocked w →
       t.st ← Ready v;
       List.iter (fun f → f t) !w
   ∣ _ → failwith "fullfill"

let connect t t′ =
   let t′ = repr t′ in
   match t′.st with
   ∣ Ready v → fullfill t v
   ∣ Blocked w′ →
       let t = repr t in
       match t.st with
       ∣ Blocked w → w := !w @ !w′; t′.st ← Link t
       ∣ _ → failwith "connect"

let (>>=) t f =
   match (repr t).st with
   ∣ Ready v → f v
   ∣ Blocked w → let res = blocked () in
     w := (fun t → let Ready v = t.st in connect res (f v)):: !w;
     res

let skip = ready ()
let halt () = ready ()

let yield () = let p = blocked () in enqueue (fun () → fullfill p ()); p

let wait_start = blocked ()

let spawn t = wait_start >>= t; ()

exception Stop
let stop () = raise Stop

let start () =
   try
     fullfill wait_start ();
     while true do
       dequeue () ()
     done
   with Queue.Empty ∣ Stop → ()

type α mvar = { mutable v:α option; 
                   mutable read: α t option;
                   mutable write: (unit t × α) option }

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v =
   match out with
   ∣ { v=Some v′; read=_; write=None } → 
       let w = blocked () in out.write ← Some (w,v); w

   ∣ { v=None; read=Some r; write=None } → 
       out.read ← None; enqueue (fun () → fullfill r v); ready ()

   ∣ { v=None; read=None; write=None } → out.v ← Some v; ready ()

let take_mvar inp =
   match inp with
   ∣ { v=Some v; read=None; write=None } → 
       inp.v ← None; ready v

   ∣ { v=Some v; read=None; write=Some(c,v′) } → 
       inp.v ← Some v′; inp.write ← None; enqueue (fun () → fullfill c ());
       ready v

   ∣ { v=None; read=None; write=_ } → 
       let w = blocked () in inp.read ← Some(w); w

type α fifo = { q : α Queue.t; mutable w: α t option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f =
   if Queue.length f.q = 0 then
     let k = blocked () in (f.w ← Some k; k)
   else
     ready (Queue.take f.q)

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some k → f.w ← None; fullfill k (Queue.take f.q)
   ∣ None → ()

B.7  Events

let skip k = k ()

let (>>=) inst k = inst k

type eventid = unit ref
type α event = Written of eventid ∣ Read of eventid × α ∣ Go of eventid

let make_eventid () = ref ()

let esys : int event Equeue.t = Equeue.create (fun _ → ())

let yield k = 
   let id = make_eventid () in
   Equeue.add_handler esys (fun esys e →
     match e with
     ∣ Go id′ when id′ ≡ id → k ()
     ∣ _ → raise Equeue.Reject);
   Equeue.add_event esys (Go id);
   raise Equeue.Terminate

let spawn t = 
   let id = make_eventid () in
   Equeue.add_handler esys (fun esys e →
     match e with
     ∣ Go id′ when id′ ≡ id → t ()
     ∣ _ → raise Equeue.Reject);
   Equeue.add_event esys (Go id)

let halt () = raise Equeue.Terminate

exception Stop
let stop () = raise Stop

let start () =
   try
     Equeue.run esys
   with Stop → ()

type α mvar = { mutable v:α option; 
                   mutable read:eventid option;
                   mutable write:(eventid × α) option }

let make_mvar () = { v=None; read=None; write=None }

let put_mvar out v k =
   match out with
   ∣ { v=Some v′; read=_; write=None } → 
       let id = make_eventid () in out.write ← Some (id, v);
       Equeue.add_handler esys (fun esys e →
         match e with
         ∣ Written id′ when id′ ≡ id → k ()
         ∣ _ → raise Equeue.Reject);
       raise Equeue.Terminate

   ∣ { v=None; read=Some id; write=None } → 
       out.read ← None;
       Equeue.add_event esys (Read(id, v));
       k ()

   ∣ { v=None; read=None; write=None } → out.v ← Some v; k ()

let take_mvar inp k =
   match inp with
   ∣ { v=Some v; read=None; write=None } → inp.v ← None; k v

   ∣ { v=Some v; read=None; write=Some(id, v′) } → 
       inp.v ← Some v′; inp.write ← None;
       Equeue.add_event esys (Written id); k v

   ∣ { v=None; read=None; write=_ } →
       let id = make_eventid () in
       inp.read ← Some id;
       Equeue.add_handler esys (fun esys e →
         match e with
         ∣ Read(id′, arg) when id′ ≡ id → k arg
         ∣ _ → raise Equeue.Reject);
       raise Equeue.Terminate

type α fifo = { q:α Queue.t; mutable w:eventid option }
let make_fifo () = { q=Queue.create (); w=None }

let take_fifo f k =
   if Queue.length f.q = 0 then
     let id = make_eventid () in
     f.w ← Some id;
     Equeue.add_handler esys (fun esys e →
       match e with
       ∣ Read(id′, arg) when id′ ≡ id → k arg
       ∣ _ → raise Equeue.Reject);
     raise Equeue.Terminate 
   else
     k (Queue.take f.q)

let put_fifo f v =
   Queue.add v f.q;
   match f.w with
   ∣ Some id → Equeue.add_event esys (Read(id, Queue.take f.q)); f.w ← None
   ∣ None → ()

Previous Up