From 7a340922dac31e64dc21daaff64803914481381a Mon Sep 17 00:00:00 2001 From: KC Sivaramakrishnan Date: Sun, 1 Oct 2023 17:04:03 +0530 Subject: [PATCH 1/3] Update to OCaml 5.1 in ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8c6cf63..b43c12f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,7 @@ jobs: - ubuntu-latest - macos-latest ocaml-compiler: - - ocaml-base-compiler.5.0.0~alpha1 + - ocaml-base-compiler.5.1.0 runs-on: ${{ matrix.os }} From 578812c7a3cd7c31b69a29aefd82664e4121ac4f Mon Sep 17 00:00:00 2001 From: KC Sivaramakrishnan Date: Sun, 1 Oct 2023 17:52:14 +0530 Subject: [PATCH 2/3] Update ci.yml --- .github/workflows/ci.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b43c12f..05b2aa2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,7 +29,6 @@ jobs: ocaml-compiler: ${{ matrix.ocaml-compiler }} opam-repositories: | default: https://github.com/ocaml/opam-repository.git - alpha: git+https://github.com/kit-ty-kate/opam-alpha-repository opam-depext: false - run: opam install . --deps-only --with-test From a29824035c30f00b683db93802477b8debd3da5d Mon Sep 17 00:00:00 2001 From: Sudha Parimala Date: Tue, 10 Oct 2023 17:14:38 +0530 Subject: [PATCH 3/3] ocamlformat source files --- .ocamlformat | 2 + aio/aio.ml | 247 ++++++++++---------- aio/aio.mli | 9 +- aio/echo.ml | 43 ++-- algorithmic_differentiation.ml | 90 ++++---- callbacks/bar.ml | 21 +- callbacks/dune | 20 +- concurrent.ml | 35 ++- dune | 4 +- dyn_wind.ml | 47 ++-- eratosthenes.ml | 195 ++++++++-------- fringe.ml | 72 +++--- generator.ml | 103 +++++---- loop.ml | 17 +- multishot/clone_is_tricky.ml | 34 ++- multishot/delimcc.ml | 136 ++++++----- multishot/delimcc_paper_example.ml | 299 +++++++++++------------- multishot/memo.ml | 57 ++--- multishot/nim.ml | 354 ++++++++++++++++------------- multishot/nondeterminism.ml | 167 ++++++++------ multishot/queens.ml | 85 ++++--- mvar/MVar.ml | 35 ++- mvar/MVar.mli | 20 +- mvar/MVar_monad.ml | 55 +++-- mvar/MVar_monad.mli | 1 + mvar/MVar_test.ml | 6 +- mvar/chameneos.ml | 94 ++++---- mvar/chameneos_lwt.ml | 112 ++++----- mvar/chameneos_monad.ml | 105 ++++----- mvar/chameneos_systhr.ml | 146 ++++++------ mvar/concurrent_monad.ml | 35 ++- mvar/dune | 11 +- mvar/sched.ml | 61 +++-- mvar/sched.mli | 20 +- mvar/sched_monad.ml | 67 +++--- mvar/sched_monad.mli | 19 +- pipes.ml | 113 ++++----- promises.ml | 160 +++++++------ ref.ml | 254 +++++++++++---------- reify_reflect.ml | 72 +++--- sched.ml | 38 ++-- sched.mli | 5 +- state.ml | 180 ++++++++------- transaction.ml | 73 +++--- 44 files changed, 1983 insertions(+), 1736 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..0b240ee --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,2 @@ +profile = default +version = 0.26.0 \ No newline at end of file diff --git a/aio/aio.ml b/aio/aio.ml index 34a803b..94740c3 100644 --- a/aio/aio.ml +++ b/aio/aio.ml @@ -11,45 +11,34 @@ open Effect.Deep type file_descr = Unix.file_descr type sockaddr = Unix.sockaddr type msg_flag = Unix.msg_flag - -type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t +type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t type _ Effect.t += Yield : unit Effect.t type _ Effect.t += Accept : file_descr -> (file_descr * sockaddr) Effect.t -type _ Effect.t += Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t -type _ Effect.t += Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t -type _ Effect.t += Sleep : float -> unit Effect.t - -let fork f = - perform (Fork f) - -let yield () = - perform Yield -let accept fd = - perform (Accept fd) +type _ Effect.t += + | Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t -let recv fd buf pos len mode = - perform (Recv (fd, buf, pos, len, mode)) +type _ Effect.t += + | Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t -let send fd bus pos len mode = - perform (Send (fd, bus, pos, len, mode)) +type _ Effect.t += Sleep : float -> unit Effect.t -let sleep timeout = - perform (Sleep timeout) +let fork f = perform (Fork f) +let yield () = perform Yield +let accept fd = perform (Accept fd) +let recv fd buf pos len mode = perform (Recv (fd, buf, pos, len, mode)) +let send fd bus pos len mode = perform (Send (fd, bus, pos, len, mode)) +let sleep timeout = perform (Sleep timeout) (** Poll to see if the file descriptor is available to read. *) let poll_rd fd = - let r,_,_ = Unix.select [fd] [] [] 0. in - match r with - | [] -> false - | _ -> true + let r, _, _ = Unix.select [ fd ] [] [] 0. in + match r with [] -> false | _ -> true (** Poll to see if the file descriptor is available to write. *) let poll_wr fd = - let _,r,_ = Unix.select [] [fd] [] 0. in - match r with - | [] -> false - | _ -> true + let _, r, _ = Unix.select [] [ fd ] [] 0. in + match r with [] -> false | _ -> true type read = | Accept of (file_descr * sockaddr, unit) continuation @@ -58,56 +47,52 @@ type read = type write = | Send of bytes * int * int * msg_flag list * (int, unit) continuation -type timeout = - | Sleep of (unit, unit) continuation +type timeout = Sleep of (unit, unit) continuation type runnable = | Thread : ('a, unit) continuation * 'a -> runnable | Read : file_descr * read -> runnable | Write : file_descr * write -> runnable -type state = - { run_q : runnable Queue.t; - read_ht : (file_descr, read) Hashtbl.t; - write_ht : (file_descr, write) Hashtbl.t; - sleep_ht : (float, timeout) Hashtbl.t; } +type state = { + run_q : runnable Queue.t; + read_ht : (file_descr, read) Hashtbl.t; + write_ht : (file_descr, write) Hashtbl.t; + sleep_ht : (float, timeout) Hashtbl.t; +} let init () = - { run_q = Queue.create (); + { + run_q = Queue.create (); read_ht = Hashtbl.create 13; write_ht = Hashtbl.create 13; - sleep_ht = Hashtbl.create 13; } - -let enqueue_thread st k x = - Queue.push (Thread(k, x)) st.run_q - -let enqueue_read st fd op = - Queue.push (Read(fd, op)) st.run_q + sleep_ht = Hashtbl.create 13; + } -let enqueue_write st fd op = - Queue.push (Write(fd, op)) st.run_q +let enqueue_thread st k x = Queue.push (Thread (k, x)) st.run_q +let enqueue_read st fd op = Queue.push (Read (fd, op)) st.run_q +let enqueue_write st fd op = Queue.push (Write (fd, op)) st.run_q let dequeue st = match Queue.pop st.run_q with - | Thread(k, x) -> continue k x - | Read(fd, Accept k) -> - let res = Unix.accept fd in - continue k res - | Read(fd, Recv(buf, pos, len, mode, k)) -> - let res = Unix.recv fd buf pos len mode in - continue k res - | Write(fd, Send(buf, pos, len, mode, k)) -> - let res = Unix.send fd buf pos len mode in - continue k res - -let block_accept st fd k = - Hashtbl.add st.read_ht fd (Accept k) + | Thread (k, x) -> continue k x + | Read (fd, Accept k) -> + let res = Unix.accept fd in + continue k res + | Read (fd, Recv (buf, pos, len, mode, k)) -> + let res = Unix.recv fd buf pos len mode in + continue k res + | Write (fd, Send (buf, pos, len, mode, k)) -> + let res = Unix.send fd buf pos len mode in + continue k res + +let block_accept st fd k = Hashtbl.add st.read_ht fd (Accept k) let block_recv st fd buf pos len mode k = - Hashtbl.add st.read_ht fd (Recv(buf, pos, len, mode, k)) + Hashtbl.add st.read_ht fd (Recv (buf, pos, len, mode, k)) let block_send st fd buf pos len mode k = - Hashtbl.add st.write_ht fd (Send(buf, pos, len, mode, k)) + Hashtbl.add st.write_ht fd (Send (buf, pos, len, mode, k)) let block_sleep st span k = let time = Unix.gettimeofday () +. span in @@ -119,13 +104,13 @@ let block_sleep st span k = * needs to wake up, and [b] is true if some thread is woken up. *) let wakeup st now : bool * float = - let (l,w,n) = + let l, w, n = Hashtbl.fold (fun t (Sleep k) (l, w, next) -> - if t <= now then - (enqueue_thread st k (); (t::l, true, next)) - else if t < next then - (l, w, t) + if t <= now then ( + enqueue_thread st k (); + (t :: l, true, next)) + else if t < next then (l, w, t) else (l, w, next)) st.sleep_ht ([], false, max_float) in @@ -133,31 +118,32 @@ let wakeup st now : bool * float = (w, n) let rec schedule st = - if Queue.is_empty st.run_q then (* No runnable threads *) - if Hashtbl.length st.read_ht = 0 && - Hashtbl.length st.write_ht = 0 && - Hashtbl.length st.sleep_ht = 0 then () (* We are done. *) + if Queue.is_empty st.run_q then + (* No runnable threads *) + if + Hashtbl.length st.read_ht = 0 + && Hashtbl.length st.write_ht = 0 + && Hashtbl.length st.sleep_ht = 0 + then () (* We are done. *) else let now = Unix.gettimeofday () in - let (thrd_has_woken_up, next_wakeup_time) = wakeup st now in - if thrd_has_woken_up then - schedule st - else if next_wakeup_time = max_float then - perform_io st (-1.) + let thrd_has_woken_up, next_wakeup_time = wakeup st now in + if thrd_has_woken_up then schedule st + else if next_wakeup_time = max_float then perform_io st (-1.) else perform_io st (next_wakeup_time -. now) else (* Still have runnable threads *) dequeue st and perform_io st timeout = - let rd_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) st.read_ht [] in - let wr_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) st.write_ht [] in + let rd_fds = Hashtbl.fold (fun fd _ acc -> fd :: acc) st.read_ht [] in + let wr_fds = Hashtbl.fold (fun fd _ acc -> fd :: acc) st.write_ht [] in let rdy_rd_fds, rdy_wr_fds, _ = Unix.select rd_fds wr_fds [] timeout in let rec resume ht enqueue = function - | [] -> () - | x::xs -> - enqueue st x (Hashtbl.find ht x); - Hashtbl.remove ht x; - resume ht enqueue xs + | [] -> () + | x :: xs -> + enqueue st x (Hashtbl.find ht x); + Hashtbl.remove ht x; + resume ht enqueue xs in resume st.read_ht enqueue_read rdy_rd_fds; resume st.write_ht enqueue_write rdy_wr_fds; @@ -167,50 +153,61 @@ and perform_io st timeout = let run main = let st = init () in let rec fork st f = - match_with f () { - retc = (fun () -> schedule st); - exnc = (fun exn -> - print_string (Printexc.to_string exn); - schedule st); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield -> Some (fun (k : (a, _) continuation) -> - enqueue_thread st k (); - schedule st) - | Fork f -> Some (fun k -> - enqueue_thread st k (); - fork st f) - | Accept fd -> Some (fun k -> - if poll_rd fd then begin - let res = Unix.accept fd in - continue k res - end else begin - block_accept st fd k; - schedule st - end) - | Recv (fd, buf, pos, len, mode) -> Some (fun k -> - if poll_rd fd then begin - let res = Unix.recv fd buf pos len mode in - continue k res - end else begin - block_recv st fd buf pos len mode k; - schedule st - end) - | Send (fd, buf, pos, len, mode) -> Some (fun k -> - if poll_wr fd then begin - let res = Unix.send fd buf pos len mode in - continue k res - end else begin - block_send st fd buf pos len mode k; - schedule st - end) - | Sleep t -> Some (fun k -> - if t <= 0. then continue k () - else begin - block_sleep st t k; - schedule st - end) - | _ -> None - } + match_with f () + { + retc = (fun () -> schedule st); + exnc = + (fun exn -> + print_string (Printexc.to_string exn); + schedule st); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield -> + Some + (fun (k : (a, _) continuation) -> + enqueue_thread st k (); + schedule st) + | Fork f -> + Some + (fun k -> + enqueue_thread st k (); + fork st f) + | Accept fd -> + Some + (fun k -> + if poll_rd fd then + let res = Unix.accept fd in + continue k res + else ( + block_accept st fd k; + schedule st)) + | Recv (fd, buf, pos, len, mode) -> + Some + (fun k -> + if poll_rd fd then + let res = Unix.recv fd buf pos len mode in + continue k res + else ( + block_recv st fd buf pos len mode k; + schedule st)) + | Send (fd, buf, pos, len, mode) -> + Some + (fun k -> + if poll_wr fd then + let res = Unix.send fd buf pos len mode in + continue k res + else ( + block_send st fd buf pos len mode k; + schedule st)) + | Sleep t -> + Some + (fun k -> + if t <= 0. then continue k () + else ( + block_sleep st t k; + schedule st)) + | _ -> None); + } in fork st main diff --git a/aio/aio.mli b/aio/aio.mli index 6e09833..ca972a1 100644 --- a/aio/aio.mli +++ b/aio/aio.mli @@ -6,7 +6,7 @@ * transparent to the programmer. *) -val fork : (unit -> unit) -> unit +val fork : (unit -> unit) -> unit val yield : unit -> unit type file_descr = Unix.file_descr @@ -14,8 +14,7 @@ type sockaddr = Unix.sockaddr type msg_flag = Unix.msg_flag val accept : file_descr -> file_descr * sockaddr -val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int -val send : file_descr -> bytes -> int -> int -> msg_flag list -> int -val sleep : float -> unit - +val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int +val send : file_descr -> bytes -> int -> int -> msg_flag list -> int +val sleep : float -> unit val run : (unit -> unit) -> unit diff --git a/aio/echo.ml b/aio/echo.ml index 0d2756d..ce48031 100644 --- a/aio/echo.ml +++ b/aio/echo.ml @@ -28,49 +28,45 @@ let send sock str = let len = Bytes.length str in let total = ref 0 in (try - while !total < len do - let write_count = Aio.send sock str !total (len - !total) [] in - total := write_count + !total - done - with _ -> () - ); + while !total < len do + let write_count = Aio.send sock str !total (len - !total) [] in + total := write_count + !total + done + with _ -> ()); !total let recv sock maxlen = let str = Bytes.create maxlen in - let recvlen = - try Aio.recv sock str 0 maxlen [] - with _ -> 0 - in - Bytes.sub str 0 recvlen + let recvlen = try Aio.recv sock str 0 maxlen [] with _ -> 0 in + Bytes.sub str 0 recvlen let close sock = try Unix.shutdown sock Unix.SHUTDOWN_ALL - with _ -> () ; - Unix.close sock + with _ -> + (); + Unix.close sock let string_of_sockaddr = function | Unix.ADDR_UNIX s -> s - | Unix.ADDR_INET (inet,port) -> + | Unix.ADDR_INET (inet, port) -> Unix.string_of_inet_addr inet ^ ":" ^ string_of_int port (* Repeat what the client says until the client goes away. *) let rec echo_server sock addr = try let data = recv sock 1024 in - if Bytes.length data > 0 then - (ignore (send sock data); - echo_server sock addr) + if Bytes.length data > 0 then ( + ignore (send sock data); + echo_server sock addr) else let cn = string_of_sockaddr addr in - (printf "echo_server : client (%s) disconnected.\n%!" cn; - close sock) - with - | _ -> close sock + printf "echo_server : client (%s) disconnected.\n%!" cn; + close sock + with _ -> close sock let server () = (* Server listens on localhost at 9301 *) - let addr, port = Unix.inet_addr_loopback, 9301 in + let addr, port = (Unix.inet_addr_loopback, 9301) in printf "Echo server listening on 127.0.0.1:%d\n%!" port; let saddr = Unix.ADDR_INET (addr, port) in let ssock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in @@ -89,7 +85,6 @@ let server () = Unix.set_nonblock client_sock; Aio.fork (fun () -> echo_server client_sock client_addr) done - with - | _ -> close ssock + with _ -> close ssock let () = Aio.run server diff --git a/algorithmic_differentiation.ml b/algorithmic_differentiation.ml index 1a71d94..627f240 100644 --- a/algorithmic_differentiation.ml +++ b/algorithmic_differentiation.ml @@ -6,39 +6,50 @@ open Effect.Deep module F : sig type t + val mk : float -> t - val (+.) : t -> t -> t + val ( +. ) : t -> t -> t val ( *. ) : t -> t -> t - val grad : (t -> t) -> float -> float + val grad : (t -> t) -> float -> float val grad2 : (t * t -> t) -> float * float -> float * float end = struct type t = { v : float; mutable d : float } - let mk v = {v; d = 0.0} + let mk v = { v; d = 0.0 } type _ Effect.t += Add : t * t -> t Effect.t type _ Effect.t += Mult : t * t -> t Effect.t let run f = - ignore (match_with f () { - retc = (fun r -> r.d <- 1.0; r); - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | Add (a, b) -> Some (fun (k : (a, _) continuation) -> - let x = {v = a.v +. b.v; d = 0.0} in - ignore (continue k x); - a.d <- a.d +. x.d; - b.d <- b.d +. x.d; - x) - | Mult(a,b) -> Some (fun k -> - let x = {v = a.v *. b.v; d = 0.0} in - ignore (continue k x); - a.d <- a.d +. (b.v *. x.d); - b.d <- b.d +. (a.v *. x.d); - x) - | _ -> None - }) + ignore + (match_with f () + { + retc = + (fun r -> + r.d <- 1.0; + r); + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Add (a, b) -> + Some + (fun (k : (a, _) continuation) -> + let x = { v = a.v +. b.v; d = 0.0 } in + ignore (continue k x); + a.d <- a.d +. x.d; + b.d <- b.d +. x.d; + x) + | Mult (a, b) -> + Some + (fun k -> + let x = { v = a.v *. b.v; d = 0.0 } in + ignore (continue k x); + a.d <- a.d +. (b.v *. x.d); + b.d <- b.d +. (a.v *. x.d); + x) + | _ -> None); + }) let grad f x = let x = mk x in @@ -46,29 +57,32 @@ end = struct x.d let grad2 f (x, y) = - let x,y = mk x, mk y in - run (fun () -> f (x,y)); - x.d, y.d + let x, y = (mk x, mk y) in + run (fun () -> f (x, y)); + (x.d, y.d) - let (+.) a b = perform (Add(a,b)) - let ( *. ) a b = perform (Mult(a,b)) -end;; + let ( +. ) a b = perform (Add (a, b)) + let ( *. ) a b = perform (Mult (a, b)) +end +;; (* f = x + x^3 => df/dx = 1 + 3 * x^2 *) for x = 0 to 10 do let x = float_of_int x in - assert (F.(grad (fun x -> x +. x *. x *. x) x) = - 1.0 +. 3.0 *. x *. x) -done;; + assert (F.(grad (fun x -> x +. (x *. x *. x)) x) = 1.0 +. (3.0 *. x *. x)) +done +;; (* f = x^2 + x^3 => df/dx = 2*x + 3 * x^2 *) for x = 0 to 10 do let x = float_of_int x in - assert (F.(grad (fun x -> x *. x +. x *. x *. x) x) = - 2.0 *. x +. 3.0 *. x *. x) -done;; + assert ( + F.(grad (fun x -> (x *. x) +. (x *. x *. x)) x) + = (2.0 *. x) +. (3.0 *. x *. x)) +done +;; (* f = x^2 * y^4 => df/dx = 2 * x * y^4 @@ -77,8 +91,8 @@ for x = 0 to 10 do for y = 0 to 10 do let x = float_of_int x in let y = float_of_int y in - assert (F.(grad2 (fun (x,y) -> x *. x *. y *. y *. y *. y) (x,y)) = - (2.0 *. x *. y *. y *. y *. y, - 4.0 *. x *. x *. y *. y *. y)) + assert ( + F.(grad2 (fun (x, y) -> x *. x *. y *. y *. y *. y) (x, y)) + = (2.0 *. x *. y *. y *. y *. y, 4.0 *. x *. x *. y *. y *. y)) done -done;; +done diff --git a/callbacks/bar.ml b/callbacks/bar.ml index efc36ae..077284d 100644 --- a/callbacks/bar.ml +++ b/callbacks/bar.ml @@ -43,12 +43,15 @@ let _ = caml_to_c (); printf "[Caml] Return from caml_to_c\n%!" in - try_with f () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | E -> Some (fun (k : (a, _) continuation) -> - printf "[Caml] Handle effect E. Continuing..\n%!"; - continue k ()) - | _ -> None - } - + try_with f () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | E -> + Some + (fun (k : (a, _) continuation) -> + printf "[Caml] Handle effect E. Continuing..\n%!"; + continue k ()) + | _ -> None); + } diff --git a/callbacks/dune b/callbacks/dune index 3cadaac..ec99b62 100644 --- a/callbacks/dune +++ b/callbacks/dune @@ -1,3 +1,17 @@ -(rule (target foo.o) (deps foo.c) (action (run ocamlc -ccopt -DSERIAL -c foo.c))) -(rule (target bar.cmi) (deps bar.mli) (action (run ocamlc -c bar.mli))) -(rule (target callback) (deps bar.ml foo.o) (action (run ocamlc -custom -o callback foo.o bar.ml -linkall))) +(rule + (target foo.o) + (deps foo.c) + (action + (run ocamlc -ccopt -DSERIAL -c foo.c))) + +(rule + (target bar.cmi) + (deps bar.mli) + (action + (run ocamlc -c bar.mli))) + +(rule + (target callback) + (deps bar.ml foo.o) + (action + (run ocamlc -custom -o callback foo.o bar.ml -linkall))) diff --git a/concurrent.ml b/concurrent.ml index 8b8e623..856ffba 100644 --- a/concurrent.ml +++ b/concurrent.ml @@ -1,31 +1,30 @@ (* Demonstrate the concurrent scheduler - ------------------------------------ - Spawn binary tree of tasks in depth-first order + ------------------------------------ + Spawn binary tree of tasks in depth-first order - ************ - Fiber tree - ************ - 0 - / \ - 1 2 - / \ / \ - 3 4 5 6 + ************ + Fiber tree + ************ + 0 + / \ + 1 2 + / \ / \ + 3 4 5 6 *) let log = Printf.printf let rec f id depth = log "Starting number %i\n%!" id; - if depth > 0 then begin - log "Forking number %i\n%!" (id * 2 + 1); - Sched.fork (fun () -> f (id * 2 + 1) (depth - 1)); - log "Forking number %i\n%!" (id * 2 + 2); - Sched.fork (fun () -> f (id * 2 + 2) (depth - 1)) - end else begin + if depth > 0 then ( + log "Forking number %i\n%!" ((id * 2) + 1); + Sched.fork (fun () -> f ((id * 2) + 1) (depth - 1)); + log "Forking number %i\n%!" ((id * 2) + 2); + Sched.fork (fun () -> f ((id * 2) + 2) (depth - 1))) + else ( log "Yielding in number %i\n%!" id; Sched.yield (); - log "Resumed number %i\n%!" id; - end; + log "Resumed number %i\n%!" id); log "Finishing number %i\n%!" id let () = Sched.run (fun () -> f 0 2) diff --git a/dune b/dune index 0a7f305..0a6526e 100644 --- a/dune +++ b/dune @@ -1,6 +1,7 @@ (env (dev - (flags (:standard -w -50 -w -32 -w -27)))) + (flags + (:standard -w -50 -w -32 -w -27)))) (executables (names concurrent) @@ -49,4 +50,3 @@ (executables (names algorithmic_differentiation) (modules algorithmic_differentiation)) - diff --git a/dyn_wind.ml b/dyn_wind.ml index 22df9f4..809ffe9 100644 --- a/dyn_wind.ml +++ b/dyn_wind.ml @@ -6,16 +6,22 @@ open Effect.Deep let dynamic_wind before_thunk thunk after_thunk = before_thunk (); let res = - match_with thunk () { - retc = Fun.id; - exnc = (fun e -> after_thunk (); raise e); - effc = fun (type a) (e : a Effect.t) -> - Some (fun (k : (a, _) continuation) -> - after_thunk (); - let res' = perform e in - before_thunk (); - continue k res') - } + match_with thunk () + { + retc = Fun.id; + exnc = + (fun e -> + after_thunk (); + raise e); + effc = + (fun (type a) (e : a Effect.t) -> + Some + (fun (k : (a, _) continuation) -> + after_thunk (); + let res' = perform e in + before_thunk (); + continue k res')); + } in after_thunk (); res @@ -26,12 +32,21 @@ let () = let bt () = Printf.printf "IN\n" in let at () = Printf.printf "OUT\n" in let foo () = - Printf.printf "peform E\n"; perform E; - Printf.printf "peform E\n"; perform E; + Printf.printf "peform E\n"; + perform E; + Printf.printf "peform E\n"; + perform E; Printf.printf "done\n" in try_with (dynamic_wind bt foo) at - { effc = fun (type a) (e : a Effect.t) -> - match e with - | E -> Some (fun (k : (a, _) continuation) -> Printf.printf "handled E\n"; continue k ()) - | _ -> None } + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | E -> + Some + (fun (k : (a, _) continuation) -> + Printf.printf "handled E\n"; + continue k ()) + | _ -> None); + } diff --git a/eratosthenes.ml b/eratosthenes.ml index e7c596c..82d7706 100644 --- a/eratosthenes.ml +++ b/eratosthenes.ml @@ -1,5 +1,6 @@ -(** Message-passing parallel prime number generation using Sieve of Eratosthenes **) open Effect +(** Message-passing parallel prime number generation using Sieve of Eratosthenes **) + open Effect.Deep (* A message is either a [Stop] signal or a [Candidate] prime number *) @@ -9,154 +10,168 @@ let string_of_msg = function | Stop -> "Stop" | Candidate i -> Printf.sprintf "%d" i -(** Process primitives **) type pid = int +(** Process primitives **) type _ Effect.t += Spawn : (pid -> unit) -> pid Effect.t + let spawn p = perform (Spawn p) type _ Effect.t += Yield : unit Effect.t + let yield () = perform Yield (** Communication primitives **) type _ Effect.t += Send : pid * message -> unit Effect.t + let send pid data = perform (Send (pid, data)); yield () type _ Effect.t += Recv : pid -> message option Effect.t + let rec recv pid = match perform (Recv pid) with | Some m -> m - | None -> yield (); recv pid - + | None -> + yield (); + recv pid (** A mailbox is indexed by process ids (PIDs), each process has its own message queue **) -module Mailbox = -struct - module Make (Ord : Map.OrderedType) = - struct - include Map.Make(Ord) +module Mailbox = struct + module Make (Ord : Map.OrderedType) = struct + include Map.Make (Ord) let empty = empty - - let lookup key mb = - try - Some (find key mb) - with - | Not_found -> None + let lookup key mb = try Some (find key mb) with Not_found -> None let pop key mb = - (match lookup key mb with - | Some msg_q -> - if Queue.is_empty msg_q then None - else Some (Queue.pop msg_q) - | None -> None) - , mb + ( (match lookup key mb with + | Some msg_q -> + if Queue.is_empty msg_q then None else Some (Queue.pop msg_q) + | None -> None), + mb ) let push key msg mb = match lookup key mb with | Some msg_q -> - Queue.push msg msg_q; - mb + Queue.push msg msg_q; + mb | None -> - let msg_q = Queue.create () in - Queue.push msg msg_q; - add key msg_q mb + let msg_q = Queue.create () in + Queue.push msg msg_q; + add key msg_q mb end end (** Communication handler **) let mailbox f = - let module Mailbox = Mailbox.Make(struct type t = pid let compare = compare end) in + let module Mailbox = Mailbox.Make (struct + type t = pid + + let compare = compare + end) in let mailbox = ref Mailbox.empty in let lookup pid = - let (msg, mb) = Mailbox.pop pid !mailbox in - mailbox := mb; msg + let msg, mb = Mailbox.pop pid !mailbox in + mailbox := mb; + msg in - try_with f () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | (Send (pid, msg)) -> Some (fun (k : (a, _) continuation) -> - mailbox := Mailbox.push pid msg !mailbox; - continue k ()) - | (Recv who) -> Some (fun k -> - let msg = lookup who in - continue k msg) - | _ -> None - } + try_with f () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Send (pid, msg) -> + Some + (fun (k : (a, _) continuation) -> + mailbox := Mailbox.push pid msg !mailbox; + continue k ()) + | Recv who -> + Some + (fun k -> + let msg = lookup who in + continue k msg) + | _ -> None); + } (** Process handler Slightly modified version of sched.ml **) let run main () = let run_q = Queue.create () in let enqueue k = Queue.push k run_q in - let dequeue () = - if Queue.is_empty run_q then () - else (Queue.pop run_q) () - in + let dequeue () = if Queue.is_empty run_q then () else (Queue.pop run_q) () in let pid = ref (-1) in let rec spawn f = pid := 1 + !pid; - match_with f !pid { - retc = (fun () -> dequeue ()); - exnc = (fun e -> raise e); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield -> Some (fun (k : (a, _) continuation) -> - enqueue (fun () -> continue k ()); dequeue ()) - | Spawn p -> Some (fun k -> - enqueue (fun () -> continue k !pid); spawn p) - | _ -> None - } + match_with f !pid + { + retc = (fun () -> dequeue ()); + exnc = (fun e -> raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield -> + Some + (fun (k : (a, _) continuation) -> + enqueue (fun () -> continue k ()); + dequeue ()) + | Spawn p -> + Some + (fun k -> + enqueue (fun () -> continue k !pid); + spawn p) + | _ -> None); + } in spawn main -let fromSome = function - | Some x -> x - | _ -> failwith "Attempt to unwrap None" +let fromSome = function Some x -> x | _ -> failwith "Attempt to unwrap None" (** The prime number generator **) let rec generator : pid -> unit = - fun _ -> - let n = - if Array.length Sys.argv > 1 - then int_of_string Sys.argv.(1) - else 101 - in - let first = spawn sieve in (* Spawn first sieve *) - Printf.printf "Primes in [2..%d]: " n; - for i = 2 to n do - send first (Candidate i); (* Send candidate prime to first sieve *) - done; - send first Stop; (* Stop the pipeline *) - Printf.printf "\n" + fun _ -> + let n = + if Array.length Sys.argv > 1 then int_of_string Sys.argv.(1) else 101 + in + let first = spawn sieve in + (* Spawn first sieve *) + Printf.printf "Primes in [2..%d]: " n; + for i = 2 to n do + send first (Candidate i) (* Send candidate prime to first sieve *) + done; + send first Stop; + (* Stop the pipeline *) + Printf.printf "\n" + and sieve : pid -> unit = - fun mypid -> - match recv mypid with - | Candidate myprime -> - let _ = Printf.printf "%d " myprime in - let succ = ref None in - let rec loop () = - let msg = recv mypid in - match msg with - | Candidate prime when (prime mod myprime) <> 0 -> + fun mypid -> + match recv mypid with + | Candidate myprime -> + let _ = Printf.printf "%d " myprime in + let succ = ref None in + let rec loop () = + let msg = recv mypid in + match msg with + | Candidate prime when prime mod myprime <> 0 -> let succ_pid = - if !succ = None then - let pid = spawn sieve in (* Create a successor process *) + if !succ = None then ( + let pid = spawn sieve in + (* Create a successor process *) succ := Some pid; - pid + pid) else fromSome !succ in - send succ_pid (Candidate prime); (* Send candidate prime to successor process *) + send succ_pid (Candidate prime); + (* Send candidate prime to successor process *) loop () - | Stop when !succ <> None -> + | Stop when !succ <> None -> send (fromSome !succ) Stop (* Forward stop command *) - | Stop -> () - | _ -> loop () - in - loop () - | _ -> () + | Stop -> () + | _ -> loop () + in + loop () + | _ -> () (* Run application *) let _ = mailbox (run generator) diff --git a/fringe.ml b/fringe.ml index bf925d6..c186ee6 100644 --- a/fringe.ml +++ b/fringe.ml @@ -12,48 +12,49 @@ open Effect.Deep module type EQUATABLE = sig type t + val equals : t -> t -> bool end (* Basic binary tree structure *) -type 'a tree = - | Leaf of 'a - | Node of 'a tree * 'a tree - -module SameFringe(E : EQUATABLE) = struct +type 'a tree = Leaf of 'a | Node of 'a tree * 'a tree +module SameFringe (E : EQUATABLE) = struct type nonrec tree = E.t tree (* Yielding control *) type _ Effect.t += Yield : E.t -> unit Effect.t + let yield e = perform (Yield e) (* The walk routine *) - let rec walk : tree -> unit = - function + let rec walk : tree -> unit = function | Leaf e -> yield e - | Node (l,r) -> walk l; walk r + | Node (l, r) -> + walk l; + walk r (* Reification of effects *) type resumption = (unit, step) continuation - and step = Done - | Yielded of E.t * resumption + and step = Done | Yielded of E.t * resumption (* Reifies `Yield' effects *) let step f = - match_with f () { - retc = (fun _ -> Done); - exnc = (fun e -> raise e); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield e -> Some (fun (k : (a, _) continuation) -> Yielded (e, k)) - | _ -> None - } + match_with f () + { + retc = (fun _ -> Done); + exnc = (fun e -> raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield e -> Some (fun (k : (a, _) continuation) -> Yielded (e, k)) + | _ -> None); + } (* The comparator "step walks" two given trees simultaneously *) let comparator ltree rtree = - let l = fun () -> step (fun () -> walk ltree) in - let r = fun () -> step (fun () -> walk rtree) in + let l () = step (fun () -> walk ltree) in + let r () = step (fun () -> walk rtree) in let rec stepper l r = (* There are three cases to consider: 1) Both walk routines are done in which case the trees must have @@ -65,40 +66,39 @@ module SameFringe(E : EQUATABLE) = struct b) the values differ which implies that the trees do not have the same fringe. 3) Either walk routine is done, while the other yielded, - which implies the one tree has a larger fringe than the other. *) - match l (), r () with + which implies the one tree has a larger fringe than the other. *) + match (l (), r ()) with | Done, Done -> true | Yielded (e, k), Yielded (e', k') -> - if E.equals e e' - then stepper (fun () -> continue k ()) (fun () -> continue k' ()) - else false + if E.equals e e' then + stepper (fun () -> continue k ()) (fun () -> continue k' ()) + else false | _, _ -> false in stepper l r - end (* Instantiate SameFringe to work over integers *) -module SameFringe_Int = - SameFringe(struct type t = int - let equals x y = (Stdlib.compare x y) = 0 - end) +module SameFringe_Int = SameFringe (struct + type t = int + + let equals x y = Stdlib.compare x y = 0 +end) (* Some examples *) let ex1 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) let ex2 = Node (Node (Leaf 1, Leaf 2), Leaf 3) let ex3 = Node (Node (Leaf 3, Leaf 2), Leaf 1) - let ex4 = Leaf 42 let ex5 = Leaf 41 let _ = let open SameFringe_Int in - let pairs = [ex1,ex2; ex2,ex1; ex1,ex3; ex3,ex2; ex4,ex4; ex5,ex4] in + let pairs = + [ (ex1, ex2); (ex2, ex1); (ex1, ex3); (ex3, ex2); (ex4, ex4); (ex5, ex4) ] + in List.iter (function - | true -> print_endline "same" - | false -> print_endline "different") - (List.map (fun (l,r) -> comparator l r) pairs); + | true -> print_endline "same" | false -> print_endline "different") + (List.map (fun (l, r) -> comparator l r) pairs); flush stdout - diff --git a/generator.ml b/generator.ml index 714ff24..eca6031 100644 --- a/generator.ml +++ b/generator.ml @@ -20,75 +20,85 @@ module type TREE = sig val to_iter : 'a t -> ('a -> unit) -> unit (** Iterator function. *) - val to_gen : 'a t -> (unit -> 'a option) + val to_gen : 'a t -> unit -> 'a option (** Generator function. [to_gen t] returns a generator function [g] for the tree that traverses the tree in depth-first fashion, returning [Some x] for each node when [g] is invoked. [g] returns [None] once the traversal is complete. *) - val to_gen_cps : 'a t -> (unit -> 'a option) + val to_gen_cps : 'a t -> unit -> 'a option (** CPS version of the generator function. *) end module Tree : TREE = struct - - type 'a t = - | Leaf - | Node of 'a t * 'a * 'a t + type 'a t = Leaf | Node of 'a t * 'a * 'a t let leaf = Leaf - - let node l x r = Node (l,x,r) + let node l x r = Node (l, x, r) let rec deep = function | 0 -> Leaf - | n -> let t = deep (n-1) in Node (t,n,t) + | n -> + let t = deep (n - 1) in + Node (t, n, t) let rec iter f = function | Leaf -> () - | Node (l, x, r) -> iter f l; f x; iter f r + | Node (l, x, r) -> + iter f l; + f x; + iter f r (* val to_iter : 'a t -> ('a -> unit) -> unit *) let to_iter t f = iter f t (* val to_gen : 'a t -> (unit -> 'a option) *) let to_gen (type a) (t : a t) = - let module M = struct + let module M = struct type _ Effect.t += Next : a -> unit Effect.t end in let open M in - let rec step = ref (fun () -> - try_with - (fun t -> iter (fun x -> perform (Next x)) t; None) - t - { effc = fun (type a) (e : a Effect.t) -> - match e with - | Next v -> - Some (fun (k : (a, _) continuation) -> - step := (fun () -> continue k ()); - Some v) - | _ -> None }) + let rec step = + ref (fun () -> + try_with + (fun t -> + iter (fun x -> perform (Next x)) t; + None) + t + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Next v -> + Some + (fun (k : (a, _) continuation) -> + (step := fun () -> continue k ()); + Some v) + | _ -> None); + }) in - fun () -> !step () + fun () -> !step () let to_gen_cps t = let next = ref t in let cont = ref Leaf in - let rec iter t k = match t with + let rec iter t k = + match t with | Leaf -> run k | Node (left, x, right) -> iter left (Node (k, x, right)) and run = function | Leaf -> None | Node (k, x, right) -> - next := right; - cont := k; - Some x - in fun () -> iter !next !cont + next := right; + cont := k; + Some x + in + fun () -> iter !next !cont end let get_mean_sd l = - let get_mean l = (List.fold_right (fun a v -> a +. v) l 0.) /. - (float_of_int @@ List.length l) + let get_mean l = + List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) in let mean = get_mean l in let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in @@ -96,42 +106,35 @@ let get_mean_sd l = let benchmark f n = let rec run acc = function - | 0 -> acc - | n -> let t1 = Sys.time () in - let () = f () in - let d = Sys.time () -. t1 in - run (d::acc) (n-1) + | 0 -> acc + | n -> + let t1 = Sys.time () in + let () = f () in + let d = Sys.time () -. t1 in + run (d :: acc) (n - 1) in let r = run [] n in get_mean_sd r (* Main follows *) -let n = - try - int_of_string (Sys.argv.(1)) - with - | _ -> 25 - +let n = try int_of_string Sys.argv.(1) with _ -> 25 let t = Tree.deep n - let iter_fun () = Tree.to_iter t (fun _ -> ()) -let (m,sd) = benchmark iter_fun 5 +let m, sd = benchmark iter_fun 5 let () = printf "Iter: mean = %f, sd = %f\n%!" m sd - -let rec consume_all f = - match f () with - | None -> () - | Some _ -> consume_all f +let rec consume_all f = match f () with None -> () | Some _ -> consume_all f let gen_cps_fun () = let f = Tree.to_gen_cps t in consume_all f -let (m,sd) = benchmark gen_cps_fun 5 + +let m, sd = benchmark gen_cps_fun 5 let () = printf "Gen_cps: mean = %f, sd = %f\n%!" m sd let gen_fun () = let f = Tree.to_gen t in consume_all f -let (m, sd) = benchmark gen_fun 5 + +let m, sd = benchmark gen_fun 5 let () = printf "Gen_eff: mean = %f, sd = %f\n%!" m sd diff --git a/loop.ml b/loop.ml index 17e78af..4e3fb4a 100644 --- a/loop.ml +++ b/loop.ml @@ -6,9 +6,14 @@ type _ Effect.t += Foo : (unit -> 'a) Effect.t let f () = perform Foo () let res : type a. a = - try_with f () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Foo -> Some (fun (k : (a, _) continuation) -> continue k (fun () -> perform Foo ())) - | _ -> None - } + try_with f () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Foo -> + Some + (fun (k : (a, _) continuation) -> + continue k (fun () -> perform Foo ())) + | _ -> None); + } diff --git a/multishot/clone_is_tricky.ml b/multishot/clone_is_tricky.ml index 05f8763..696bdce 100644 --- a/multishot/clone_is_tricky.ml +++ b/multishot/clone_is_tricky.ml @@ -10,16 +10,26 @@ type _ Effect.t += Bar : unit Effect.t let _ = let run () = - try_with perform Foo { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Foo -> Some (fun (k : (a, _) continuation) -> continue k (perform Bar)) (* This continuation is resumed twice *) - | _ -> None - } + try_with perform Foo + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Foo -> + Some (fun (k : (a, _) continuation) -> continue k (perform Bar)) + (* This continuation is resumed twice *) + | _ -> None); + } in - try_with run () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Bar -> Some (fun (k : (a, _) continuation) -> continue (Multicont.Deep.clone_continuation k) (); continue k ()) - | _ -> None - } + try_with run () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Bar -> + Some + (fun (k : (a, _) continuation) -> + continue (Multicont.Deep.clone_continuation k) (); + continue k ()) + | _ -> None); + } diff --git a/multishot/delimcc.ml b/multishot/delimcc.ml index 2176f1e..bf5abfd 100644 --- a/multishot/delimcc.ml +++ b/multishot/delimcc.ml @@ -4,76 +4,104 @@ open Effect open Effect.Deep module type S = sig - type 'a prompt - (* One-shot continuation. *) - type ('a,'b) subcont - - val new_prompt : unit -> 'a prompt - val push_prompt : 'a prompt -> (unit -> 'a) -> 'a - val take_subcont : 'b prompt -> (('a,'b) subcont -> 'b) -> 'a - val push_subcont : ('a,'b) subcont -> 'a -> 'b - - (* Assorted control operators *) - val reset : ('a prompt -> 'a) -> 'a - val shift : 'a prompt -> (('b -> 'a) -> 'a) -> 'b - val control : 'a prompt -> (('b -> 'a) -> 'a) -> 'b - val shift0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b - val control0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b - val abort : 'a prompt -> 'a -> 'b + type 'a prompt + + (* One-shot continuation. *) + type ('a, 'b) subcont + + val new_prompt : unit -> 'a prompt + val push_prompt : 'a prompt -> (unit -> 'a) -> 'a + val take_subcont : 'b prompt -> (('a, 'b) subcont -> 'b) -> 'a + val push_subcont : ('a, 'b) subcont -> 'a -> 'b + + (* Assorted control operators *) + val reset : ('a prompt -> 'a) -> 'a + val shift : 'a prompt -> (('b -> 'a) -> 'a) -> 'b + val control : 'a prompt -> (('b -> 'a) -> 'a) -> 'b + val shift0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b + val control0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b + val abort : 'a prompt -> 'a -> 'b end module M : S = struct - type ('a,'b) subcont = ('a,'b) continuation - - type 'a prompt = { - take : 'b. (('b, 'a) subcont -> 'a) -> 'b; - push : (unit -> 'a) -> 'a; - } - - let new_prompt (type a) () : a prompt = - let module M = struct type _ Effect.t += Prompt : (('b, a) subcont -> a) -> 'b Effect.t end in - let take f = perform (M.Prompt f) in - let push f = try_with f () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | M.Prompt f -> Some (fun k -> f k) - | _ -> None - } - in + type ('a, 'b) subcont = ('a, 'b) continuation + + type 'a prompt = { + take : 'b. (('b, 'a) subcont -> 'a) -> 'b; + push : (unit -> 'a) -> 'a; + } + + let new_prompt (type a) () : a prompt = + let module M = struct + type _ Effect.t += Prompt : (('b, a) subcont -> a) -> 'b Effect.t + end in + let take f = perform (M.Prompt f) in + let push f = + try_with f () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with M.Prompt f -> Some (fun k -> f k) | _ -> None); + } + in { take; push } - let push_prompt prompt = prompt.push - let take_subcont prompt = prompt.take - let push_subcont k v = - let k' = Multicont.Deep.clone_continuation k in - continue k' v + let push_prompt prompt = prompt.push + let take_subcont prompt = prompt.take + + let push_subcont k v = + let k' = Multicont.Deep.clone_continuation k in + continue k' v - (** For the details of the implementation of control and shift0, see + (** For the details of the implementation of control and shift0, see https://hackage.haskell.org/package/CC-delcont-0.2.1.0/docs/src/Control-Monad-CC.html *) - let reset e = let p = new_prompt () in push_prompt p (fun () -> e p) - let shift p f = take_subcont p (fun sk -> push_prompt p (fun () -> f (fun c -> push_prompt p (fun () -> push_subcont sk c)))) - let control p f = take_subcont p (fun sk -> push_prompt p (fun () -> f (fun c -> push_subcont sk c))) - let shift0 p f = take_subcont p (fun sk -> f (fun c -> push_prompt p (fun () -> push_subcont sk c))) - let control0 p f = take_subcont p (fun sk -> f (fun c -> push_subcont sk c)) - let abort p e = take_subcont p (fun _ -> e) + let reset e = + let p = new_prompt () in + push_prompt p (fun () -> e p) + + let shift p f = + take_subcont p (fun sk -> + push_prompt p (fun () -> + f (fun c -> push_prompt p (fun () -> push_subcont sk c)))) + + let control p f = + take_subcont p (fun sk -> + push_prompt p (fun () -> f (fun c -> push_subcont sk c))) + + let shift0 p f = + take_subcont p (fun sk -> + f (fun c -> push_prompt p (fun () -> push_subcont sk c))) + + let control0 p f = take_subcont p (fun sk -> f (fun c -> push_subcont sk c)) + let abort p e = take_subcont p (fun _ -> e) end -open M;; +open M let p = new_prompt ();; -assert ([] = push_prompt p (fun () -> 1::2::take_subcont p (fun _k -> [])));; -assert ([1;2] = push_prompt p (fun () -> 1::2::take_subcont p (fun k -> push_subcont k [])));; -assert (135 = +assert ([] = push_prompt p (fun () -> 1 :: 2 :: take_subcont p (fun _k -> []))) +;; + +assert ( + [ 1; 2 ] + = push_prompt p (fun () -> + 1 :: 2 :: take_subcont p (fun k -> push_subcont k []))) +;; + +assert ( + 135 + = let p1 = new_prompt () in let p2 = new_prompt () in let p3 = new_prompt () in let pushtwice sk = sk (fun () -> - sk (fun () -> - shift0 p2 (fun sk2 -> sk2 (fun () -> - sk2 (fun () -> 3))) ())) + sk (fun () -> + shift0 p2 (fun sk2 -> sk2 (fun () -> sk2 (fun () -> 3))) ())) in push_prompt p1 (fun () -> - push_prompt p2 (fun () -> - push_prompt p3 (fun () -> shift0 p1 pushtwice ()) + 10) + 1) + 100) + push_prompt p2 (fun () -> + push_prompt p3 (fun () -> shift0 p1 pushtwice ()) + 10) + + 1) + + 100) diff --git a/multishot/delimcc_paper_example.ml b/multishot/delimcc_paper_example.ml index 4897196..7ca5449 100644 --- a/multishot/delimcc_paper_example.ml +++ b/multishot/delimcc_paper_example.ml @@ -1,212 +1,185 @@ (* Example in the delimcc paper: * http://okmij.org/ftp/continuations/caml-shift-journal.pdf *) -open Delimcc.M;; +open Delimcc.M (* A finite map: a search tree *) -type ('k, 'v) tree = - | Empty - | Node of ('k, 'v) tree * 'k * 'v * ('k, 'v) tree -;; +type ('k, 'v) tree = Empty | Node of ('k, 'v) tree * 'k * 'v * ('k, 'v) tree exception NotFound -;; (* Update the value associated with the key k by applying the update function f. Return the new tree. If the key is not found, throw an exception. *) -let rec update1 : 'k -> ('v->'v) -> ('k,'v) tree -> ('k,'v) tree = - fun k f -> - let rec loop = function +let rec update1 : 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = + fun k f -> + let rec loop = function | Empty -> raise NotFound - | Node (l,k1,v1,r) -> - begin - match compare k k1 with - | 0 -> Node(l,k1,f v1,r) - | n when n < 0 -> Node(loop l,k1,v1,r) - | _ -> Node(l,k1,v1,loop r) - end - in loop -;; + | Node (l, k1, v1, r) -> ( + match compare k k1 with + | 0 -> Node (l, k1, f v1, r) + | n when n < 0 -> Node (loop l, k1, v1, r) + | _ -> Node (l, k1, v1, loop r)) + in + loop (* Add to the tree the association of the key k to the value v, overriding any existing association with the key k, if any. *) let rec insert k v = function - | Empty -> Node(Empty,k,v,Empty) - | Node(l,k1,v1,r) -> - begin - match compare k k1 with - | 0 -> Node(l,k1,v,r) - | n when n < 0 -> Node(insert k v l, k1,v1,r) - | _ -> Node(l,k1,v1,insert k v r) - end -;; + | Empty -> Node (Empty, k, v, Empty) + | Node (l, k1, v1, r) -> ( + match compare k k1 with + | 0 -> Node (l, k1, v, r) + | n when n < 0 -> Node (insert k v l, k1, v1, r) + | _ -> Node (l, k1, v1, insert k v r)) (* A re-balancing function; dummy for now *) -let rebalance : ('k,'v) tree -> ('k,'v) tree = - fun t -> - print_endline "Rebalancing"; t -;; +let rebalance : ('k, 'v) tree -> ('k, 'v) tree = + fun t -> + print_endline "Rebalancing"; + t (* Examples of using update1 *) let tree1 = - let n1 = Node(Empty,1,101,Empty) in - let n9 = Node(Empty,9,109,Empty) in - let n5 = Node(n1,5,105,Empty) in - let n7 = Node(n5,7,107,n9) in - n7;; - -let Node (Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 7, 107, - Node (Empty, 9, 109, Empty)) - = - try update1 1 succ tree1 - with NotFound -> insert 1 100 tree1 -;; - - -let - Node - (Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), - 7, 107, Node (Empty, 9, 109, Empty)) - = - try update1 0 succ tree1 - with NotFound -> insert 0 100 tree1 -;; - + let n1 = Node (Empty, 1, 101, Empty) in + let n9 = Node (Empty, 9, 109, Empty) in + let n5 = Node (n1, 5, 105, Empty) in + let n7 = Node (n5, 7, 107, n9) in + n7 + +let (Node + ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = + try update1 1 succ tree1 with NotFound -> insert 1 100 tree1 + +let (Node + ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = + try update1 0 succ tree1 with NotFound -> insert 0 100 tree1 (* The same as update1, but using Delimcc *) -let rec update2 : ('k,'v) tree option prompt -> - 'k -> ('v->'v) -> ('k,'v) tree -> ('k,'v) tree = - fun pnf k f -> - let rec loop = function +let rec update2 : + ('k, 'v) tree option prompt -> + 'k -> + ('v -> 'v) -> + ('k, 'v) tree -> + ('k, 'v) tree = + fun pnf k f -> + let rec loop = function | Empty -> abort pnf None - | Node (l,k1,v1,r) -> - begin - match compare k k1 with - | 0 -> Node(l,k1,f v1,r) - | n when n < 0 -> Node(loop l,k1,v1,r) - | _ -> Node(l,k1,v1,loop r) - end - in loop -;; - -let Node (Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 7, 107, - Node (Empty, 9, 109, Empty)) - = + | Node (l, k1, v1, r) -> ( + match compare k k1 with + | 0 -> Node (l, k1, f v1, r) + | n when n < 0 -> Node (loop l, k1, v1, r) + | _ -> Node (l, k1, v1, loop r)) + in + loop + +let (Node + ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = let pnf = new_prompt () in - match push_prompt pnf (fun () -> - Some (update2 pnf 1 succ tree1)) with + match push_prompt pnf (fun () -> Some (update2 pnf 1 succ tree1)) with | Some tree -> tree - | None -> insert 1 100 tree1 -;; - -let - Node - (Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), - 7, 107, Node (Empty, 9, 109, Empty)) - = + | None -> insert 1 100 tree1 + +let (Node + ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = let pnf = new_prompt () in - match push_prompt pnf (fun () -> - Some (update2 pnf 0 succ tree1)) with + match push_prompt pnf (fun () -> Some (update2 pnf 0 succ tree1)) with | Some tree -> tree - | None -> insert 0 100 tree1 -;; + | None -> insert 0 100 tree1 (* Resumable exceptions *) (* upd_handle is very problematic! *) -let upd_handle = fun k -> raise NotFound;; -let rec update3 : 'k -> ('v->'v) -> ('k,'v) tree -> ('k,'v) tree = - fun k f -> - let rec loop = function - | Empty -> Node(Empty,k,upd_handle k,Empty) - | Node (l,k1,v1,r) -> - begin - match compare k k1 with - | 0 -> Node(l,k1,f v1,r) - | n when n < 0 -> Node(loop l,k1,v1,r) - | _ -> Node(l,k1,v1,loop r) - end - in loop -;; - -let Node (Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 7, 107, - Node (Empty, 9, 109, Empty)) - = +let upd_handle k = raise NotFound + +let rec update3 : 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = + fun k f -> + let rec loop = function + | Empty -> Node (Empty, k, upd_handle k, Empty) + | Node (l, k1, v1, r) -> ( + match compare k k1 with + | 0 -> Node (l, k1, f v1, r) + | n when n < 0 -> Node (loop l, k1, v1, r) + | _ -> Node (l, k1, v1, loop r)) + in + loop + +let (Node + ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = update3 1 succ tree1 -;; (* Resumable exceptions *) -type ('k,'v) res = Done of ('k,'v) tree - | ReqNF of 'k * ('v,('k,'v) res) subcont -;; -let rec update4 : ('k,'v) res prompt -> - 'k -> ('v->'v) -> ('k,'v) tree -> ('k,'v) tree = - fun pnf k f -> - let rec loop = function - | Empty -> Node(Empty,k,take_subcont pnf (fun c -> ReqNF (k,c)),Empty) - | Node (l,k1,v1,r) -> - begin - match compare k k1 with - | 0 -> Node(l,k1,f v1,r) - | n when n < 0 -> Node(loop l,k1,v1,r) - | _ -> Node(l,k1,v1,loop r) - end - in loop -;; - - -let Node (Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 7, 107, - Node (Empty, 9, 109, Empty)) - = +type ('k, 'v) res = + | Done of ('k, 'v) tree + | ReqNF of 'k * ('v, ('k, 'v) res) subcont + +let rec update4 : + ('k, 'v) res prompt -> 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = + fun pnf k f -> + let rec loop = function + | Empty -> Node (Empty, k, take_subcont pnf (fun c -> ReqNF (k, c)), Empty) + | Node (l, k1, v1, r) -> ( + match compare k k1 with + | 0 -> Node (l, k1, f v1, r) + | n when n < 0 -> Node (loop l, k1, v1, r) + | _ -> Node (l, k1, v1, loop r)) + in + loop + +let (Node + ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = let pnf = new_prompt () in - match push_prompt pnf (fun () -> - Done (update4 pnf 1 succ tree1)) with - | Done tree -> tree - | ReqNF (k,c) -> - rebalance (match push_subcont c 100 with Done x -> x) -;; - -let - Node - (Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), - 7, 107, Node (Empty, 9, 109, Empty)) - = + match push_prompt pnf (fun () -> Done (update4 pnf 1 succ tree1)) with + | Done tree -> tree + | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) + +let (Node + ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), + 7, + 107, + Node (Empty, 9, 109, Empty) )) = let pnf = new_prompt () in - match push_prompt pnf (fun () -> - Done (update4 pnf 0 succ tree1)) with - | Done tree -> tree - | ReqNF (k,c) -> - rebalance (match push_subcont c 100 with Done x -> x) -;; -(* Rebalancing is printed *) - + match push_prompt pnf (fun () -> Done (update4 pnf 0 succ tree1)) with + | Done tree -> tree + | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) +(* Rebalancing is printed *) (* A custom value update function *) -exception TooBig;; +exception TooBig -let upd_fun n = if n > 5 then raise TooBig else succ n;; +let upd_fun n = if n > 5 then raise TooBig else succ n (* Several exceptions *) let Empty = - try - try update1 7 upd_fun tree1 - with NotFound -> insert 7 100 tree1 - with TooBig -> Empty -;; - + try try update1 7 upd_fun tree1 with NotFound -> insert 7 100 tree1 + with TooBig -> Empty let Empty = - try - let pnf = new_prompt () in - match push_prompt pnf (fun () -> - Done (update4 pnf 7 upd_fun tree1)) with - | Done tree -> tree - | ReqNF (k,c) -> - rebalance (match push_subcont c 100 with Done x -> x) - with TooBig -> Empty -;; + try + let pnf = new_prompt () in + match push_prompt pnf (fun () -> Done (update4 pnf 7 upd_fun tree1)) with + | Done tree -> tree + | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) + with TooBig -> Empty diff --git a/multishot/memo.ml b/multishot/memo.ml index 4491f28..0cc764e 100644 --- a/multishot/memo.ml +++ b/multishot/memo.ml @@ -9,8 +9,7 @@ open Effect.Deep *) module Memo : sig - - val memoize : ('a -> 'b) -> ('a -> 'b) + val memoize : ('a -> 'b) -> 'a -> 'b (** [memoize f] returns the memoized version of [f] that caches the * evaluation of [f] from the start of [f] to the last invocation of [cut ()] * in [f], with respect to some input [x] to the memoized function. @@ -26,39 +25,43 @@ module Memo : sig * multiple [cut()], the function is memoized until the last cut. Invoking a * memoized function without establishing a cut is an error. *) - end = struct - type _ Effect.t += Cut : unit Effect.t + let cut () = perform Cut - type ('a,'b) cache_entry = - {input : 'a; - mutable cont : unit -> 'b} + type ('a, 'b) cache_entry = { input : 'a; mutable cont : unit -> 'b } let memoize f = let cache = ref None in fun x -> try_with - (fun () -> match !cache with - | Some {input; cont} when x = input -> cont () - | _ -> - let err_msg = "Memoized function was not cut" in - cache := Some {input = x; cont = fun () -> failwith err_msg}; - f x) + (fun () -> + match !cache with + | Some { input; cont } when x = input -> cont () + | _ -> + let err_msg = "Memoized function was not cut" in + cache := Some { input = x; cont = (fun () -> failwith err_msg) }; + f x) () - { effc = fun (type a) (e : a Effect.t) -> - match e with - | Cut -> Some (fun (k : (a, _) continuation) -> - match !cache with - | Some c -> - let rec save_cont k () = - c.cont <- save_cont (Multicont.Deep.clone_continuation k); - continue k () - in - save_cont k () - | None -> failwith "impossible") - | _ -> None} + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Cut -> + Some + (fun (k : (a, _) continuation) -> + match !cache with + | Some c -> + let rec save_cont k () = + c.cont <- + save_cont (Multicont.Deep.clone_continuation k); + continue k () + in + save_cont k () + | None -> failwith "impossible") + | _ -> None); + } end let print_succ x = @@ -66,8 +69,8 @@ let print_succ x = (* ...... * expensive computation * .....*) - Memo.cut(); - Printf.printf "Succ of %d is %d\n" x (x+1) + Memo.cut (); + Printf.printf "Succ of %d is %d\n" x (x + 1) let memoized_print_succ = Memo.memoize print_succ diff --git a/multishot/nim.ml b/multishot/nim.ml index 0a48ddb..368134f 100644 --- a/multishot/nim.ml +++ b/multishot/nim.ml @@ -1,18 +1,18 @@ (* Nim game (https://en.wikipedia.org/wiki/Nim) - It was Nicolas Oury's original idea to use Nim to show case handlers. - c.f. https://github.com/slindley/effect-handlers/blob/master/Examples/Nim.hs + It was Nicolas Oury's original idea to use Nim to show case handlers. + c.f. https://github.com/slindley/effect-handlers/blob/master/Examples/Nim.hs - This particular implementation is adapted from Hillerström and Lindley. + This particular implementation is adapted from Hillerström and Lindley. - Mathematical game Nim + Mathematical game Nim - Rules: - - Two players: Alice and Bob; Alice always starts. - - One heap of N sticks. - - Turn-based, one move per turn. - - A player may pick between 1-3 sticks at each turn. - - The player, who takes the last stick, wins. - *) + Rules: + - Two players: Alice and Bob; Alice always starts. + - One heap of N sticks. + - Turn-based, one move per turn. + - A player may pick between 1-3 sticks at each turn. + - The player, who takes the last stick, wins. +*) open Effect open Effect.Deep @@ -20,39 +20,34 @@ open Effect.Deep type player = Alice | Bob (* String representation of players *) -let string_of_player = function - | Alice -> "Alice" - | Bob -> "Bob" +let string_of_player = function Alice -> "Alice" | Bob -> "Bob" (* The [move] operation is centric to the game. The operation is -parameterised by the active player and the number of sticks left in -the game. *) + parameterised by the active player and the number of sticks left in + the game. *) type _ Effect.t += Move : (player * int) -> int Effect.t + let move p n = perform (Move (p, n)) (* The game is modelled as two mutually recursive functions *) -let rec alice_turn n = - if n == 0 - then Bob - else bob_turn (n - (move Alice n)) -and bob_turn n = - if n == 0 - then Alice - else alice_turn (n - (move Bob n)) +let rec alice_turn n = if n == 0 then Bob else bob_turn (n - move Alice n) +and bob_turn n = if n == 0 then Alice else alice_turn (n - move Bob n) (* Auxiliary function to start a game with [n] sticks. *) -let game n = - fun () -> alice_turn n +let game n () = alice_turn n -(** Encoding player strategies **) (* The strategy handler assigns strategy s(p) to player [p] *) -let strategy (s : player -> (int -> (int, player) continuation -> player)) m = - try_with - m () - { effc = fun (type a) (e : a Effect.t) -> - match e with - | Move (p, n) -> Some (fun (k : (a, player) continuation) -> s p n k) - | _ -> None } + +(** Encoding player strategies **) +let strategy (s : player -> int -> (int, player) continuation -> player) m = + try_with m () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Move (p, n) -> Some (fun (k : (a, player) continuation) -> s p n k) + | _ -> None); + } (* Simple (and naive) strategy *) let ns _ k = continue k 1 @@ -62,17 +57,16 @@ let ps n k = continue k (max 1 (n mod 4)) (* Brute force strategy *) (* The auxiliary function [valid_moves] computes the set of legal -moves when there are [n] sticks left in the game. *) -let valid_moves n = - List.filter (fun m -> m <= n) [1;2;3] + moves when there are [n] sticks left in the game. *) +let valid_moves n = List.filter (fun m -> m <= n) [ 1; 2; 3 ] (* The function [elem_index] returns Some index of the first element -satisfying the predicate [p]. *) + satisfying the predicate [p]. *) let elem_index p xs = let rec elem_index' i = function | x :: xs when p x -> Some i - | x :: xs -> elem_index' (i+1) xs - | [] -> None + | x :: xs -> elem_index' (i + 1) xs + | [] -> None in elem_index' 0 xs @@ -81,170 +75,198 @@ let nonlinear_continue k = continue (Multicont.Deep.clone_continuation k) (* This function maps a continuation [k] over a list *) let rec mapk k = function - | x :: xs -> (nonlinear_continue k x) :: mapk k xs - | [] -> [] + | x :: xs -> nonlinear_continue k x :: mapk k xs + | [] -> [] (* Finally, we can define the brute force strategy. In contrast to -[ns] and [ps] it takes an additional parameter [p] which is the player -for whom we are attempting to brute force a winning strategy. *) + [ns] and [ps] it takes an additional parameter [p] which is the player + for whom we are attempting to brute force a winning strategy. *) let bf p n k = let winners = mapk k (valid_moves n) in match elem_index (fun w -> w == p) winners with - | None -> continue k 1 (* Not among the winners *) - | Some i -> continue k (i+1) (* Among the winners, play the winning strategy (indices are zero-based) *) + | None -> continue k 1 (* Not among the winners *) + | Some i -> continue k (i + 1) +(* Among the winners, play the winning strategy (indices are zero-based) *) (* Some example strategy handlers *) -let naive = strategy (fun _ -> ns) +let naive = strategy (fun _ -> ns) let perfect = strategy (fun _ -> ps) -let bruteforce_bob = strategy (function | Alice -> ps - | Bob -> bf Bob) +let bruteforce_bob = strategy (function Alice -> ps | Bob -> bf Bob) (** Computing game data **) (* The strategy handlers produce a single piece of data about games, -namely, the winner of a particular game. We can generalise this idea -to compute the game tree of a game. *) + namely, the winner of a particular game. We can generalise this idea + to compute the game tree of a game. *) -type gametree = Winner of player - | Take of player * (int * gametree) list +type gametree = Winner of player | Take of player * (int * gametree) list (* String representation of a gametree *) -let rec string_of_gametree : gametree -> string = - function - | Winner p -> "Winner(" ^ (string_of_player p) ^ ")" - | Take (p, ts) -> "Take" ^ (string_of_pair string_of_player (string_of_list (string_of_pair string_of_int string_of_gametree)) (p, ts)) -and string_of_pair : 'a 'b. ('a -> string) -> ('b -> string) -> ('a * 'b) -> string = - fun string_of_x string_of_y (x,y) -> "(" ^ (string_of_x x) ^ ", " ^ (string_of_y y) ^ ")" -and string_of_list string_of_x xs = "[" ^ (String.concat "; " (List.map string_of_x xs)) ^ "]" - +let rec string_of_gametree : gametree -> string = function + | Winner p -> "Winner(" ^ string_of_player p ^ ")" + | Take (p, ts) -> + "Take" + ^ string_of_pair string_of_player + (string_of_list (string_of_pair string_of_int string_of_gametree)) + (p, ts) + +and string_of_pair : + 'a 'b. ('a -> string) -> ('b -> string) -> 'a * 'b -> string = + fun string_of_x string_of_y (x, y) -> + "(" ^ string_of_x x ^ ", " ^ string_of_y y ^ ")" + +and string_of_list string_of_x xs = + "[" ^ String.concat "; " (List.map string_of_x xs) ^ "]" (* A zip that zips until either list has been exhausted. *) let rec zip xs ys = - match xs, ys with + match (xs, ys) with | [], _ -> [] | _, [] -> [] - | (x :: xs), (y :: ys) -> (x, y) :: (zip xs ys) + | x :: xs, y :: ys -> (x, y) :: zip xs ys (* This function reifies a move as a node in the game tree *) let reify p n k = let subgames = mapk k (valid_moves n) in - let subtrees = zip [1;2;3] subgames in + let subtrees = zip [ 1; 2; 3 ] subgames in Take (p, subtrees) let gametree m = - match_with m () { - retc = (fun v -> Winner v); - exnc = (fun e -> raise e); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Move (p, n) -> Some (fun (k : (a, _) continuation) -> reify p n k) - | _ -> None - } + match_with m () + { + retc = (fun v -> Winner v); + exnc = (fun e -> raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Move (p, n) -> Some (fun (k : (a, _) continuation) -> reify p n k) + | _ -> None); + } -(** Cheat detection via effect forwarding **) (* We model Cheat as an exception parameterised by the player (the -cheater) and the number of sticks the player took *) + cheater) and the number of sticks the player took *) exception Cheat of player * int +(** Cheat detection via effect forwarding **) + let cheat p n = raise (Cheat (p, n)) (* A simple cheating strategy is to take all sticks, thereby winning in a single move *) let cs n k = continue k n - -let bob_cheats = strategy (function | Alice -> ps - | Bob -> cs) +let bob_cheats = strategy (function Alice -> ps | Bob -> cs) (* The cheat detection mechanism *) let check_move p n k = let m = move p n in - if m < 1 || 3 < m - then cheat p m (* player p cheats by making an illegal move m (m < 1 or 3 < m) *) + if m < 1 || 3 < m then + cheat p m (* player p cheats by making an illegal move m (m < 1 or 3 < m) *) else continue k m let checker m = - try_with m () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Move (p, n) -> Some (fun (k : (a, _) continuation) -> check_move p n k) - | _ -> None - } + try_with m () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Move (p, n) -> + Some (fun (k : (a, _) continuation) -> check_move p n k) + | _ -> None); + } (* The following exception handler reports cheaters *) let cheat_report m = - try m () with - | Cheat (p, n) -> failwith ("Cheater: " ^ (string_of_player p) ^ " took " ^ (string_of_int n) ^ " sticks!") + try m () + with Cheat (p, n) -> + failwith + ("Cheater: " ^ string_of_player p ^ " took " ^ string_of_int n + ^ " sticks!") (* Another way to deal with cheaters is to disqualify them *) let cheat_lose m = - try m () with - | Cheat (Alice, _) -> Bob - | Cheat (Bob, _) -> Alice + try m () with Cheat (Alice, _) -> Bob | Cheat (Bob, _) -> Alice (* The pipeline operator combines two handlers [h] and [g]. Data flows from [g] to [h]. *) -let (-<-) h g = fun m -> h (fun () -> g m) +let ( -<- ) h g m = h (fun () -> g m) (** Choosing between strategies **) type _ Effect.t += Choose : bool Effect.t + let choose () = perform Choose (* Flip a coin to decide whether to interpret Choose as true or -false *) + false *) let coin m = - try_with m () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Choose -> Some (fun (k : (a, _) continuation) -> continue k (Random.float 1.0 > 0.5)) - | _ -> None - } + try_with m () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Choose -> + Some + (fun (k : (a, _) continuation) -> + continue k (Random.float 1.0 > 0.5)) + | _ -> None); + } let bob_maybe_cheats m = - let h = if choose () - then strategy (fun _ -> ps) - else strategy (function - | Alice -> ps - | Bob -> cs) - in h m + let h = + if choose () then strategy (fun _ -> ps) + else strategy (function Alice -> ps | Bob -> cs) + in + h m -(** Stateful scoreboard **) (* The state effect is given by two operations 1) get to retrieve the current state, 2) and put to update the state *) (* State module is copied from KC's state example *) + +(** Stateful scoreboard **) module type STATE = sig type t + val put : t -> unit val get : unit -> t val run : (unit -> 'a) -> init:t -> 'a end (* From: https://gist.github.com/kayceesrk/3c307d0340fbfc68435d4769ad447e10 *) -module State (S : sig type t end) : STATE with type t = S.t = struct +module State (S : sig + type t +end) : STATE with type t = S.t = struct type t = S.t - type _ Effect.t += Put : t -> unit Effect.t + let put v = perform (Put v) type _ Effect.t += Get : t Effect.t + let get () = perform Get let run (type a) (f : unit -> a) ~init : a = let comp = match_with f () - { retc = (fun x -> (fun s -> (s, x))); - exnc = (fun e -> raise e); - effc = fun (type b) (e : b Effect.t) -> - match e with - | Get -> Some (fun (k : (b, t -> (t * a)) continuation) -> - (fun (s : t) -> continue k s s)) - | Put s' -> Some (fun k -> - (fun _s -> continue k () s')) - | e -> None - } - in snd @@ comp init + { + retc = (fun x s -> (s, x)); + exnc = (fun e -> raise e); + effc = + (fun (type b) (e : b Effect.t) -> + match e with + | Get -> + Some + (fun (k : (b, t -> t * a) continuation) (s : t) -> + continue k s s) + | Put s' -> Some (fun k _s -> continue k () s') + | e -> None); + } + in + snd @@ comp init end type gamestate = (player * int) list -module GS = State (struct type t = gamestate end) + +module GS = State (struct + type t = gamestate +end) (* Get and put operations *) let get = GS.get @@ -254,70 +276,76 @@ let put = GS.put let state s m = GS.run m ~init:s (* Initially both players have zero wins *) -let s0 = [(Alice,0); (Bob,0)] +let s0 = [ (Alice, 0); (Bob, 0) ] (* Update scoreboard *) -let increment_wins p = List.map (fun (p',n) -> if p == p' then (p',n+1) else (p',n)) +let increment_wins p = + List.map (fun (p', n) -> if p == p' then (p', n + 1) else (p', n)) (* Post-processing handler that updates the scoreboard *) -let score_updater m = - match m () with - | p -> put (increment_wins p (get ())) +let score_updater m = match m () with p -> put (increment_wins p (get ())) (* Print the scoreboard *) let print_board s = let rec make_whitespace n = - if n > 0 - then " " ^ (make_whitespace (n - 1)) - else "" + if n > 0 then " " ^ make_whitespace (n - 1) else "" in - let s = List.map - (fun (p,n) -> - let player = string_of_player p in - let wins = string_of_int n in - "| " ^ player ^ make_whitespace (11 - (String.length player)) ^ - "|" ^ make_whitespace (8 - (String.length wins)) ^ wins ^ " |" - ) (List.sort (fun x y -> let (n,n') = (snd x, snd y) in - if n < n' then 1 - else if n > n' then -1 else 0 ) - s) + let s = + List.map + (fun (p, n) -> + let player = string_of_player p in + let wins = string_of_int n in + "| " ^ player + ^ make_whitespace (11 - String.length player) + ^ "|" + ^ make_whitespace (8 - String.length wins) + ^ wins ^ " |") + (List.sort + (fun x y -> + let n, n' = (snd x, snd y) in + if n < n' then 1 else if n > n' then -1 else 0) + s) in - print_endline("/======================\\"); - print_endline("| NIM HIGHSCORE |"); - print_endline("|======================|"); - print_endline("| Player | #Wins |"); - print_endline("|============|=========|"); - (if List.length s > 1 - then (print_endline (List.hd s); - List.fold_left - (fun _ l -> - print_endline("|============|=========|"); - print_endline l; - ) () (List.tl s)) - else ()); - print_endline("\\======================/") + print_endline "/======================\\"; + print_endline "| NIM HIGHSCORE |"; + print_endline "|======================|"; + print_endline "| Player | #Wins |"; + print_endline "|============|=========|"; + if List.length s > 1 then ( + print_endline (List.hd s); + List.fold_left + (fun _ l -> + print_endline "|============|=========|"; + print_endline l) + () (List.tl s)) + else (); + print_endline "\\======================/" (* Post-processing handler that prints the scoreboard *) -let printer m = - match m () with - | _ -> print_board (get ()) +let printer m = match m () with _ -> print_board (get ()) (* Replays a game after n times *) -let rec replay n m = - match m () with - | _ when n > 0 -> replay (n-1) m - | x -> x +let rec replay n m = match m () with _ when n > 0 -> replay (n - 1) m | x -> x let run_examples () = - print_endline (">> game 7 |> perfect :\n" ^ (string_of_player (game 7 |> perfect))); - print_endline (">> game 12 |> perfect :\n" ^ (string_of_player (game 12 |> perfect))); + print_endline + (">> game 7 |> perfect :\n" ^ string_of_player (game 7 |> perfect)); + print_endline + (">> game 12 |> perfect :\n" ^ string_of_player (game 12 |> perfect)); (* Computing game tree *) - print_endline (">> game 3 |> gametree:\n" ^ (string_of_gametree (game 3 |> gametree))); + print_endline + (">> game 3 |> gametree:\n" ^ string_of_gametree (game 3 |> gametree)); (* A stateful scoreboard *) - print_endline ">> game 7 |> (state s0) -<- printer -<- (replay 10) -<- coin -<- score_updater -<- bob_maybe_cheats :"; - let _ = game 7 |> (state s0) -<- printer -<- (replay 10) -<- coin -<- score_updater -<- bob_maybe_cheats in + print_endline + ">> game 7 |> (state s0) -<- printer -<- (replay 10) -<- coin -<- \ + score_updater -<- bob_maybe_cheats :"; + let _ = + game 7 + |> state s0 -<- printer -<- replay 10 -<- coin -<- score_updater + -<- bob_maybe_cheats + in (* Cheat detection example *) print_endline ">> game 7 |> cheat_report -<- bob_cheats -<- checker :\n"; diff --git a/multishot/nondeterminism.ml b/multishot/nondeterminism.ml index 2186250..ba81c12 100644 --- a/multishot/nondeterminism.ml +++ b/multishot/nondeterminism.ml @@ -1,118 +1,143 @@ -(** Coin flipping -- non-determinism as an algebraic effect **) (* This example is adapted from Kammar et. al (2013) *) open Effect +(** Coin flipping -- non-determinism as an algebraic effect **) + open Effect.Deep (* Non-determinism is an effect given by an operation Choose, that returns a boolean. *) type _ Effect.t += Choose : bool Effect.t + let choose () = perform Choose (* An example non-deterministic computation: A coin toss *) type toss = Heads | Tails -let toss () = - if choose () - then Heads - else Tails + +let toss () = if choose () then Heads else Tails (* Fixed interpretations *) -let make_charged_handler (b : bool) = - fun m -> - try_with m () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Choose -> Some (fun (k : (a, _) continuation) -> continue k b) - | _ -> None - } - -let positive = make_charged_handler true (* always interpret as true *) +let make_charged_handler (b : bool) m = + try_with m () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Choose -> Some (fun (k : (a, _) continuation) -> continue k b) + | _ -> None); + } + +let positive = make_charged_handler true (* always interpret as true *) let negative = make_charged_handler false (* always interpret as false *) (* [all_results] enumerates every possible outcome of a non-deterministic computation *) let all_results m = - match_with m () { - retc = (fun v -> [v]); - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | Choose -> Some (fun (k : (a, _) continuation) -> (continue k true) @ (continue (Multicont.Deep.clone_continuation k) false)) - | _ -> None - } - + match_with m () + { + retc = (fun v -> [ v ]); + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Choose -> + Some + (fun (k : (a, _) continuation) -> + continue k true + @ continue (Multicont.Deep.clone_continuation k) false) + | _ -> None); + } + (* OCaml effects/multicore only supports single-shot continuations. But, we can simulate multi-shot continuations by copying a continuation (using Obj.clone) before invocation. *) (* Random interpretation *) let coin m = - try_with m () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Choose -> Some (fun (k : (a, _) continuation) -> continue k (Random.float 1.0 > 0.5)) - | _ -> None - } + try_with m () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Choose -> + Some + (fun (k : (a, _) continuation) -> + continue k (Random.float 1.0 > 0.5)) + | _ -> None); + } (* Another example: A drunken coin toss. A drunkard may fail to catch -the coin. *) + the coin. *) exception Too_drunk -let too_drunk () = raise Too_drunk -let drunk_toss () = - if choose () - then too_drunk () - else toss () +let too_drunk () = raise Too_drunk +let drunk_toss () = if choose () then too_drunk () else toss () (* This exception handler returns Some result if [m] was successful, -otherwise it returns None. *) -let optionalize m = - try Some (m ()) with - | Too_drunk -> None + otherwise it returns None. *) +let optionalize m = try Some (m ()) with Too_drunk -> None (* This exception handler restarts [m] whenever it fails. *) -let rec persevere m = - try m () with - | Too_drunk -> persevere m +let rec persevere m = try m () with Too_drunk -> persevere m (* The pipeline operator combines two handlers [h] and [g]. Data flows from [g] to [h]. *) -let (-<-) h g = fun m -> h (fun () -> g m) +let ( -<- ) h g m = h (fun () -> g m) (* Running some examples + boilerplate conversions *) -let string_of_toss = function - | Heads -> "Heads" - | Tails -> "Tails" +let string_of_toss = function Heads -> "Heads" | Tails -> "Tails" let string_of_list string_of_e xs = let xs = List.map string_of_e xs in - "[" ^ (if List.length xs > 1 - then List.fold_left (fun xs x -> xs ^ ", " ^ x) (List.hd xs) (List.tl xs) - else List.hd xs) + "[" + ^ (if List.length xs > 1 then + List.fold_left (fun xs x -> xs ^ ", " ^ x) (List.hd xs) (List.tl xs) + else List.hd xs) ^ "]" let string_of_option string_of_e = function - | Some e -> "Some (" ^ (string_of_e e) ^ ")" - | None -> "None" + | Some e -> "Some (" ^ string_of_e e ^ ")" + | None -> "None" let run_examples () = - print_endline (">> positive toss : " ^ (string_of_toss (positive toss))); - - print_endline (">> negative toss : " ^ (string_of_toss (negative toss))); - - print_endline (">> all_results toss: " ^ (string_of_list string_of_toss (all_results toss))); - - print_endline (">> coin toss : " ^ (string_of_toss (coin toss))); - - print_endline (">> toss |> optionalize -<- all_results : " ^ (string_of_option (string_of_list string_of_toss) (toss |> optionalize -<- all_results))); - - print_endline (">> toss |> all_results -<- optionalize : " ^ (string_of_list (string_of_option string_of_toss) (toss |> all_results -<- optionalize))); - - print_endline (">> drunk_toss |> optionalize -<- all_results : " ^ (string_of_option (string_of_list string_of_toss) (drunk_toss |> optionalize -<- all_results))); - - print_endline (">> drunk_toss |> all_results -<- optionalize : " ^ (string_of_list (string_of_option string_of_toss) (drunk_toss |> all_results -<- optionalize))); - - print_endline (">> drunk_toss |> optionalize -<- coin : " ^ (string_of_option string_of_toss (drunk_toss |> optionalize -<- coin))); - - print_endline (">> drunk_toss |> peservere -<- coin : " ^ (string_of_toss (drunk_toss |> persevere -<- coin))) + print_endline (">> positive toss : " ^ string_of_toss (positive toss)); + + print_endline (">> negative toss : " ^ string_of_toss (negative toss)); + + print_endline + (">> all_results toss: " ^ string_of_list string_of_toss (all_results toss)); + + print_endline (">> coin toss : " ^ string_of_toss (coin toss)); + + print_endline + (">> toss |> optionalize -<- all_results : " + ^ string_of_option + (string_of_list string_of_toss) + (toss |> optionalize -<- all_results)); + + print_endline + (">> toss |> all_results -<- optionalize : " + ^ string_of_list + (string_of_option string_of_toss) + (toss |> all_results -<- optionalize)); + + print_endline + (">> drunk_toss |> optionalize -<- all_results : " + ^ string_of_option + (string_of_list string_of_toss) + (drunk_toss |> optionalize -<- all_results)); + + print_endline + (">> drunk_toss |> all_results -<- optionalize : " + ^ string_of_list + (string_of_option string_of_toss) + (drunk_toss |> all_results -<- optionalize)); + + print_endline + (">> drunk_toss |> optionalize -<- coin : " + ^ string_of_option string_of_toss (drunk_toss |> optionalize -<- coin)); + + print_endline + (">> drunk_toss |> peservere -<- coin : " + ^ string_of_toss (drunk_toss |> persevere -<- coin)) let _ = run_examples () diff --git a/multishot/queens.ml b/multishot/queens.ml index 77d581e..65ccdda 100644 --- a/multishot/queens.ml +++ b/multishot/queens.ml @@ -7,54 +7,73 @@ let n = try int_of_string Sys.argv.(1) with _ -> 8 let rec safe queen diag xs = match xs with | [] -> true - | q :: qs -> queen <> q && queen <> q + diag && queen <> q - diag && - safe queen (diag + 1) qs + | q :: qs -> + queen <> q + && queen <> q + diag + && queen <> q - diag + && safe queen (diag + 1) qs type _ Effect.t += Pick : int -> int Effect.t + exception Fail let rec find_solution n col : int list = if col = 0 then [] - else begin + else let sol = find_solution n (col - 1) in let queen = perform (Pick n) in - if safe queen 1 sol then queen::sol else raise Fail - end + if safe queen 1 sol then queen :: sol else raise Fail let queens_count n = - match_with (find_solution n) n { - retc = (fun _ -> 1); - exnc = (function Fail -> 0 | e -> raise e); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Pick n -> Some (fun (k : (a, _) continuation) -> - let rec loop i acc = - if i = n then (continue k i + acc) - else loop (i+1) (continue (Multicont.Deep.clone_continuation k) i + acc) - in loop 1 0) - | _ -> None - } + match_with (find_solution n) n + { + retc = (fun _ -> 1); + exnc = (function Fail -> 0 | e -> raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Pick n -> + Some + (fun (k : (a, _) continuation) -> + let rec loop i acc = + if i = n then continue k i + acc + else + loop (i + 1) + (continue (Multicont.Deep.clone_continuation k) i + acc) + in + loop 1 0) + | _ -> None); + } let queens_choose n = - match_with (find_solution n) n { - retc = (fun x -> [ x ]); - exnc = (function Fail -> [] | e -> raise e); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Pick n -> Some (fun (k : (a, _) continuation) -> - let rec loop i acc : int list list = - if i = 1 then (continue k i @ acc) - else loop (i-1) (continue (Multicont.Deep.clone_continuation k) i @ acc) - in loop n []) - | _ -> None - } + match_with (find_solution n) n + { + retc = (fun x -> [ x ]); + exnc = (function Fail -> [] | e -> raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Pick n -> + Some + (fun (k : (a, _) continuation) -> + let rec loop i acc : int list list = + if i = 1 then continue k i @ acc + else + loop (i - 1) + (continue (Multicont.Deep.clone_continuation k) i @ acc) + in + loop n []) + | _ -> None); + } let print_all_solutions () = let sols = queens_choose n in - List.iter (fun l -> - List.iter (fun pos -> Printf.printf "%d " pos) l; - print_endline "") sols + List.iter + (fun l -> + List.iter (fun pos -> Printf.printf "%d " pos) l; + print_endline "") + sols let _ = print_all_solutions (); - Printf.printf "%d\n" (queens_count n) \ No newline at end of file + Printf.printf "%d\n" (queens_count n) diff --git a/mvar/MVar.ml b/mvar/MVar.ml index 9e34890..70bc88c 100644 --- a/mvar/MVar.ml +++ b/mvar/MVar.ml @@ -1,42 +1,40 @@ module type S = sig type 'a t - val create : 'a -> 'a t + + val create : 'a -> 'a t val create_empty : unit -> 'a t - val put : 'a -> 'a t -> unit - val take : 'a t -> 'a + val put : 'a -> 'a t -> unit + val take : 'a t -> 'a end module type SCHED = sig type 'a cont type _ Effect.t += Suspend : ('a cont -> unit) -> 'a Effect.t - type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t + type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t end module Make (S : SCHED) : S = struct open Effect - + (** The state of mvar is either [Full v q] filled with value [v] and a queue [q] of threads waiting to fill the mvar, or [Empty q], with a queue [q] of threads waiting to empty the mvar. *) type 'a mv_state = - | Full of 'a * ('a * unit S.cont) Queue.t + | Full of 'a * ('a * unit S.cont) Queue.t | Empty of 'a S.cont Queue.t type 'a t = 'a mv_state ref let create_empty () = ref (Empty (Queue.create ())) - let create v = ref (Full (v, Queue.create ())) - let suspend f = perform @@ S.Suspend f - let resume (a,b) = perform @@ S.Resume (a,b) + let resume (a, b) = perform @@ S.Resume (a, b) let put v mv = match !mv with - | Full (v', q) -> suspend (fun k -> Queue.push (v,k) q) + | Full (v', q) -> suspend (fun k -> Queue.push (v, k) q) | Empty q -> - if Queue.is_empty q then - mv := Full (v, Queue.create ()) + if Queue.is_empty q then mv := Full (v, Queue.create ()) else let t = Queue.pop q in resume (t, v) @@ -45,11 +43,12 @@ module Make (S : SCHED) : S = struct match !mv with | Empty q -> suspend (fun k -> Queue.push k q) | Full (v, q) -> - if Queue.is_empty q then - (mv := Empty (Queue.create ()); v) + if Queue.is_empty q then ( + mv := Empty (Queue.create ()); + v) else - let (v', t) = Queue.pop q in - (mv := Full (v', q); - resume (t, ()); - v) + let v', t = Queue.pop q in + mv := Full (v', q); + resume (t, ()); + v end diff --git a/mvar/MVar.mli b/mvar/MVar.mli index 06930e2..5faef5d 100644 --- a/mvar/MVar.mli +++ b/mvar/MVar.mli @@ -1,34 +1,36 @@ module type S = sig + type 'a t (** MVar type. Represents a data structure with a single hole that can be filled with value. *) - type 'a t - (** [create v] allocates a new mvar with the hole filled with value [v]. *) val create : 'a -> 'a t + (** [create v] allocates a new mvar with the hole filled with value [v]. *) - (** [create_empty ()] allocates a new mvar with the hole empty. *) val create_empty : unit -> 'a t + (** [create_empty ()] allocates a new mvar with the hole empty. *) + val put : 'a -> 'a t -> unit (** [put v m] fills mvar [m] with value v. If the mvar is already filled, this operation blocks until the hole become empty. *) - val put : 'a -> 'a t -> unit + val take : 'a t -> 'a (** [take m] empties the mvar [m] if it is filled and returns the value. If [m] is empty, then the operation blocks until the mvar becomes filled. *) - val take : 'a t -> 'a end module type SCHED = sig type 'a cont (** Represents a blocked computation that waits for a value of type 'a. *) - type _ Effect.t += Suspend : ('a cont -> unit) -> 'a Effect.t - (** [perform @@ Suspend f] applies [f] to the current continuation, and suspends the + type _ Effect.t += + | Suspend : ('a cont -> unit) -> 'a Effect.t + (** [perform @@ Suspend f] applies [f] to the current continuation, and suspends the execution of the current thread, and switches to the next thread in the scheduler's queue. *) - type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t - (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and + type _ Effect.t += + | Resume : ('a cont * 'a) -> unit Effect.t + (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and enqueues it to the scheduler queue. *) end diff --git a/mvar/MVar_monad.ml b/mvar/MVar_monad.ml index 8f6bc12..f1cef4d 100644 --- a/mvar/MVar_monad.ml +++ b/mvar/MVar_monad.ml @@ -4,43 +4,42 @@ module S = Sched_monad [q] of threads waiting to fill the mvar, or [Empty q], with a queue [q] of threads waiting to empty the mvar. *) type 'a mv_state = - | Full of 'a * ('a * unit S.cont) Queue.t + | Full of 'a * ('a * unit S.cont) Queue.t | Empty of 'a S.cont Queue.t type 'a t = 'a mv_state ref let create_empty () = ref (Empty (Queue.create ())) - let create v = ref (Full (v, Queue.create ())) let put mv v = - S.suspend ( fun k -> - match !mv with - | Full (v', q) -> - Queue.push (v,k) q; - None - | Empty q -> - if Queue.is_empty q then - ( mv := Full (v, Queue.create ()); - Some ((), None)) - else - let t = Queue.pop q in - Some ((), Some (S.prepare t v)) ) + S.suspend (fun k -> + match !mv with + | Full (v', q) -> + Queue.push (v, k) q; + None + | Empty q -> + if Queue.is_empty q then ( + mv := Full (v, Queue.create ()); + Some ((), None)) + else + let t = Queue.pop q in + Some ((), Some (S.prepare t v))) -let (>>) = S.(>>) +let ( >> ) = S.( >> ) let take mv = S.suspend (fun k -> - match !mv with - | Empty q -> - Queue.push k q; - None - | Full (v, q) -> - if Queue.is_empty q then - (mv := Empty (Queue.create ()); - Some (v, None)) - else - let (v', t) = Queue.pop q in - mv := Full (v', q); - Printf.printf "take: resume\n"; - Some (v, Some (S.prepare t ()))) + match !mv with + | Empty q -> + Queue.push k q; + None + | Full (v, q) -> + if Queue.is_empty q then ( + mv := Empty (Queue.create ()); + Some (v, None)) + else + let v', t = Queue.pop q in + mv := Full (v', q); + Printf.printf "take: resume\n"; + Some (v, Some (S.prepare t ()))) diff --git a/mvar/MVar_monad.mli b/mvar/MVar_monad.mli index 7525f6d..074ed74 100644 --- a/mvar/MVar_monad.mli +++ b/mvar/MVar_monad.mli @@ -1,4 +1,5 @@ type 'a t + val create : 'a -> 'a t val create_empty : unit -> 'a t val put : 'a t -> 'a -> unit Sched_monad.t diff --git a/mvar/MVar_test.ml b/mvar/MVar_test.ml index 71fcd8e..54d52d0 100644 --- a/mvar/MVar_test.ml +++ b/mvar/MVar_test.ml @@ -1,17 +1,15 @@ module MVar = MVar.Make (Sched) - open MVar open Printf open Sched let mv = create_empty () - let fork f = Effect.perform @@ Fork f let put x = - (printf "Before put: %s\n" x; + printf "Before put: %s\n" x; put x mv; - printf "After put: %s\n" x) + printf "After put: %s\n" x let get () = let () = printf "Before get\n" in diff --git a/mvar/chameneos.ml b/mvar/chameneos.ml index e02968f..9a0a32e 100644 --- a/mvar/chameneos.ml +++ b/mvar/chameneos.ml @@ -1,17 +1,13 @@ open Effect - module List = ListLabels module String = StringLabels open Printf module Color = struct - type t = - | Blue - | Red - | Yellow + type t = Blue | Red | Yellow let complement t t' = - match t, t' with + match (t, t') with | Blue, Blue -> Blue | Blue, Red -> Yellow | Blue, Yellow -> Red @@ -22,42 +18,36 @@ module Color = struct | Yellow, Red -> Blue | Yellow, Yellow -> Yellow - let to_string = function - | Blue -> "blue" - | Red -> "red" - | Yellow -> "yellow" - + let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" let all = [ Blue; Red; Yellow ] end module MVar = MVar.Make (Sched) type chameneos = Color.t ref - -type mp = -| Nobody of int -| Somebody of int * chameneos * chameneos MVar.t +type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = let waker = MVar.create_empty () in - let inc x i = if (x == ch) then i+1 else i in + let inc x i = if x == ch then i + 1 else i in let rec go t b = let w = MVar.take mpv in match w with | Nobody 0 -> MVar.put w mpv; - MVar.put (t,b) finish + MVar.put (t, b) finish | Nobody q -> - MVar.put (Somebody (q, ch, waker)) mpv; - go (t+1) @@ inc (MVar.take waker) b + MVar.put (Somebody (q, ch, waker)) mpv; + go (t + 1) @@ inc (MVar.take waker) b | Somebody (q, ch', waker') -> MVar.put (Nobody (q - 1)) mpv; let c'' = Color.complement !ch !ch' in ch := c''; ch' := c''; MVar.put ch waker'; - go (t+1) @@ inc ch' b -in go 0 0 + go (t + 1) @@ inc ch' b + in + go 0 0 let spell_int i = let spell_char = function @@ -78,48 +68,62 @@ let spell_int i = let print_complements () = List.iter Color.all ~f:(fun c1 -> - List.iter Color.all ~f:(fun c2 -> - printf "%s + %s -> %s\n" - (Color.to_string c1) - (Color.to_string c2) - (Color.to_string (Color.complement c1 c2)))); - printf "\n"; -;; + List.iter Color.all ~f:(fun c2 -> + printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) + (Color.to_string (Color.complement c1 c2)))); + printf "\n" let rec tabulate' acc f = function | 0 -> acc - | n -> tabulate' (f()::acc) f (n-1) -;; + | n -> tabulate' (f () :: acc) f (n - 1) let tabulate f n = List.rev @@ tabulate' [] f n - let fork f = perform @@ Sched.Fork f let work colors n = - let () = List.iter colors ~f:(fun c -> - printf " %s" (Color.to_string c)); printf "\n" in + let () = + List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); + printf "\n" + in let fs = tabulate MVar.create_empty (List.length colors) in let mpv = MVar.create (Nobody n) in let chams = List.map ~f:(fun c -> ref c) colors in - let () = List.iter2 ~f:(fun fin ch -> - fork (fun () -> arrive mpv fin ch)) fs chams in + let () = + List.iter2 ~f:(fun fin ch -> fork (fun () -> arrive mpv fin ch)) fs chams + in let ns = List.map ~f:MVar.take fs in - let () = List.iter ~f:(fun (n,b) -> print_int n; spell_int b; printf "\n") ns in - let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n,_) -> n+acc) ns in - spell_int sum_meets; printf "\n" + let () = + List.iter + ~f:(fun (n, b) -> + print_int n; + spell_int b; + printf "\n") + ns + in + let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in + spell_int sum_meets; + printf "\n" let main () = - let n = - try - int_of_string (Sys.argv.(1)) - with - | _ -> 600 - in + let n = try int_of_string Sys.argv.(1) with _ -> 600 in print_complements (); let module C = Color in work [ C.Blue; C.Red; C.Yellow ] n; printf "\n"; - work [ C.Blue; C.Red; C.Yellow; C.Red; C.Yellow; C.Blue; C.Red; C.Yellow; C.Red; C.Blue ] n; + work + [ + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Yellow; + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Blue; + ] + n; printf "\n" let () = Sched.run main diff --git a/mvar/chameneos_lwt.ml b/mvar/chameneos_lwt.ml index a0209e3..e3df367 100644 --- a/mvar/chameneos_lwt.ml +++ b/mvar/chameneos_lwt.ml @@ -1,6 +1,6 @@ open Lwt -let (>>) = fun a b -> a >>= fun () -> b +let ( >> ) a b = a >>= fun () -> b module MVar = Lwt_mvar module List = ListLabels @@ -8,13 +8,10 @@ module String = StringLabels open Printf module Color = struct - type t = - | Blue - | Red - | Yellow + type t = Blue | Red | Yellow let complement t t' = - match t, t' with + match (t, t') with | Blue, Blue -> Blue | Blue, Red -> Yellow | Blue, Yellow -> Red @@ -25,43 +22,35 @@ module Color = struct | Yellow, Red -> Blue | Yellow, Yellow -> Yellow - let to_string = function - | Blue -> "blue" - | Red -> "red" - | Yellow -> "yellow" - + let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" let all = [ Blue; Red; Yellow ] end type chameneos = Color.t ref - -type mp = -| Nobody of int -| Somebody of int * chameneos * chameneos MVar.t +type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = let waker = MVar.create_empty () in - let inc x i = if (x == ch) then i+1 else i in + let inc x i = if x == ch then i + 1 else i in let rec go t b = MVar.take mpv >>= fun w -> match w with - | Nobody 0 -> - MVar.put mpv w >> - MVar.put finish (t,b) + | Nobody 0 -> MVar.put mpv w >> MVar.put finish (t, b) | Nobody q -> - Lwt.pause () >> - MVar.put mpv (Somebody (q, ch, waker)) >> - MVar.take waker >>= fun w' -> - go (t+1) @@ inc w' b + Lwt.pause () + >> MVar.put mpv (Somebody (q, ch, waker)) + >> MVar.take waker + >>= fun w' -> go (t + 1) @@ inc w' b | Somebody (q, ch', waker') -> - Lwt.pause () >> - MVar.put mpv (Nobody (q - 1)) >> + Lwt.pause () + >> MVar.put mpv (Nobody (q - 1)) + >> let c'' = Color.complement !ch !ch' in ch := c''; ch' := c''; - MVar.put waker' ch >> - go (t+1) @@ inc ch' b - in go 0 0 + MVar.put waker' ch >> go (t + 1) @@ inc ch' b + in + go 0 0 let spell_int i = let spell_char = function @@ -82,47 +71,64 @@ let spell_int i = let print_complements () = List.iter Color.all ~f:(fun c1 -> - List.iter Color.all ~f:(fun c2 -> - printf "%s + %s -> %s\n" - (Color.to_string c1) - (Color.to_string c2) - (Color.to_string (Color.complement c1 c2)))); - printf "\n"; -;; + List.iter Color.all ~f:(fun c2 -> + printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) + (Color.to_string (Color.complement c1 c2)))); + printf "\n" let rec tabulate' acc f = function | 0 -> acc - | n -> tabulate' (f()::acc) f (n-1) -;; + | n -> tabulate' (f () :: acc) f (n - 1) let tabulate f n = List.rev @@ tabulate' [] f n let work colors n = - let () = List.iter colors ~f:(fun c -> - printf " %s" (Color.to_string c)); printf "\n" in + let () = + List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); + printf "\n" + in let fs = tabulate MVar.create_empty (List.length colors) in let mpv = MVar.create (Nobody n) in let chams = List.map ~f:(fun c -> ref c) colors in let comb = List.combine fs chams in - Lwt_list.iter_p (fun (fin,ch) -> arrive mpv fin ch) comb >> - Lwt_list.map_p MVar.take fs >>= fun ns -> - let () = List.iter ~f:(fun (n,b) -> print_int n; spell_int b; printf "\n") ns in - let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n,_) -> n+acc) ns in - spell_int sum_meets; printf "\n"; return () + Lwt_list.iter_p (fun (fin, ch) -> arrive mpv fin ch) comb + >> Lwt_list.map_p MVar.take fs + >>= fun ns -> + let () = + List.iter + ~f:(fun (n, b) -> + print_int n; + spell_int b; + printf "\n") + ns + in + let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in + spell_int sum_meets; + printf "\n"; + return () let main = - let n = - try - int_of_string (Sys.argv.(1)) - with - | _ -> 600 - in + let n = try int_of_string Sys.argv.(1) with _ -> 600 in print_complements (); let module C = Color in work [ C.Blue; C.Red; C.Yellow ] n >>= fun () -> printf "\n"; - work [ C.Blue; C.Red; C.Yellow; C.Red; C.Yellow; - C.Blue; C.Red; C.Yellow; C.Red; C.Blue ] n >>= fun () -> - printf "\n"; return () + work + [ + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Yellow; + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Blue; + ] + n + >>= fun () -> + printf "\n"; + return () let () = Lwt_main.run main diff --git a/mvar/chameneos_monad.ml b/mvar/chameneos_monad.ml index 54ef5bf..917c154 100644 --- a/mvar/chameneos_monad.ml +++ b/mvar/chameneos_monad.ml @@ -1,6 +1,6 @@ open Sched_monad -let (>>) = fun a b -> a >>= fun () -> b +let ( >> ) a b = a >>= fun () -> b module MVar = MVar_monad module List = ListLabels @@ -8,13 +8,10 @@ module String = StringLabels open Printf module Color = struct - type t = - | Blue - | Red - | Yellow + type t = Blue | Red | Yellow let complement t t' = - match t, t' with + match (t, t') with | Blue, Blue -> Blue | Blue, Red -> Yellow | Blue, Yellow -> Red @@ -25,43 +22,33 @@ module Color = struct | Yellow, Red -> Blue | Yellow, Yellow -> Yellow - let to_string = function - | Blue -> "blue" - | Red -> "red" - | Yellow -> "yellow" - + let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" let all = [ Blue; Red; Yellow ] end type chameneos = Color.t ref - -type mp = -| Nobody of int -| Somebody of int * chameneos * chameneos MVar.t +type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = let waker = MVar.create_empty () in - let inc x i = if (x == ch) then i+1 else i in + let inc x i = if x == ch then i + 1 else i in let rec go t b = MVar.take mpv >>= fun w -> match w with - | Nobody 0 -> - MVar.put mpv w >> - MVar.put finish (t,b) + | Nobody 0 -> MVar.put mpv w >> MVar.put finish (t, b) | Nobody q -> - yield >> - MVar.put mpv (Somebody (q, ch, waker)) >> - MVar.take waker >>= fun w' -> - go (t+1) @@ inc w' b + yield >> MVar.put mpv (Somebody (q, ch, waker)) >> MVar.take waker + >>= fun w' -> go (t + 1) @@ inc w' b | Somebody (q, ch', waker') -> - yield >> - MVar.put mpv (Nobody (q - 1)) >> + yield + >> MVar.put mpv (Nobody (q - 1)) + >> let c'' = Color.complement !ch !ch' in let () = ch := c'' in let () = ch' := c'' in - MVar.put waker' ch >> - go (t+1) @@ inc ch' b - in go 0 0 + MVar.put waker' ch >> go (t + 1) @@ inc ch' b + in + go 0 0 let spell_int i = let spell_char = function @@ -82,49 +69,63 @@ let spell_int i = let print_complements () = List.iter Color.all ~f:(fun c1 -> - List.iter Color.all ~f:(fun c2 -> - printf "%s + %s -> %s\n" - (Color.to_string c1) - (Color.to_string c2) - (Color.to_string (Color.complement c1 c2)))); - printf "\n"; -;; + List.iter Color.all ~f:(fun c2 -> + printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) + (Color.to_string (Color.complement c1 c2)))); + printf "\n" let rec tabulate' acc f = function | 0 -> acc - | n -> tabulate' (f()::acc) f (n-1) -;; + | n -> tabulate' (f () :: acc) f (n - 1) let tabulate f n = List.rev @@ tabulate' [] f n let work colors n = - let () = List.iter colors ~f:(fun c -> - printf " %s" (Color.to_string c)); printf "\n" in + let () = + List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); + printf "\n" + in let fs = tabulate MVar.create_empty (List.length colors) in let mpv = MVar.create (Nobody n) in let chams = List.map ~f:(fun c -> ref c) colors in let comb = List.combine fs chams in - iter_p (fun (fin,ch) -> fork (arrive mpv fin ch)) comb >> - map_p MVar.take fs >>= fun ns -> - let () = List.iter ~f:(fun (n,b) -> print_int n; spell_int b; printf "\n") ns in - let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n,_) -> n+acc) ns in + iter_p (fun (fin, ch) -> fork (arrive mpv fin ch)) comb >> map_p MVar.take fs + >>= fun ns -> + let () = + List.iter + ~f:(fun (n, b) -> + print_int n; + spell_int b; + printf "\n") + ns + in + let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in let () = spell_int sum_meets in let () = printf "\n" in return () let main = - let n = - try - int_of_string (Sys.argv.(1)) - with - | _ -> 600 - in + let n = try int_of_string Sys.argv.(1) with _ -> 600 in print_complements (); let module C = Color in work [ C.Blue; C.Red; C.Yellow ] n >>= fun () -> printf "\n"; - work [ C.Blue; C.Red; C.Yellow; C.Red; C.Yellow; - C.Blue; C.Red; C.Yellow; C.Red; C.Blue ] n >>= fun () -> - printf "\n"; return () + work + [ + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Yellow; + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Blue; + ] + n + >>= fun () -> + printf "\n"; + return () let () = run main diff --git a/mvar/chameneos_systhr.ml b/mvar/chameneos_systhr.ml index 8e7a8e2..2d77790 100644 --- a/mvar/chameneos_systhr.ml +++ b/mvar/chameneos_systhr.ml @@ -1,16 +1,12 @@ module List = ListLabels module String = StringLabels - open Printf module Color = struct - type t = - | Blue - | Red - | Yellow + type t = Blue | Red | Yellow let complement t t' = - match t, t' with + match (t, t') with | Blue, Blue -> Blue | Blue, Red -> Yellow | Blue, Yellow -> Red @@ -21,16 +17,11 @@ module Color = struct | Yellow, Red -> Blue | Yellow, Yellow -> Yellow - let to_string = function - | Blue -> "blue" - | Red -> "red" - | Yellow -> "yellow" - + let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" let all = [ Blue; Red; Yellow ] end module Meeting_place = struct - type 'chameneos t = { mutable state : [ `Empty | `First of 'chameneos | `Second of 'chameneos ]; mutable meetings_left : int; @@ -39,54 +30,48 @@ module Meeting_place = struct wait_for_empty : Condition.t; } - let create n = { - state = `Empty; - meetings_left = n; - mutex = Mutex.create (); - wait_for_second = Condition.create (); - wait_for_empty = Condition.create (); - } + let create n = + { + state = `Empty; + meetings_left = n; + mutex = Mutex.create (); + wait_for_second = Condition.create (); + wait_for_empty = Condition.create (); + } let meet t c = let rec loop () = - if t.meetings_left = 0 then begin + if t.meetings_left = 0 then ( Condition.broadcast t.wait_for_empty; - None - end + None) else - match t.state with - | `Empty -> - t.state <- `First c; - Condition.wait t.wait_for_second t.mutex; - begin match t.state with - | `Empty - | `First _ -> - assert false - | `Second c -> - t.state <- `Empty; - Condition.signal t.wait_for_empty; - Condition.signal t.wait_for_empty; - Some c - end - | `First c1 -> - t.state <- `Second c; - t.meetings_left <- t.meetings_left - 1; - Condition.signal t.wait_for_second; - Some c1 - | `Second _ -> - Condition.wait t.wait_for_empty t.mutex; - loop () + | `Empty -> ( + t.state <- `First c; + Condition.wait t.wait_for_second t.mutex; + match t.state with + | `Empty | `First _ -> assert false + | `Second c -> + t.state <- `Empty; + Condition.signal t.wait_for_empty; + Condition.signal t.wait_for_empty; + Some c) + | `First c1 -> + t.state <- `Second c; + t.meetings_left <- t.meetings_left - 1; + Condition.signal t.wait_for_second; + Some c1 + | `Second _ -> + Condition.wait t.wait_for_empty t.mutex; + loop () in Mutex.lock t.mutex; let res = loop () in Mutex.unlock t.mutex; res - ;; end module Chameneos = struct - type t = { id : int; mutable color : Color.t; @@ -101,35 +86,28 @@ module Chameneos = struct id := r + 1; r in - fun color -> - { id = new_id (); - color = color; - meetings = 0; - meetings_with_self = 0; - } + fun color -> { id = new_id (); color; meetings = 0; meetings_with_self = 0 } let run t place = let rec loop () = match Meeting_place.meet place t with | None -> () | Some other -> - t.meetings <- t.meetings + 1; - if t.id = other.id then t.meetings_with_self <- t.meetings_with_self + 1; - t.color <- Color.complement t.color other.color; - loop () + t.meetings <- t.meetings + 1; + if t.id = other.id then + t.meetings_with_self <- t.meetings_with_self + 1; + t.color <- Color.complement t.color other.color; + loop () in Thread.create loop () end let print_complements () = List.iter Color.all ~f:(fun c1 -> - List.iter Color.all ~f:(fun c2 -> - printf "%s + %s -> %s\n" - (Color.to_string c1) - (Color.to_string c2) - (Color.to_string (Color.complement c1 c2)))); - printf "\n"; -;; + List.iter Color.all ~f:(fun c2 -> + printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) + (Color.to_string (Color.complement c1 c2)))); + printf "\n" let spell_int i = let spell_char = function @@ -146,37 +124,45 @@ let spell_int i = | x -> failwith "unexpected char" in let s = string_of_int i in - String.iter s ~f:(fun c -> printf " %s" (spell_char c)); -;; + String.iter s ~f:(fun c -> printf " %s" (spell_char c)) let work colors n = let module C = Chameneos in - List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); printf "\n"; + List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); + printf "\n"; let place = Meeting_place.create n in let cs = List.map colors ~f:Chameneos.create in let threads = List.map cs ~f:(fun c -> Chameneos.run c place) in List.iter threads ~f:Thread.join; let sum_meets = ref 0 in List.iter cs ~f:(fun c -> - printf "%d" c.C.meetings; spell_int c.C.meetings_with_self; printf "\n"; - sum_meets := !sum_meets + c.C.meetings); - spell_int !sum_meets; printf "\n"; -;; - + printf "%d" c.C.meetings; + spell_int c.C.meetings_with_self; + printf "\n"; + sum_meets := !sum_meets + c.C.meetings); + spell_int !sum_meets; + printf "\n" let main () = - let n = - try - int_of_string (Sys.argv.(1)) - with - | _ -> 600 - in + let n = try int_of_string Sys.argv.(1) with _ -> 600 in print_complements (); let module C = Color in work [ C.Blue; C.Red; C.Yellow ] n; printf "\n"; - work [ C.Blue; C.Red; C.Yellow; C.Red; C.Yellow; C.Blue; C.Red; C.Yellow; C.Red; C.Blue ] n; - printf "\n"; -;; + work + [ + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Yellow; + C.Blue; + C.Red; + C.Yellow; + C.Red; + C.Blue; + ] + n; + printf "\n" let () = main () diff --git a/mvar/concurrent_monad.ml b/mvar/concurrent_monad.ml index 428bf6b..79917c5 100644 --- a/mvar/concurrent_monad.ml +++ b/mvar/concurrent_monad.ml @@ -2,34 +2,33 @@ let log = Printf.printf -(* ************ - Fiber tree - ************ - 0 - / \ - 1 2 - / \ / \ - 3 4 5 6 +(* ************ + Fiber tree + ************ + 0 + / \ + 1 2 + / \ / \ + 3 4 5 6 *) open Sched_monad -let (>>) a b = a >>= (fun _ -> b) +let ( >> ) a b = a >>= fun _ -> b let rec f id depth = log "Starting number %i\n%!" id; - if depth > 0 then begin - log "Forking (1) number %i\n%!" (id * 2 + 1); - fork (f (id * 2 + 1) (depth - 1)) >> - let () = log "Forking (2) number %i\n%!" (id * 2 + 2) in - fork (f (id * 2 + 2) (depth - 1)) - end - else begin + if depth > 0 then ( + log "Forking (1) number %i\n%!" ((id * 2) + 1); + fork (f ((id * 2) + 1) (depth - 1)) + >> + let () = log "Forking (2) number %i\n%!" ((id * 2) + 2) in + fork (f ((id * 2) + 2) (depth - 1))) + else ( log "Yielding in number %i\n%!" id; yield >>= fun _ -> log "Resumed number %i\n%!" id; - return () - end; + return ()); log "Finishing number %i\n%!" id; return () diff --git a/mvar/dune b/mvar/dune index a0a77d8..a907144 100644 --- a/mvar/dune +++ b/mvar/dune @@ -1,4 +1,13 @@ (executables (names chameneos chameneos_monad chameneos_lwt MVar_test chameneos_systhr) (libraries threads lwt lwt.unix) - (modules sched MVar sched_monad MVar_monad chameneos chameneos_monad chameneos_lwt MVar_test chameneos_systhr)) + (modules + sched + MVar + sched_monad + MVar_monad + chameneos + chameneos_monad + chameneos_lwt + MVar_test + chameneos_systhr)) diff --git a/mvar/sched.ml b/mvar/sched.ml index 257f62c..0f5397d 100644 --- a/mvar/sched.ml +++ b/mvar/sched.ml @@ -1,39 +1,50 @@ open Effect open Effect.Deep -type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t -type _ Effect.t += Yield : unit Effect.t - -type 'a cont = ('a,unit) continuation +type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t +type _ Effect.t += Yield : unit Effect.t +type 'a cont = ('a, unit) continuation type _ Effect.t += Suspend : ('a cont -> unit) -> 'a Effect.t -type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t +type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t let run main = let run_q = Queue.create () in - let enqueue t v = - Queue.push (fun () -> continue t v) run_q - in - let dequeue () = - if Queue.is_empty run_q then () - else Queue.pop run_q () - in + let enqueue t v = Queue.push (fun () -> continue t v) run_q in + let dequeue () = if Queue.is_empty run_q then () else Queue.pop run_q () in let rec spawn f = - match_with f () { - retc = dequeue; - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield -> Some (fun (k : (a, _) continuation) -> enqueue k (); dequeue ()) - | Fork f -> Some (fun k -> enqueue k (); spawn f) - | Suspend f -> Some (fun k -> f k; dequeue ()) - | Resume (k', v) -> Some (fun k -> - enqueue k' v; ignore (continue k ())) - | _ -> None - } + match_with f () + { + retc = dequeue; + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield -> + Some + (fun (k : (a, _) continuation) -> + enqueue k (); + dequeue ()) + | Fork f -> + Some + (fun k -> + enqueue k (); + spawn f) + | Suspend f -> + Some + (fun k -> + f k; + dequeue ()) + | Resume (k', v) -> + Some + (fun k -> + enqueue k' v; + ignore (continue k ())) + | _ -> None); + } in spawn main let fork f = perform (Fork f) let yield () = perform Yield let suspend f = perform (Suspend f) -let resume (k,v) = perform (Resume (k,v)) +let resume (k, v) = perform (Resume (k, v)) diff --git a/mvar/sched.mli b/mvar/sched.mli index 02028d4..33c38e3 100644 --- a/mvar/sched.mli +++ b/mvar/sched.mli @@ -1,20 +1,24 @@ type 'a cont (** Represents a blocked computation that waits for a value of type 'a. *) -type _ Effect.t += Suspend : ('a cont -> unit) -> 'a Effect.t -(** [Perform @@ Suspend f] applies [f] to the current continuation, and suspends the +type _ Effect.t += + | Suspend : ('a cont -> unit) -> 'a Effect.t + (** [Perform @@ Suspend f] applies [f] to the current continuation, and suspends the execution of the current thread, and switches to the next thread in the scheduler's queue. *) -type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t -(** [perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and +type _ Effect.t += + | Resume : ('a cont * 'a) -> unit Effect.t + (** [perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and enqueues it to the scheduler queue. *) -type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t -(** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) +type _ Effect.t += + | Fork : (unit -> unit) -> unit Effect.t + (** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) -type _ Effect.t += Yield : unit Effect.t -(** [perform Yield] suspends the current thread and switches to the next thread from +type _ Effect.t += + | Yield : unit Effect.t + (** [perform Yield] suspends the current thread and switches to the next thread from the run queue. *) val run : (unit -> unit) -> unit diff --git a/mvar/sched_monad.ml b/mvar/sched_monad.ml index 9ffa0e6..e86bb82 100644 --- a/mvar/sched_monad.ml +++ b/mvar/sched_monad.ml @@ -9,55 +9,62 @@ type action = and zaction = unit -> action type 'a t = ('a -> action) -> action - type 'a cont = 'a -> action -let (>>=) f k = fun c -> f (fun a -> k a c) -let (>>) a b = a >>= (fun _ -> b) -let return x = fun c -> c x -let atom f = fun c -> Atom (fun () -> (let b = f () in c b)) +let ( >>= ) f k c = f (fun a -> k a c) +let ( >> ) a b = a >>= fun _ -> b +let return x c = c x + +let atom f c = + Atom + (fun () -> + let b = f () in + c b) + let action f = f (fun () -> Stop) -let fork f = fun c -> Fork ((fun () -> action f), c) -let stop = fun c -> Stop -let yield = fun c -> Yield c -let suspend f = fun c -> +let fork f c = Fork ((fun () -> action f), c) +let stop c = Stop +let yield c = Yield c + +let suspend f c = match f c with | None -> Suspend | Some (v, None) -> c v | Some (v, Some l) -> Resume ((fun () -> c v), l) type ready_cont = zaction -let prepare k v = fun () -> k v - +let prepare k v () = k v let rec round = function - | [] -> () - | (x::xs) -> match x with - | Atom th -> let y = th () in round (xs @ [y]) - | Fork (a1, a2) -> round (a1 () :: a2 () :: xs) - | Yield a -> round ( xs @ [a ()]) - | Suspend -> round xs - | Resume (a1, a2) -> round (a1 () :: a2 () :: xs) - | Stop -> round xs + | [] -> () + | x :: xs -> ( + match x with + | Atom th -> + let y = th () in + round (xs @ [ y ]) + | Fork (a1, a2) -> round (a1 () :: a2 () :: xs) + | Yield a -> round (xs @ [ a () ]) + | Suspend -> round xs + | Resume (a1, a2) -> round (a1 () :: a2 () :: xs) + | Stop -> round xs) -let run m = round [action m] +let run m = round [ action m ] let rec iter_p f l = match l with - | [] -> return () - | x :: l -> - let tx = f x and tl = iter_p f l in - tx >>= fun () -> tl + | [] -> return () + | x :: l -> + let tx = f x and tl = iter_p f l in + tx >>= fun () -> tl -let map f m = (>>=) m (fun x -> return (f x)) -let (>|=) t f = map f t +let map f m = m >>= fun x -> return (f x) +let ( >|= ) t f = map f t let rec map_p f l = match l with | [] -> return [] | x :: l -> - let tx = f x and tl = map_p f l in - tx >>= fun x -> - tl >|= fun l -> - x :: l + let tx = f x and tl = map_p f l in + tx >>= fun x -> + tl >|= fun l -> x :: l diff --git a/mvar/sched_monad.mli b/mvar/sched_monad.mli index ea59e89..28b2eb5 100644 --- a/mvar/sched_monad.mli +++ b/mvar/sched_monad.mli @@ -1,16 +1,17 @@ type 'a t -val return : 'a -> 'a t -val (>>) : 'a t -> 'b t -> 'b t -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -val yield : unit t -val fork : unit t -> unit t -val run : unit t -> unit -val atom : (unit -> unit) -> unit t + +val return : 'a -> 'a t +val ( >> ) : 'a t -> 'b t -> 'b t +val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t +val yield : unit t +val fork : unit t -> unit t +val run : unit t -> unit +val atom : (unit -> unit) -> unit t type 'a cont type ready_cont -val prepare : 'a cont -> 'a -> ready_cont -val suspend : ('a cont -> (('a * ready_cont option) option)) -> 'a t +val prepare : 'a cont -> 'a -> ready_cont +val suspend : ('a cont -> ('a * ready_cont option) option) -> 'a t val iter_p : ('a -> unit t) -> 'a list -> unit t val map_p : ('a -> 'b t) -> 'a list -> 'b list t diff --git a/pipes.ml b/pipes.ml index fb7dde2..e952fc0 100644 --- a/pipes.ml +++ b/pipes.ml @@ -1,32 +1,38 @@ +open Effect (** Deep encoding of pipes. The example is adapted from Kammar et al. (2013) **) -open Effect + open Effect.Deep (* We specialise our pipes to work only with integers *) type _ Effect.t += Await : int Effect.t + let await () = perform Await type _ Effect.t += Yield : int -> unit Effect.t + let yield s = perform (Yield s) -type prod = Prod of (unit -> (cons -> unit)) -and cons = Cons of (int -> (prod -> unit)) +type prod = Prod of (unit -> cons -> unit) +and cons = Cons of (int -> prod -> unit) -let flip f = fun y x -> f x y +let flip f y x = f x y (* Parameterised handler that takes a consumer as parameter *) let up m = - match_with m () { - retc = (fun v -> fun _ -> v); - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield s -> Some (fun (k : (a, _) continuation) -> - fun (Cons cons) -> - cons s (Prod (fun () -> continue k ()))) - | _ -> None - } + match_with m () + { + retc = (fun v _ -> v); + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield s -> + Some + (fun (k : (a, _) continuation) (Cons cons) -> + cons s (Prod (fun () -> continue k ()))) + | _ -> None); + } (* Refine up to accept the parameter first rather than the computation. It's more convenient when combining handlers. *) @@ -34,68 +40,63 @@ let up = flip up (* Parameterised handler that takes a producer as parameter *) let down m = - match_with m () { - retc = (fun v -> fun _ -> v); - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | Await -> Some (fun (k : (a, _) continuation) -> - fun (Prod prod) -> - prod () (Cons (fun s -> continue k s))) - | _ -> None - } + match_with m () + { + retc = (fun v _ -> v); + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Await -> + Some + (fun (k : (a, _) continuation) (Prod prod) -> + prod () (Cons (fun s -> continue k s))) + | _ -> None); + } let down = flip down (** Some convenient combinators **) -let (<+<) d u = fun () -> down (Prod (fun () cons -> up cons u)) d -let (>+>) d u = u <+< d +let ( <+< ) d u () = down (Prod (fun () cons -> up cons u)) d +let ( >+> ) d u = u <+< d -(** Some producers and consumers **) (* Produces an infinite stream of integers starting from [n] *) -let rec produceFrom : int -> unit -> unit - = fun n () -> - yield n; - produceFrom (n+1) () + +(** Some producers and consumers **) +let rec produceFrom : int -> unit -> unit = + fun n () -> + yield n; + produceFrom (n + 1) () (* Accumulates elements from an integer stream until the sum is greater than or equal to [n]. Moreover, it produces a singleton integer stream *) -let sumTo : int -> (unit -> unit) = +let sumTo : int -> unit -> unit = let rec sumTo' acc lim = - if acc >= lim then - yield acc + if acc >= lim then yield acc else let x = await () in - sumTo' (acc+x) lim + sumTo' (acc + x) lim in fun n () -> sumTo' 0 n (* Skips [n] elements of an arbitrary stream *) -let rec skip : int -> (unit -> unit) = - fun n () -> - if n <= 0 then - ( yield (await ()) - ; skip 0 () ) - else - ( ignore (await ()) - ; skip (n-1) () ) +let rec skip : int -> unit -> unit = + fun n () -> + if n <= 0 then ( + yield (await ()); + skip 0 ()) + else ( + ignore (await ()); + skip (n - 1) ()) (* Prints a stream of integers *) -let rec printer : unit -> unit - = fun () -> - Printf.printf "%d\n" (await ()); - printer () +let rec printer : unit -> unit = + fun () -> + Printf.printf "%d\n" (await ()); + printer () (* Wiring everything together *) -let example = - produceFrom 0 - >+> - skip 99 - >+> - sumTo 100 - >+> - printer - +let example = produceFrom 0 >+> skip 99 >+> sumTo 100 >+> printer let _ = example () diff --git a/promises.ml b/promises.ml index 42a5525..8c0d0b2 100644 --- a/promises.ml +++ b/promises.ml @@ -3,131 +3,137 @@ open Effect.Deep module type Applicative = sig type 'a t - val pure : 'a -> 'a t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + + val pure : 'a -> 'a t + val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t end module type Promise = sig include Applicative - val fork : (unit -> 'a) -> 'a t - val get : 'a t -> ('a, exn) result + + val fork : (unit -> 'a) -> 'a t + val get : 'a t -> ('a, exn) result val get_val : 'a t -> 'a - val run : (unit -> 'a) -> ('a, exn) result + val run : (unit -> 'a) -> ('a, exn) result end module Promise : Promise = struct - - type cont = - | Cont : (unit, 'b) continuation -> cont - + type cont = Cont : (unit, 'b) continuation -> cont type tvar = cont option ref let mk_tvar k = ref (Some (Cont k)) - type 'a status = - | Done of 'a - | Cancelled of exn - | Waiting of tvar list - + type 'a status = Done of 'a | Cancelled of exn | Waiting of tvar list type 'a t = 'a status ref - type _ Effect.t += Fork : (unit -> 'a) -> 'a t Effect.t type _ Effect.t += Wait : 'a t -> unit Effect.t let fork f = perform (Fork f) - - let enqueue run_q k v = - Queue.push (fun () -> ignore @@ continue k v) run_q - - let dequeue run_q = - if Queue.is_empty run_q then () - else (Queue.pop run_q) () - + let enqueue run_q k v = Queue.push (fun () -> ignore @@ continue k v) run_q + let dequeue run_q = if Queue.is_empty run_q then () else (Queue.pop run_q) () let mk_status () = ref (Waiting []) let finish run_q sr v = match !sr with | Waiting l -> sr := Done v; - List.iter (fun tv -> - match !tv with - | None -> () - | Some (Cont k) -> - tv := None; - enqueue run_q k ()) l + List.iter + (fun tv -> + match !tv with + | None -> () + | Some (Cont k) -> + tv := None; + enqueue run_q k ()) + l | _ -> failwith "Impossible: finish" let abort run_q sr e = match !sr with | Waiting l -> sr := Cancelled e; - List.iter (fun tv -> - match !tv with - | None -> () - | Some (Cont k) -> - tv := None; - enqueue run_q k ()) l + List.iter + (fun tv -> + match !tv with + | None -> () + | Some (Cont k) -> + tv := None; + enqueue run_q k ()) + l | _ -> failwith "Impossible: abort" let wait sr k = match !sr with - | Waiting l -> sr := Waiting (mk_tvar k::l) + | Waiting l -> sr := Waiting (mk_tvar k :: l) | _ -> failwith "Impossible: wait" let rec get sr = match !sr with | Done v -> Ok v | Cancelled e -> Error e - | Waiting _ -> perform (Wait sr); get sr + | Waiting _ -> + perform (Wait sr); + get sr let rec get_val sr = match !sr with | Done v -> v | Cancelled e -> raise e - | Waiting _ -> perform (Wait sr); get_val sr + | Waiting _ -> + perform (Wait sr); + get_val sr let pure v = ref (Done v) - let rec (<*>) f g = - match !f, !g with - | Cancelled _ as x, _ -> ref x + let rec ( <*> ) f g = + match (!f, !g) with + | (Cancelled _ as x), _ -> ref x | _, (Cancelled _ as x) -> ref x - | Waiting _, _ -> - begin - perform (Wait f); - match get f with - | Ok f -> ref (Done f) <*> g - | Error e -> ref (Cancelled e) - end + | Waiting _, _ -> ( + perform (Wait f); + match get f with + | Ok f -> ref (Done f) <*> g + | Error e -> ref (Cancelled e)) | Done f, Done g -> ref (Done (f g)) - | Done f, Waiting _ -> - begin - perform (Wait g); - match get g with - | Ok g -> ref (Done (f g)) - | Error e -> ref (Cancelled e) - end + | Done f, Waiting _ -> ( + perform (Wait g); + match get g with + | Ok g -> ref (Done (f g)) + | Error e -> ref (Cancelled e)) let run main = let run_q = Queue.create () in let rec spawn : 'a. 'a status ref -> (unit -> 'a) -> unit = - fun sr f -> - match_with f () { - retc = (fun v -> finish run_q sr v; dequeue run_q); - exnc = (fun e -> abort run_q sr e; dequeue run_q); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Wait sr -> Some (fun (k : (a, _) continuation) -> wait sr k; dequeue run_q) - | Fork f -> Some (fun k -> - let sr = mk_status () in - enqueue run_q k sr; spawn sr f) - | _ -> None + fun sr f -> + match_with f () + { + retc = + (fun v -> + finish run_q sr v; + dequeue run_q); + exnc = + (fun e -> + abort run_q sr e; + dequeue run_q); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Wait sr -> + Some + (fun (k : (a, _) continuation) -> + wait sr k; + dequeue run_q) + | Fork f -> + Some + (fun k -> + let sr = mk_status () in + enqueue run_q k sr; + spawn sr f) + | _ -> None); } in let sr = mk_status () in spawn sr main; get sr - end open Promise @@ -136,7 +142,7 @@ open Printf let test1 () = let x = pure 10 in let y = pure 20 in - let z = pure (+) <*> x <*> y in + let z = pure ( + ) <*> x <*> y in get_val z let _ = @@ -145,9 +151,21 @@ let _ = | Error e -> Printf.printf "test2: error: %s\n" @@ Printexc.to_string e let test2 () = - let x = fork (fun () -> printf "test2: x\n%!"; 10) in - let y = fork (fun () -> printf "test2: y\n%!"; raise Exit) in - let z = fork (fun () -> printf "test2: z\n%!"; 20) in + let x = + fork (fun () -> + printf "test2: x\n%!"; + 10) + in + let y = + fork (fun () -> + printf "test2: y\n%!"; + raise Exit) + in + let z = + fork (fun () -> + printf "test2: z\n%!"; + 20) + in let add3 x y z = let _ = printf "test2: add %d %d %d\n" x y z in x + y + z diff --git a/ref.ml b/ref.ml index 84fffe4..22522c7 100644 --- a/ref.ml +++ b/ref.ml @@ -14,23 +14,22 @@ open Effect open Effect.Deep open State - (* --------------------------------------------------------------------------- *) (** Type Definitions. *) (* [REF] is the interface of dynamically allocated references. *) module type REF = sig type 'a t - val ref : 'a -> 'a t - val (!) : 'a t -> 'a - val (:=) : 'a t -> 'a -> unit - val run : (unit -> 'a) -> 'a + + val ref : 'a -> 'a t + val ( ! ) : 'a t -> 'a + val ( := ) : 'a t -> 'a -> unit + val run : (unit -> 'a) -> 'a end (* [HEAP] is the type of a functor that, given the implementation of a cell, implements dynamically allocated references. *) -module type HEAP = CELL -> REF - +module type HEAP = functor (_ : CELL) -> REF (* --------------------------------------------------------------------------- *) (** Heap Implementation Based on First-Class Modules. *) @@ -48,59 +47,74 @@ module type HEAP = CELL -> REF [get] and [set] obtained from a new instance of [Cell]. *) -module FCMBasedHeap : HEAP = functor (Cell : CELL) -> struct - (* [EFF] declares a pair of effect names [Get] and [Set]. *) - module type EFF = sig - type t - type _ Effect.t += Get : t Effect.t - type _ Effect.t += Set : t -> unit Effect.t - end - (* ['a t] is the type of first-class [EFF] modules. - The effect-name declarations in [EFF] become first-class. *) - type 'a t = (module EFF with type t = 'a) - - type _ Effect.t += Ref : 'a -> ('a t) Effect.t - - let ref init = perform (Ref init) - let (!) : type a. a t -> a = - fun (module E) -> perform E.Get - let (:=) : type a. a t -> a -> unit = - fun (module E) y -> perform (E.Set y) - - (* [fresh()] allocates fresh effect names [Get] and [Set], - and packs these names into a first-class module. *) - let fresh (type a) () : a t = - (module struct - type t = a +module FCMBasedHeap : HEAP = +functor + (Cell : CELL) + -> + struct + (* [EFF] declares a pair of effect names [Get] and [Set]. *) + module type EFF = sig + type t type _ Effect.t += Get : t Effect.t type _ Effect.t += Set : t -> unit Effect.t - end) - - let run main = - try_with main () { - effc = fun (type b) (e : b Effect.t) -> - match e with - | Ref init -> Some (fun (k : (b, _) continuation) -> - (init, k) |> fun (type a) ((init, k) : a * (a t, _) continuation) -> - let module E = (val (fresh() : a t)) in - let module C = Cell(struct type t = a end) in - let main() = - try_with (continue k) (module E) { - effc = fun (type c) (e : c Effect.t) -> - match e with - | E.Get -> Some (fun (k : (c, _) continuation) -> - continue k (C.get() : a)) - | E.Set y -> Some (fun k -> - continue k (C.set y)) - | _ -> None - } - in - snd (C.run ~init main) - ) - | _ -> None - } -end - + end + + (* ['a t] is the type of first-class [EFF] modules. + The effect-name declarations in [EFF] become first-class. *) + type 'a t = (module EFF with type t = 'a) + type _ Effect.t += Ref : 'a -> 'a t Effect.t + + let ref init = perform (Ref init) + let ( ! ) : type a. a t -> a = fun (module E) -> perform E.Get + + let ( := ) : type a. a t -> a -> unit = + fun (module E) y -> perform (E.Set y) + + (* [fresh()] allocates fresh effect names [Get] and [Set], + and packs these names into a first-class module. *) + let fresh (type a) () : a t = + (module struct + type t = a + type _ Effect.t += Get : t Effect.t + type _ Effect.t += Set : t -> unit Effect.t + end) + + let run main = + try_with main () + { + effc = + (fun (type b) (e : b Effect.t) -> + match e with + | Ref init -> + Some + (fun (k : (b, _) continuation) -> + (init, k) + |> + fun (type a) ((init, k) : a * (a t, _) continuation) -> + let module E = (val (fresh () : a t)) in + let module C = Cell (struct + type t = a + end) in + let main () = + try_with (continue k) + (module E) + { + effc = + (fun (type c) (e : c Effect.t) -> + match e with + | E.Get -> + Some + (fun (k : (c, _) continuation) -> + continue k (C.get () : a)) + | E.Set y -> + Some (fun k -> continue k (C.set y)) + | _ -> None); + } + in + snd (C.run ~init main)) + | _ -> None); + } + end (* --------------------------------------------------------------------------- *) (** Heap Implementation Based on Records. *) @@ -113,71 +127,75 @@ end by this new cell. *) -module RecordBasedHeap : HEAP = functor (Cell : CELL) -> struct - type 'a t = { - get : unit -> 'a; - set : 'a -> unit; - } - type _ Effect.t += Ref : 'a -> ('a t) Effect.t - - let ref init = perform (Ref init) - let (!) {get; _} = get() - let (:=) {set; _} y = set y - - let run main = - try_with main () { - effc = fun (type b) (e : b Effect.t) -> - match e with - | Ref init -> Some (fun (k : (b, _) continuation) -> - (init, k) |> fun (type a) ((init, k) : a * (a t, _) continuation) -> - let open Cell(struct type t = a end) in - snd (run ~init (fun _ -> continue k {get; set})) - ) - | _ -> None - } -end - +module RecordBasedHeap : HEAP = +functor + (Cell : CELL) + -> + struct + type 'a t = { get : unit -> 'a; set : 'a -> unit } + type _ Effect.t += Ref : 'a -> 'a t Effect.t + + let ref init = perform (Ref init) + let ( ! ) { get; _ } = get () + let ( := ) { set; _ } y = set y + + let run main = + try_with main () + { + effc = + (fun (type b) (e : b Effect.t) -> + match e with + | Ref init -> + Some + (fun (k : (b, _) continuation) -> + (init, k) + |> + fun (type a) ((init, k) : a * (a t, _) continuation) -> + let open Cell (struct + type t = a + end) in + snd (run ~init (fun _ -> continue k { get; set }))) + | _ -> None); + } + end (* --------------------------------------------------------------------------- *) (** Examples. *) open Printf -let _ = - printf "Opening module Ref...\n" - -let _ = - printf "Running tests...\n" - -let _ = - let heaps : (module REF) list = [ - (module FCMBasedHeap(StPassing)); - (module RecordBasedHeap(StPassing)); - (module FCMBasedHeap(LocalMutVar)); - (module RecordBasedHeap(LocalMutVar)); - (module FCMBasedHeap(GlobalMutVar)); - (module RecordBasedHeap(GlobalMutVar)) - ] in - - List.iter (fun heap -> - let open (val heap : REF) in - let main () = - let fibs = ref [] in - let a, b = ref 0, ref 1 in - for _i = 0 to 10 do - let fibsv, av, bv = !fibs, !a, !b in - fibs := av :: fibsv; - a := bv; - b := av + bv - done; - let fibsv, av, bv = !fibs, !a, !b in - assert (((List.hd fibsv), av, bv) = (55, 89, 144)) - in - run main - ) heaps - -let _ = - printf "End of tests.\n" +let _ = printf "Opening module Ref...\n" +let _ = printf "Running tests...\n" let _ = - printf "End of module Ref.\n" + let heaps : (module REF) list = + [ + (module FCMBasedHeap (StPassing)); + (module RecordBasedHeap (StPassing)); + (module FCMBasedHeap (LocalMutVar)); + (module RecordBasedHeap (LocalMutVar)); + (module FCMBasedHeap (GlobalMutVar)); + (module RecordBasedHeap (GlobalMutVar)); + ] + in + + List.iter + (fun heap -> + let open (val heap : REF) in + let main () = + let fibs = ref [] in + let a, b = (ref 0, ref 1) in + for _i = 0 to 10 do + let fibsv, av, bv = (!fibs, !a, !b) in + fibs := av :: fibsv; + a := bv; + b := av + bv + done; + let fibsv, av, bv = (!fibs, !a, !b) in + assert ((List.hd fibsv, av, bv) = (55, 89, 144)) + in + run main) + heaps + +let _ = printf "End of tests.\n" +let _ = printf "End of module Ref.\n" diff --git a/reify_reflect.ml b/reify_reflect.ml index b3fbd25..2da0cd2 100644 --- a/reify_reflect.ml +++ b/reify_reflect.ml @@ -4,49 +4,59 @@ open Effect open Effect.Deep (* The monad signature *) -module type MONAD = -sig +module type MONAD = sig type +_ t + val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t end (* Build reify and reflect operations for any monad *) -module RR(M: MONAD) : -sig +module RR (M : MONAD) : sig val reify : (unit -> 'a) -> 'a M.t val reflect : 'a M.t -> 'a -end = -struct +end = struct type _ Effect.t += E : 'a M.t -> 'a Effect.t - let reify f = match_with f () { - retc = (fun x -> M.return x); - exnc = raise; - effc = fun (type a) (e : a Effect.t) -> - match e with - | E m -> Some (fun k -> M.bind m (continue k)) - | _ -> None - } + + let reify f = + match_with f () + { + retc = (fun x -> M.return x); + exnc = raise; + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | E m -> Some (fun k -> M.bind m (continue k)) + | _ -> None); + } + let reflect m = perform (E m) end (* The state monad *) -module State = -struct +module State = struct type 'a t = int -> int * 'a + let return v s = (s, v) - let bind m k s = let s, a = m s in k a s + + let bind m k s = + let s, a = m s in + k a s + let get s = (s, s) let put s _ = (s, ()) let run s ~init = s init end (* Reify and reflect for State *) -module StateR = RR(State) +module StateR = RR (State) + (* val put : int -> unit State.t *) let put v = StateR.reflect (State.put v) + (* val get : unit -> int State.t *) let get () = StateR.reflect State.get + (* val run_state : (unit -> 'a) -> init:int -> 'a *) let run_state f ~init = let final, v = State.run (StateR.reify f) ~init in @@ -54,9 +64,9 @@ let run_state f ~init = v (* The exception monad *) -module Exception = -struct +module Exception = struct type 'a t = Ok of 'a | Exn of exn + let return v = Ok v let bind m k = match m with Ok v -> k v | Exn e -> Exn e let raise exn = Exn exn @@ -64,9 +74,11 @@ struct end (* Reify and reflect for Exception *) -module ExceptionR = RR(Exception) +module ExceptionR = RR (Exception) + (* val raise : exn -> 'a *) let raise e = ExceptionR.reflect (Exception.raise e) + (* val run_exception : (unit -> 'a) -> catch:(exn -> 'a) -> 'a *) let run_exception m ~catch = Exception.run (ExceptionR.reify m) ~catch @@ -94,8 +106,7 @@ let combined_example () = raise (Failure "An error!") |> ignore; put 200 -let print_exception e = - Printf.printf "Exception: %s\n" (Printexc.to_string e) +let print_exception e = Printf.printf "Exception: %s\n" (Printexc.to_string e) let () = run_state ~init:10 state_example |> ignore; @@ -104,16 +115,9 @@ let () = run_exception ~catch:print_exception exception_example; print_endline "========================================"; - begin - run_exception ~catch:print_exception @@ fun () -> - run_state ~init:10 @@ fun () -> - combined_example (); - end; + ( run_exception ~catch:print_exception @@ fun () -> + run_state ~init:10 @@ fun () -> combined_example () ); print_endline "========================================"; - begin - run_state ~init:10 @@ fun () -> - run_exception ~catch:print_exception @@ fun () -> - combined_example (); - end - + run_state ~init:10 @@ fun () -> + run_exception ~catch:print_exception @@ fun () -> combined_example () diff --git a/sched.ml b/sched.ml index 562edfd..40691ed 100644 --- a/sched.ml +++ b/sched.ml @@ -12,23 +12,31 @@ let run main = let run_q = Queue.create () in let enqueue k = Queue.push k run_q in let dequeue () = - if Queue.is_empty run_q then () - else continue (Queue.pop run_q) () + if Queue.is_empty run_q then () else continue (Queue.pop run_q) () in let rec spawn f = (* Effect handler => instantiates fiber *) - match_with f () { - retc = (fun () -> dequeue ()); - exnc = (fun e -> - print_string (Printexc.to_string e); - dequeue ()); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Yield -> - Some (fun (k : (a, unit) continuation) -> enqueue k; dequeue ()) - | Fork f -> - Some (fun (k : (a, unit) continuation) -> enqueue k; spawn f) - | _ -> None - } + match_with f () + { + retc = (fun () -> dequeue ()); + exnc = + (fun e -> + print_string (Printexc.to_string e); + dequeue ()); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Yield -> + Some + (fun (k : (a, unit) continuation) -> + enqueue k; + dequeue ()) + | Fork f -> + Some + (fun (k : (a, unit) continuation) -> + enqueue k; + spawn f) + | _ -> None); + } in spawn main diff --git a/sched.mli b/sched.mli index 5976ccd..bbcab18 100644 --- a/sched.mli +++ b/sched.mli @@ -1,5 +1,6 @@ (* Control operations on threads *) -val fork : (unit -> unit) -> unit +val fork : (unit -> unit) -> unit val yield : unit -> unit + (* Runs the scheduler. *) -val run : (unit -> unit) -> unit +val run : (unit -> unit) -> unit diff --git a/state.ml b/state.ml index 72700a6..7b62877 100644 --- a/state.ml +++ b/state.ml @@ -10,14 +10,13 @@ (3) [StPassing], a functional implementation in state-passing style. The stating-passing--style implementation comes from - + https://gist.github.com/kayceesrk/3c307d0340fbfc68435d4769ad447e10 . *) open Effect open Effect.Deep - (* --------------------------------------------------------------------------- *) (** Type Definitions. *) @@ -33,6 +32,7 @@ end *) module type STATE = sig type t + val get : unit -> t val set : t -> unit val run : init:t -> (unit -> 'a) -> t * 'a @@ -68,7 +68,6 @@ module type CELL = functor (T : TYPE) -> STATE with type t = T.t want to avoid types such as [cell -> (module REF)]). *) - (* --------------------------------------------------------------------------- *) (** Global State. *) @@ -95,22 +94,23 @@ module type CELL = functor (T : TYPE) -> STATE with type t = T.t instances are still ongoing. Moreover, accesses to [var] will suffer from race conditions. *) -module GlobalMutVar : CELL = functor (T : TYPE) -> struct - type t = T.t - - let var = ref None - - let get() = match !var with Some x -> x | None -> assert false - let set y = var := Some y - - let run ~init main = - set init |> fun _ -> - main() |> fun res -> - get() |> fun x -> - (var := None) |> fun _ -> - (x, res) -end - +module GlobalMutVar : CELL = +functor + (T : TYPE) + -> + struct + type t = T.t + + let var = ref None + let get () = match !var with Some x -> x | None -> assert false + let set y = var := Some y + + let run ~init main = + set init |> fun _ -> + main () |> fun res -> + get () |> fun x -> + (var := None) |> fun _ -> (x, res) + end (* --------------------------------------------------------------------------- *) (** Local State. *) @@ -136,30 +136,38 @@ end of [get] and [set], there is no interference among these instances, because effect names are immutable. *) -module LocalMutVar : CELL = functor (T : TYPE) -> struct - type t = T.t - type _ Effect.t += Get : t Effect.t - type _ Effect.t += Set : t -> unit Effect.t - - let get() = perform Get - let set y = perform (Set y) - - let run (type a) ~init main : t * a= - let var = ref init in - match_with main () { - retc = (fun res -> (!var, res)); - exnc = raise; - effc = fun (type b) (e : b Effect.t) -> - match e with - | Get -> Some (fun (k : (b, t * a) continuation) -> - continue k (!var : t)) - | Set y -> Some (fun k -> - var := y; - continue k ()) - | _ -> None - } -end - +module LocalMutVar : CELL = +functor + (T : TYPE) + -> + struct + type t = T.t + type _ Effect.t += Get : t Effect.t + type _ Effect.t += Set : t -> unit Effect.t + + let get () = perform Get + let set y = perform (Set y) + + let run (type a) ~init main : t * a = + let var = ref init in + match_with main () + { + retc = (fun res -> (!var, res)); + exnc = raise; + effc = + (fun (type b) (e : b Effect.t) -> + match e with + | Get -> + Some + (fun (k : (b, t * a) continuation) -> continue k (!var : t)) + | Set y -> + Some + (fun k -> + var := y; + continue k ()) + | _ -> None); + } + end (* --------------------------------------------------------------------------- *) (** State-Passing Style. *) @@ -186,63 +194,67 @@ end separate stacks are safe. The same remarks as for the functor [LocalMutVar] apply. *) -module StPassing : CELL = functor (T : TYPE) -> struct - type t = T.t - type _ Effect.t += Get : t Effect.t - type _ Effect.t += Set : t -> unit Effect.t - - let get() = perform Get - let set y = perform (Set y) - - let run (type a) ~init (main : unit -> a) : t * a = - match_with main () { - retc = (fun res x -> (x, res)); - exnc = raise; - effc = fun (type b) (e : b Effect.t) -> - match e with - | Get -> Some (fun (k : (b, t -> (t * a)) continuation) -> - fun (x : t) -> continue k x x) - | Set y -> Some (fun k -> - fun (_x : t) -> continue k () y) - | _ -> None - } init -end - +module StPassing : CELL = +functor + (T : TYPE) + -> + struct + type t = T.t + type _ Effect.t += Get : t Effect.t + type _ Effect.t += Set : t -> unit Effect.t + + let get () = perform Get + let set y = perform (Set y) + + let run (type a) ~init (main : unit -> a) : t * a = + match_with main () + { + retc = (fun res x -> (x, res)); + exnc = raise; + effc = + (fun (type b) (e : b Effect.t) -> + match e with + | Get -> + Some + (fun (k : (b, t -> t * a) continuation) (x : t) -> + continue k x x) + | Set y -> Some (fun k (_x : t) -> continue k () y) + | _ -> None); + } + init + end (* --------------------------------------------------------------------------- *) (** Examples. *) open Printf -let _ = - printf "Opening module State...\n" +let _ = printf "Opening module State...\n" -module IntCell = StPassing(struct type t = int end) -module StrCell = StPassing(struct type t = string end) +module IntCell = StPassing (struct + type t = int +end) -let main() : unit = +module StrCell = StPassing (struct + type t = string +end) + +let main () : unit = IntCell.( - printf "%d\n" (get()); + printf "%d\n" (get ()); set 42; - printf "%d\n" (get()); + printf "%d\n" (get ()); set 21; - printf "%d\n" (get()) - ); + printf "%d\n" (get ())); StrCell.( set "Hello..."; - printf "%s\n" (get()); + printf "%s\n" (get ()); set "...World!"; - printf "%s\n" (get ()) - ) + printf "%s\n" (get ())) let _ = printf "Running tests...\n"; - ignore ( - IntCell.run ~init:0 (fun () -> - StrCell.run ~init:"" main - ) - ); + ignore (IntCell.run ~init:0 (fun () -> StrCell.run ~init:"" main)); printf "End of tests.\n" -let _ = - printf "End of module State.\n" +let _ = printf "End of module State.\n" diff --git a/transaction.ml b/transaction.ml index 1b68120..5d4341f 100644 --- a/transaction.ml +++ b/transaction.ml @@ -6,52 +6,63 @@ type bottom module type TXN = sig type 'a t + val atomically : (unit -> unit) -> unit val ref : 'a -> 'a t - val (!) : 'a t -> 'a - val (:=) : 'a t -> 'a -> unit + val ( ! ) : 'a t -> 'a + val ( := ) : 'a t -> 'a -> unit end module Txn : TXN = struct type 'a t = 'a ref - type _ Effect.t += Update : 'a t * 'a -> unit Effect.t let atomically f = let comp = - match_with f () { - retc = (fun x -> fun _ -> x); - exnc = (fun e -> (fun rb -> rb (); raise e)); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Update (r, v) -> Some (fun (k : (a, _) continuation) -> (fun rb -> - let old_v = !r in - r := v; - continue k () (fun () -> r := old_v; rb ()))) - | _ -> None - } - in - comp (fun () -> ()) + match_with f () + { + retc = (fun x _ -> x); + exnc = + (fun e rb -> + rb (); + raise e); + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Update (r, v) -> + Some + (fun (k : (a, _) continuation) rb -> + let old_v = !r in + r := v; + continue k () (fun () -> + r := old_v; + rb ())) + | _ -> None); + } + in + comp (fun () -> ()) let ref = ref - let (!) = (!) - let (:=) = fun r v -> perform (Update (r,v)) + let ( ! ) = ( ! ) + let ( := ) r v = perform (Update (r, v)) end exception Res of int open Txn -let () = atomically (fun () -> - let r = ref 10 in - printf "T0: %d\n" (!r); - try atomically (fun () -> - r := 20; - r := 21; - printf "T1: Before abort %d\n" (!r); - raise (Res !r) |> ignore; - printf "T1: After abort %d\n" (!r); - r := 30) - with - | Res v -> printf "T0: T1 aborted with %d\n" v; - printf "T0: %d\n" !r) +let () = + atomically (fun () -> + let r = ref 10 in + printf "T0: %d\n" !r; + try + atomically (fun () -> + r := 20; + r := 21; + printf "T1: Before abort %d\n" !r; + raise (Res !r) |> ignore; + printf "T1: After abort %d\n" !r; + r := 30) + with Res v -> + printf "T0: T1 aborted with %d\n" v; + printf "T0: %d\n" !r)