From 4e53ac58e9e812ee2915dc39e0ef0db27116c8b7 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 18 Jun 2023 11:49:32 +0100 Subject: [PATCH 1/2] bring back the effect syntax Also fix the dynamic_state example which was disabled previously and hook it back into the Makefile --- .github/workflows/ci.yml | 3 +- Makefile | 2 +- README.md | 13 ++------ algorithmic_differentiation.ml | 37 +++++++++------------ dune | 4 +++ dyn_wind.ml | 31 ++++++++---------- dynamic_state.ml | 43 ++++++++++++++----------- eratosthenes.ml | 44 +++++++++++-------------- fringe.ml | 14 +++----- generator.ml | 20 ++++-------- loop.ml | 12 +++---- mvar/MVar.ml | 4 +-- mvar/MVar.mli | 4 +-- mvar/sched.ml | 8 ++--- mvar/sched.mli | 8 ++--- pipes.ml | 39 +++++++++------------- promises.ml | 23 ++++++------- ref.ml | 59 ++++++++++++---------------------- reify_reflect.ml | 13 +++----- sched.ml | 26 +++++++-------- state.ml | 29 +++++++---------- transaction.ml | 23 ++++++------- 22 files changed, 190 insertions(+), 269 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8c6cf63..609e676 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.3.0+trunk runs-on: ${{ matrix.os }} @@ -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 diff --git a/Makefile b/Makefile index ffd1a36..d489c3f 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ EXE := concurrent.exe ref.exe transaction.exe echo.exe \ dyn_wind.exe generator.exe promises.exe reify_reflect.exe \ MVar_test.exe chameneos.exe eratosthenes.exe pipes.exe loop.exe \ - fringe.exe algorithmic_differentiation.exe + fringe.exe algorithmic_differentiation.exe dynamic_state.exe all: $(EXE) diff --git a/README.md b/README.md index d7f7765..1ed87b0 100644 --- a/README.md +++ b/README.md @@ -37,22 +37,15 @@ The original implementation of Multicore OCaml allowed a user to `Obj.clone_cont ## Running the examples -To run the examples with Multicore OCaml, be sure to install [Opam with these instructions](https://opam.ocaml.org/doc/Install.html). If your version of Opam (`opam --version`) is greater than or equal to `2.1` then the following instructions will work: +To run the examples with OCaml, be sure to install [Opam with these instructions](https://opam.ocaml.org/doc/Install.html). ```bash -# After cloning this repository, create a 5.0.0 switch +# After cloning this repository, create a 5.1 switch opam update -# Add the alpha repository to get unreleased 5.0.0 compatible libraries -opam switch create 5.0.0+trunk --repo=default,alpha=git+https://github.com/kit-ty-kate/opam-alpha-repository.git +opam switch create 5.1.1 opam install . --deps-only ``` -If your version of Opam is less than `2.1`, then you will also need to add the beta repository when creating the switch. All of the other commands remain the same. - -``` -opam switch create 5.0.0+trunk --repo=default,beta=git+https://github.com/ocaml/ocaml-beta-repository.git,alpha=git+https://github.com/kit-ty-kate/opam-alpha-repository.git -``` - Running `make` will build all of the examples. If you want to run a single executable that is built with `dune` you can run: ``` diff --git a/algorithmic_differentiation.ml b/algorithmic_differentiation.ml index 1a71d94..496f22f 100644 --- a/algorithmic_differentiation.ml +++ b/algorithmic_differentiation.ml @@ -16,29 +16,24 @@ end = struct 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 + type _ eff += Add : t * t -> t eff + type _ eff += Mult : t * t -> t eff 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 f () with + | r -> r.d <- 1.0; r; + | effect (Add(a,b)), k -> + 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 + | effect (Mult(a,b)), 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) let grad f x = let x = mk x in diff --git a/dune b/dune index 0a7f305..8259f4d 100644 --- a/dune +++ b/dune @@ -18,6 +18,10 @@ (names dyn_wind) (modules dyn_wind)) +(executables + (names dynamic_state) + (modules dynamic_state)) + (executables (names generator) (modules generator)) diff --git a/dyn_wind.ml b/dyn_wind.ml index 22df9f4..5d63f8c 100644 --- a/dyn_wind.ml +++ b/dyn_wind.ml @@ -6,32 +6,27 @@ 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 thunk () with + | v -> v + | exception e -> after_thunk (); raise e + | effect e, k -> + after_thunk (); + let res' = perform e in + before_thunk (); + continue k res' in after_thunk (); res -type _ Effect.t += E : unit Effect.t +type _ eff += E : unit eff 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 "perform E\n"; perform E; + Printf.printf "perform 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 } + try dynamic_wind bt foo at with + | effect E, k -> Printf.printf "handled E\n"; continue k () diff --git a/dynamic_state.ml b/dynamic_state.ml index d438601..80ba2bf 100644 --- a/dynamic_state.ml +++ b/dynamic_state.ml @@ -1,3 +1,6 @@ +open Effect +open Effect.Deep + (* This file contains a collection of attempts at replicating ML-style references using algebraic effects and handlers. The difficult thing to do is the dynamic creation of new reference cells at arbitrary @@ -9,16 +12,16 @@ module Int = struct type t = int let compare = compare end module LocalState (R : sig type t end) = struct type reff = R.t - effect New : int -> R.t - effect Get : R.t -> int - effect Put : R.t * int -> unit + type _ eff += New : int -> R.t eff + type _ eff += Get : R.t -> int eff + type _ eff += Put : R.t * int -> unit eff end module type StateOps = sig - type rEffect.t - effect New : int -> rEffect.t - effect Get : reff -> int - effect Put : reff * int -> unit + type reff + type _ eff += New : int -> reff eff + type _ eff += Get : reff -> int eff + type _ eff += Put : reff * int -> unit eff end (**********************************************************************) @@ -31,12 +34,12 @@ let run main = let module IM = Map.Make (Int) in let comp = match main (module Int : Type) with - | effect (S.New i) k -> + | effect (S.New i), k -> fun s -> let r = fst (IM.max_binding s) + 1 in continue k r (IM.add r i s) - | effect (S.Get r) k -> + | effect (S.Get r), k -> fun s -> continue k (IM.find r s) s - | effect (S.Put (r, i)) k -> + | effect (S.Put (r, i)), k -> fun s -> continue k () (IM.add r i s) | x -> fun s -> x in @@ -57,13 +60,13 @@ let run2 main = let module IM = Map.Make (Int) in let comp = match main (module S : StateOps) with - | effect (S.New i) k -> + | effect (S.New i), k -> fun s -> let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1 in continue k r (IM.add r i s) - | effect (S.Get r) k -> + | effect (S.Get r), k -> fun s -> continue k (IM.find r s) s - | effect (S.Put (r, i)) k -> + | effect (S.Put (r, i)), k -> fun s -> continue k () (IM.add r i s) | x -> fun s -> x in @@ -80,23 +83,23 @@ let main2 (module S : StateOps) = handlers. Similar to the example in "state.ml". *) module type GetPutOps = sig type t - effect Get : t - effect Put : t -> unit + type _ eff += Get : t eff + type _ eff += Put : t -> unit eff end module MakeGetPut (T : sig type t end) () = struct type t = T.t - effect Get : t - effect Put : t -> unit + type _ eff += Get : t eff + type _ eff += Put : t -> unit eff end let run3 (type a) (module S : GetPutOps with type t = a) (s : a) main = let module IM = Map.Make (Int) in let comp = match main () with - | effect S.Get k -> + | effect S.Get, k -> fun (s : S.t) -> continue k s s - | effect (S.Put i) k -> + | effect (S.Put i), k -> fun s -> continue k () i | x -> fun s -> x in @@ -111,6 +114,7 @@ let test3 () = perform (S2.Put (string_of_int x ^ "xx")); perform S2.Get +(* XXX avsm: disabled pending port to multicont (uses clone_continuation) (**********************************************************************) (* version 4. Uses dynamic creation of new effect names to simulate @@ -174,3 +178,4 @@ let test4 () = end else print_endline !b +*) diff --git a/eratosthenes.ml b/eratosthenes.ml index e7c596c..cb10f0e 100644 --- a/eratosthenes.ml +++ b/eratosthenes.ml @@ -12,19 +12,19 @@ let string_of_msg = function (** Process primitives **) type pid = int -type _ Effect.t += Spawn : (pid -> unit) -> pid Effect.t +type _ eff += Spawn : (pid -> unit) -> pid eff let spawn p = perform (Spawn p) -type _ Effect.t += Yield : unit Effect.t +type _ eff += Yield : unit eff let yield () = perform Yield (** Communication primitives **) -type _ Effect.t += Send : pid * message -> unit Effect.t +type _ eff += Send : pid * message -> unit eff let send pid data = perform (Send (pid, data)); yield () -type _ Effect.t += Recv : pid -> message option Effect.t +type _ eff += Recv : pid -> message option eff let rec recv pid = match perform (Recv pid) with | Some m -> m @@ -74,17 +74,14 @@ let mailbox f = 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 - } + match f () with + | v -> v + | effect (Send (pid, msg)), k -> + mailbox := Mailbox.push pid msg !mailbox; + continue k () + | effect (Recv who), k -> + let msg = lookup who in + continue k msg (** Process handler Slightly modified version of sched.ml **) @@ -98,17 +95,12 @@ let run main () = 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 f !pid with + | () -> dequeue () + | effect Yield, k -> + enqueue (fun () -> continue k ()); dequeue () + | effect (Spawn p), k -> + enqueue (fun () -> continue k !pid); spawn p in spawn main diff --git a/fringe.ml b/fringe.ml index bf925d6..77079b9 100644 --- a/fringe.ml +++ b/fringe.ml @@ -25,7 +25,8 @@ module SameFringe(E : EQUATABLE) = struct type nonrec tree = E.t tree (* Yielding control *) - type _ Effect.t += Yield : E.t -> unit Effect.t + type _ eff += Yield : E.t -> unit eff + let yield e = perform (Yield e) (* The walk routine *) @@ -41,14 +42,9 @@ module SameFringe(E : EQUATABLE) = struct (* 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 f () with + | _ -> Done + | effect Yield e, k -> Yielded (e, k) (* The comparator "step walks" two given trees simultaneously *) let comparator ltree rtree = diff --git a/generator.ml b/generator.ml index 714ff24..03198a4 100644 --- a/generator.ml +++ b/generator.ml @@ -53,21 +53,15 @@ module Tree : TREE = struct (* val to_gen : 'a t -> (unit -> 'a option) *) let to_gen (type a) (t : a t) = - let module M = struct - type _ Effect.t += Next : a -> unit Effect.t - end in + let module M = struct type _ eff += Next : a -> unit eff 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 }) + try + iter (fun x -> perform (Next x)) t; + None + with effect (Next v), k -> + step := (fun () -> continue k ()); + Some v) in fun () -> !step () diff --git a/loop.ml b/loop.ml index 17e78af..003ada9 100644 --- a/loop.ml +++ b/loop.ml @@ -1,14 +1,12 @@ open Effect open Effect.Deep -type _ Effect.t += Foo : (unit -> 'a) Effect.t +type _ eff += Foo : (unit -> 'a) eff 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 - } + match f () with + | x -> x + | effect Foo, k -> + continue k (fun () -> perform Foo ()) diff --git a/mvar/MVar.ml b/mvar/MVar.ml index 9e34890..ce51641 100644 --- a/mvar/MVar.ml +++ b/mvar/MVar.ml @@ -8,8 +8,8 @@ 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 _ eff += Suspend : ('a cont -> unit) -> 'a eff + type _ eff += Resume : 'a cont * 'a -> unit eff end module Make (S : SCHED) : S = struct diff --git a/mvar/MVar.mli b/mvar/MVar.mli index 06930e2..53fc2ac 100644 --- a/mvar/MVar.mli +++ b/mvar/MVar.mli @@ -22,12 +22,12 @@ 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 + type _ eff += Suspend : ('a cont -> unit) -> 'a eff (** [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 + type _ eff += Resume : 'a cont * 'a -> unit eff (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and enqueues it to the scheduler queue. *) end diff --git a/mvar/sched.ml b/mvar/sched.ml index 257f62c..14c9466 100644 --- a/mvar/sched.ml +++ b/mvar/sched.ml @@ -1,12 +1,12 @@ open Effect open Effect.Deep -type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t -type _ Effect.t += Yield : unit Effect.t +type _ eff += Fork : (unit -> unit) -> unit eff +type _ eff += Yield : unit eff 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 _ eff += Suspend : ('a cont -> unit) -> 'a eff +type _ eff += Resume : 'a cont * 'a -> unit eff let run main = let run_q = Queue.create () in diff --git a/mvar/sched.mli b/mvar/sched.mli index 02028d4..a6e98a7 100644 --- a/mvar/sched.mli +++ b/mvar/sched.mli @@ -1,19 +1,19 @@ 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 +type _ eff += Suspend : ('a cont -> unit) -> 'a eff (** [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 +type _ eff += Resume : 'a cont * 'a -> unit eff (** [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 +type _ eff += Fork : (unit -> unit) -> unit eff (** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) -type _ Effect.t += Yield : unit Effect.t +type _ eff += Yield : unit eff (** [perform Yield] suspends the current thread and switches to the next thread from the run queue. *) diff --git a/pipes.ml b/pipes.ml index fb7dde2..02a85f9 100644 --- a/pipes.ml +++ b/pipes.ml @@ -1,13 +1,14 @@ -(** Deep encoding of pipes. - The example is adapted from Kammar et al. (2013) **) open Effect open Effect.Deep +(** Deep encoding of pipes. + The example is adapted from Kammar et al. (2013) **) + (* We specialise our pipes to work only with integers *) -type _ Effect.t += Await : int Effect.t +type _ eff += Await : int eff let await () = perform Await -type _ Effect.t += Yield : int -> unit Effect.t +type _ eff += Yield : int -> unit eff let yield s = perform (Yield s) type prod = Prod of (unit -> (cons -> unit)) @@ -17,16 +18,11 @@ let flip f = fun 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 m () with + | v -> fun _ -> v + | effect (Yield s), k -> + fun (Cons cons) -> + cons s (Prod (fun () -> continue k ())) (* Refine up to accept the parameter first rather than the computation. It's more convenient when combining handlers. *) @@ -34,16 +30,11 @@ 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 m () with + | v -> fun _ -> v + | effect Await, k -> + fun (Prod prod) -> + prod () (Cons (fun s -> continue k s)) let down = flip down diff --git a/promises.ml b/promises.ml index 42a5525..43cfd41 100644 --- a/promises.ml +++ b/promises.ml @@ -31,8 +31,9 @@ module Promise : Promise = struct 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 + type _ eff += + | Fork : (unit -> 'a) -> 'a t eff + | Wait : 'a t -> unit eff let fork f = perform (Fork f) @@ -112,17 +113,13 @@ module Promise : Promise = struct 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 - } + match f () with + | v -> finish run_q sr v; dequeue run_q + | exception e -> abort run_q sr e; dequeue run_q + | effect (Wait sr), k -> wait sr k; dequeue run_q + | effect (Fork f), k -> + let sr = mk_status () in + enqueue run_q k sr; spawn sr f in let sr = mk_status () in spawn sr main; diff --git a/ref.ml b/ref.ml index 84fffe4..3b727c3 100644 --- a/ref.ml +++ b/ref.ml @@ -52,14 +52,13 @@ 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 + type _ eff += Get : t eff | Set : t -> unit eff 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 + type _ eff += Ref : 'a -> ('a t) eff let ref init = perform (Ref init) let (!) : type a. a t -> a = @@ -72,33 +71,22 @@ module FCMBasedHeap : HEAP = functor (Cell : CELL) -> struct 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 + type _ eff += Get : t eff | Set : t -> unit eff 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 - } + try main () with + effect (Ref init), k -> + (* trick to name the existential type introduced by the matching: *) + (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 continue k (module E) with + | effect E.Get, k -> continue k (C.get() : a) + | effect (E.Set y), k -> continue k (C.set y) + in + snd (C.run ~init main) end @@ -118,23 +106,18 @@ module RecordBasedHeap : HEAP = functor (Cell : CELL) -> struct get : unit -> 'a; set : 'a -> unit; } - type _ Effect.t += Ref : 'a -> ('a t) Effect.t + type _ eff += Ref : 'a -> 'a t eff 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 - } + try main () with + | effect (Ref init), k -> + (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})) end diff --git a/reify_reflect.ml b/reify_reflect.ml index b3fbd25..10b7a26 100644 --- a/reify_reflect.ml +++ b/reify_reflect.ml @@ -18,15 +18,10 @@ sig val reflect : 'a M.t -> 'a 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 - } + type _ eff += E : 'a M.t -> 'a eff + let reify f = match f () with + x -> M.return x + | effect (E m), k -> M.bind m (continue k) let reflect m = perform (E m) end diff --git a/sched.ml b/sched.ml index 562edfd..528103b 100644 --- a/sched.ml +++ b/sched.ml @@ -1,8 +1,8 @@ open Effect open Effect.Deep -type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t -type _ Effect.t += Yield : unit Effect.t +type _ eff += Fork : (unit -> unit) -> unit eff +type _ eff += Yield : unit eff let fork f = perform (Fork f) let yield () = perform Yield @@ -17,18 +17,14 @@ let run main = 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 f () with + | () -> dequeue () + | exception e -> + ( print_string (Printexc.to_string e); + dequeue () ) + | effect Yield, k -> + ( enqueue k; dequeue () ) + | effect (Fork f), k -> + ( enqueue k; spawn f ) in spawn main diff --git a/state.ml b/state.ml index 72700a6..cc00645 100644 --- a/state.ml +++ b/state.ml @@ -138,26 +138,17 @@ 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 + type _ eff += Get : t eff | Set : t -> unit eff - let get() = perform Get + 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 - } + match main () with + | res -> !var, res + | effect Get, k -> continue k (!var : t) + | effect (Set y), k -> var := y; continue k () end @@ -188,13 +179,15 @@ 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 + type _ eff += Get : t eff | Set : t -> unit eff - let get() = perform Get + let get () = perform Get let set y = perform (Set y) let run (type a) ~init (main : unit -> a) : t * a = + (* In this case the lower-level syntax is less verbose + since we have to rebind the existentials anyway if using + the concrete effect syntax. *) match_with main () { retc = (fun res x -> (x, res)); exnc = raise; diff --git a/transaction.ml b/transaction.ml index 1b68120..0a2416e 100644 --- a/transaction.ml +++ b/transaction.ml @@ -15,23 +15,18 @@ end module Txn : TXN = struct type 'a t = 'a ref - type _ Effect.t += Update : 'a t * 'a -> unit Effect.t + type _ eff += Update : 'a t * 'a -> unit eff 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 f () with + | x -> (fun _ -> x) + | exception e -> (fun rb -> rb (); raise e) + | effect (Update (r,v)), k -> (fun rb -> + let old_v = !r in + r := v; + continue k () (fun () -> r := old_v; rb ())) + in comp (fun () -> ()) let ref = ref let (!) = (!) From d0ef0438876f4e094f27e3aca6bdedfba5463e13 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Tue, 7 May 2024 14:53:34 +0100 Subject: [PATCH 2/2] ocamlformat --- .ocamlformat | 2 +- mvar/MVar.mli | 10 ++++++---- mvar/sched.ml | 3 +-- mvar/sched.mli | 20 ++++++++++++-------- 4 files changed, 20 insertions(+), 15 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 0b240ee..0b457a3 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,2 @@ profile = default -version = 0.26.0 \ No newline at end of file +version = 0.26.2 diff --git a/mvar/MVar.mli b/mvar/MVar.mli index 45b8720..e948192 100644 --- a/mvar/MVar.mli +++ b/mvar/MVar.mli @@ -22,13 +22,15 @@ module type SCHED = sig type 'a cont (** Represents a blocked computation that waits for a value of type 'a. *) - type _ eff += Suspend : ('a cont -> unit) -> 'a eff - (** [perform @@ Suspend f] applies [f] to the current continuation, and suspends the + type _ eff += + | Suspend : ('a cont -> unit) -> 'a eff + (** [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 _ eff += Resume : 'a cont * 'a -> unit eff - (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and + type _ eff += + | Resume : 'a cont * 'a -> unit eff + (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and enqueues it to the scheduler queue. *) end diff --git a/mvar/sched.ml b/mvar/sched.ml index 83447e5..dc29a59 100644 --- a/mvar/sched.ml +++ b/mvar/sched.ml @@ -3,8 +3,7 @@ open Effect.Deep type _ eff += Fork : (unit -> unit) -> unit eff type _ eff += Yield : unit eff - -type 'a cont = ('a,unit) continuation +type 'a cont = ('a, unit) continuation type _ eff += Suspend : ('a cont -> unit) -> 'a eff type _ eff += Resume : 'a cont * 'a -> unit eff diff --git a/mvar/sched.mli b/mvar/sched.mli index a6e98a7..80476c9 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 _ eff += Suspend : ('a cont -> unit) -> 'a eff -(** [Perform @@ Suspend f] applies [f] to the current continuation, and suspends the +type _ eff += + | Suspend : ('a cont -> unit) -> 'a eff + (** [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 _ eff += Resume : 'a cont * 'a -> unit eff -(** [perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and +type _ eff += + | Resume : 'a cont * 'a -> unit eff + (** [perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and enqueues it to the scheduler queue. *) -type _ eff += Fork : (unit -> unit) -> unit eff -(** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) +type _ eff += + | Fork : (unit -> unit) -> unit eff + (** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) -type _ eff += Yield : unit eff -(** [perform Yield] suspends the current thread and switches to the next thread from +type _ eff += + | Yield : unit eff + (** [perform Yield] suspends the current thread and switches to the next thread from the run queue. *) val run : (unit -> unit) -> unit