├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .ocamlformat ├── LICENSE ├── Makefile ├── README.md ├── aio ├── aio.ml ├── aio.mli ├── dune └── echo.ml ├── algorithmic_differentiation.ml ├── callbacks ├── bar.ml ├── bar.mli ├── dune └── foo.c ├── concurrent.ml ├── dune ├── dune-project ├── dyn_wind.ml ├── dynamic_state.ml ├── effects-examples.opam ├── eratosthenes.ml ├── fringe.ml ├── generator.ml ├── loop.ml ├── multishot ├── clone_is_tricky.ml ├── delimcc.ml ├── delimcc_paper_example.ml ├── dune ├── dynamic_state.ml ├── memo.ml ├── nim.ml ├── nondeterminism.ml └── queens.ml ├── mvar ├── MVar.ml ├── MVar.mli ├── MVar_monad.ml ├── MVar_monad.mli ├── MVar_test.ml ├── Makefile ├── chameneos.hs ├── chameneos.ml ├── chameneos_lwt.ml ├── chameneos_monad.ml ├── chameneos_systhr.ml ├── concurrent_monad.ml ├── dune ├── sched.ml ├── sched.mli ├── sched_monad.ml └── sched_monad.mli ├── pipes.ml ├── promises.ml ├── ref.ml ├── reify_reflect.ml ├── sched.ml ├── sched.mli ├── state.ml └── transaction.ml /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: main 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | - macos-latest 17 | ocaml-compiler: 18 | - ocaml-variants.5.3.0+trunk 19 | 20 | runs-on: ${{ matrix.os }} 21 | 22 | steps: 23 | - name: Checkout code 24 | uses: actions/checkout@v2 25 | 26 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 27 | uses: ocaml/setup-ocaml@v2 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 30 | opam-repositories: | 31 | default: https://github.com/ocaml/opam-repository.git 32 | opam-depext: false 33 | 34 | - run: opam install . --deps-only --with-test 35 | 36 | - run: opam exec -- dune build 37 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # merlin files 23 | .merlin 24 | *~ 25 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.26.2 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, KC Sivaramakrishnan 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | EXE := concurrent.exe ref.exe transaction.exe echo.exe \ 2 | dyn_wind.exe generator.exe promises.exe reify_reflect.exe \ 3 | MVar_test.exe chameneos.exe eratosthenes.exe pipes.exe loop.exe \ 4 | fringe.exe algorithmic_differentiation.exe dynamic_state.exe 5 | 6 | all: $(EXE) 7 | 8 | concurrent.exe: sched.mli sched.ml concurrent.ml 9 | dune build concurrent.exe 10 | 11 | ref.exe: state.ml ref.ml 12 | dune build ref.exe 13 | 14 | echo.exe: aio/aio.mli aio/aio.ml aio/echo.ml 15 | dune build aio/echo.exe 16 | 17 | MVar_test.exe: mvar/MVar_test.ml 18 | dune build mvar/MVar_test.exe 19 | 20 | chameneos.exe: mvar/chameneos.ml 21 | dune build mvar/chameneos.exe 22 | 23 | chameneos_systhr.exe: mvar/chameneos_systhr.ml 24 | dune build mvar/chameneos_systhr.exe 25 | 26 | chameneos_lwt.exe: mvar/chameneos_lwt.ml 27 | dune build mvar/chameneos_lwt.exe 28 | 29 | chameneos_monad.exe: mvar/chameneos_monad.ml 30 | dune build mvar/chameneos_monad.exe 31 | 32 | chameneos-ghc.exe: mvar/chameneos.hs 33 | ghc -o mvar/chameneos-ghc.exe -cpp -XBangPatterns -XScopedTypeVariables \ 34 | -XGeneralizedNewtypeDeriving mvar/chameneos.hs 35 | 36 | callback: 37 | dune build callbacks/callback 38 | 39 | %.exe: %.ml 40 | dune build $@ 41 | 42 | clean: 43 | dune clean 44 | rm -f mvar/*.exe mvar/*.o mvar/*.hi mvar/dune-project 45 | rm -f *.exe 46 | rm -rf aio/dune-project 47 | 48 | .PHONY: clean 49 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml effects examples 2 | 3 | [![Build Status](https://github.com/ocaml-multicore/effects-examples/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/ocaml-multicore/effects-examples/actions/workflows/ci.yml) 4 | 5 | Examples to illustrate the use of algebraic effects in OCaml. See 6 | * [Effective Concurrency with Algebraic Effects](http://kcsrk.info/ocaml/multicore/2015/05/20/effects-multicore/) 7 | * [Pearls of Algebraic Effects and Handlers](http://kcsrk.info/ocaml/multicore/effects/2015/05/27/more-effects/) 8 | * [Retrofitting Effect Handlers onto OCaml](https://dl.acm.org/doi/10.1145/3453483.3454039) 9 | 10 | ## Examples 11 | 12 | * [A concurrent round-robin scheduler](https://github.com/ocaml-multicore/effects-examples/blob/master/sched.ml) 13 | * [Mutable state](https://github.com/ocaml-multicore/effects-examples/blob/master/state.ml) 14 | * [ML-style refs](https://github.com/ocaml-multicore/effects-examples/blob/master/ref.ml) 15 | * [Transactional state](https://github.com/ocaml-multicore/effects-examples/blob/master/transaction.ml) 16 | * [Asynchronous IO in direct-style](https://github.com/ocaml-multicore/effects-examples/blob/master/aio) 17 | * [Dynamic wind](https://github.com/ocaml-multicore/effects-examples/blob/master/dyn_wind.ml) 18 | * [Deriving generator from any interator](https://github.com/ocaml-multicore/effects-examples/blob/master/generator.ml) 19 | * [Promises](https://github.com/ocaml-multicore/effects-examples/blob/master/promises.ml) 20 | * [Monadic reflection](https://github.com/ocaml-multicore/effects-examples/blob/master/reify_reflect.ml) 21 | * [MVars](https://github.com/ocaml-multicore/effects-examples/blob/master/mvar/MVar.ml) 22 | * [Chameneos-redux](https://github.com/ocaml-multicore/effects-examples/blob/master/mvar/chameneos.ml) 23 | * [Message-passing pipeline: Sieve of Eratostheneses](https://github.com/ocaml-multicore/effects-examples/blob/master/eratosthenes.ml) 24 | * [Deep pipes](https://github.com/ocaml-multicore/effects-examples/blob/master/pipes.ml) 25 | * [Non termination from effects](https://github.com/ocaml-multicore/effects-examples/blob/master/loop.ml) 26 | * [Continuation cloning is tricky](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/clone_is_tricky.ml) 27 | * [A solution to the Same Fringe Problem](https://github.com/ocaml-multicore/effects-examples/blob/master/fringe.ml) 28 | * [Reverse-mode Algorithmic Differentiation](https://github.com/ocaml-multicore/effects-examples/blob/master/algorithmic_differentiation.ml) 29 | 30 | The original implementation of Multicore OCaml allowed a user to `Obj.clone_continuation`. This has been removed, the examples that used this are in the `multishot` directory. [See this conversation about the removal of this feature](https://discuss.ocaml.org/t/multi-shot-continuations-gone-forever/9072). They now use the [ocaml-multicont](https://github.com/dhil/ocaml-multicont) library. 31 | 32 | * [Delimcc encoding](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/delimcc.ml) 33 | * [Nondeterminism](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/nondeterminism.ml) 34 | * [Backtracking N-Queens](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/queens.ml) 35 | * [Memoization](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/memo.ml) 36 | * [A mathematical game: Nim](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/nim.ml) 37 | * [Dynamic State](https://github.com/ocaml-multicore/effects-examples/blob/master/multishot/dynamic_state.ml) 38 | 39 | ## Running the examples 40 | 41 | To run the examples with OCaml, be sure to install [Opam with these instructions](https://opam.ocaml.org/doc/Install.html). These examples use the new effect syntax introduced with OCaml 5.3 and onwards. If you wish to see the examples which used the underlying effect functions directly, please checkout the `5.1.1` tag of this repository instead. 42 | 43 | ```bash 44 | # After cloning this repository, create a 5.3 switch 45 | opam update 46 | opam switch create 5.3.0+trunk 47 | opam install . --deps-only 48 | ``` 49 | 50 | Running `make` will build all of the examples. If you want to run a single executable that is built with `dune` you can run: 51 | 52 | ``` 53 | $ dune exec -- ./.exe 54 | ``` 55 | 56 | ## External examples 57 | 58 | These are other examples that utilise OCaml effect handlers that are not in this repo: 59 | 60 | * [Reactive UI and animation](https://gopiandcode.uk/logs/log-bye-bye-monads-algebraic-effects.html) 61 | * [Probabilisitic Programming](https://github.com/Arnhav-Datar/EffPPL) 62 | + and the [project report](https://github.com/Arnhav-Datar/EffPPL/blob/main/reports/final_report/EffPPL_Report.pdf) 63 | 64 | ## Citation 65 | 66 | If you are citing this work in an academic paper, please cite the PLDI 2021 paper "Retrofitting Effect Handlers onto OCaml": https://dl.acm.org/doi/10.1145/3453483.3454039. 67 | -------------------------------------------------------------------------------- /aio/aio.ml: -------------------------------------------------------------------------------- 1 | (* Asynchronous IO scheduler. 2 | * 3 | * For each blocking action, if the action can be performed immediately, then it 4 | * is. Otherwise, the thread performing the blocking task is suspended and 5 | * automatically wakes up when the action completes. The suspend/resume is 6 | * transparent to the programmer. 7 | *) 8 | open Effect 9 | open Effect.Deep 10 | 11 | type file_descr = Unix.file_descr 12 | type sockaddr = Unix.sockaddr 13 | type msg_flag = Unix.msg_flag 14 | type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t 15 | type _ Effect.t += Accept : file_descr -> (file_descr * sockaddr) Effect.t 16 | 17 | type _ Effect.t += 18 | | Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t 19 | 20 | type _ Effect.t += 21 | | Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t 22 | 23 | type _ Effect.t += Sleep : float -> unit Effect.t 24 | 25 | let fork f = perform (Fork f) 26 | let accept fd = perform (Accept fd) 27 | let recv fd buf pos len mode = perform (Recv (fd, buf, pos, len, mode)) 28 | let send fd bus pos len mode = perform (Send (fd, bus, pos, len, mode)) 29 | let sleep timeout = perform (Sleep timeout) 30 | 31 | (** Poll to see if the file descriptor is available to read. *) 32 | let poll_rd fd = 33 | let r, _, _ = Unix.select [ fd ] [] [] 0. in 34 | match r with [] -> false | _ -> true 35 | 36 | (** Poll to see if the file descriptor is available to write. *) 37 | let poll_wr fd = 38 | let _, r, _ = Unix.select [] [ fd ] [] 0. in 39 | match r with [] -> false | _ -> true 40 | 41 | type read = 42 | | Accept of (file_descr * sockaddr, unit) continuation 43 | | Recv of bytes * int * int * msg_flag list * (int, unit) continuation 44 | 45 | type write = 46 | | Send of bytes * int * int * msg_flag list * (int, unit) continuation 47 | 48 | type timeout = Sleep of (unit, unit) continuation 49 | 50 | type runnable = 51 | | Thread : ('a, unit) continuation * 'a -> runnable 52 | | Read : file_descr * read -> runnable 53 | | Write : file_descr * write -> runnable 54 | 55 | type state = { 56 | run_q : runnable Queue.t; 57 | read_ht : (file_descr, read) Hashtbl.t; 58 | write_ht : (file_descr, write) Hashtbl.t; 59 | sleep_ht : (float, timeout) Hashtbl.t; 60 | } 61 | 62 | let init () = 63 | { 64 | run_q = Queue.create (); 65 | read_ht = Hashtbl.create 13; 66 | write_ht = Hashtbl.create 13; 67 | sleep_ht = Hashtbl.create 13; 68 | } 69 | 70 | let enqueue_thread st k x = Queue.push (Thread (k, x)) st.run_q 71 | let enqueue_read st fd op = Queue.push (Read (fd, op)) st.run_q 72 | let enqueue_write st fd op = Queue.push (Write (fd, op)) st.run_q 73 | 74 | let dequeue st = 75 | match Queue.pop st.run_q with 76 | | Thread (k, x) -> continue k x 77 | | Read (fd, Accept k) -> 78 | let res = Unix.accept fd in 79 | continue k res 80 | | Read (fd, Recv (buf, pos, len, mode, k)) -> 81 | let res = Unix.recv fd buf pos len mode in 82 | continue k res 83 | | Write (fd, Send (buf, pos, len, mode, k)) -> 84 | let res = Unix.send fd buf pos len mode in 85 | continue k res 86 | 87 | let block_accept st fd k = Hashtbl.add st.read_ht fd (Accept k) 88 | 89 | let block_recv st fd buf pos len mode k = 90 | Hashtbl.add st.read_ht fd (Recv (buf, pos, len, mode, k)) 91 | 92 | let block_send st fd buf pos len mode k = 93 | Hashtbl.add st.write_ht fd (Send (buf, pos, len, mode, k)) 94 | 95 | let block_sleep st span k = 96 | let time = Unix.gettimeofday () +. span in 97 | Hashtbl.add st.sleep_ht time (Sleep k) 98 | 99 | (* Wakes up sleeping threads. 100 | * 101 | * Returns [(b, t)] where [t] is the eariest time in the future when a thread 102 | * needs to wake up, and [b] is true if some thread is woken up. 103 | *) 104 | let wakeup st now : bool * float = 105 | let l, w, n = 106 | Hashtbl.fold 107 | (fun t (Sleep k) (l, w, next) -> 108 | if t <= now then ( 109 | enqueue_thread st k (); 110 | (t :: l, true, next)) 111 | else if t < next then (l, w, t) 112 | else (l, w, next)) 113 | st.sleep_ht ([], false, max_float) 114 | in 115 | List.iter (fun t -> Hashtbl.remove st.sleep_ht t) l; 116 | (w, n) 117 | 118 | let rec schedule st = 119 | if Queue.is_empty st.run_q then 120 | (* No runnable threads *) 121 | if 122 | Hashtbl.length st.read_ht = 0 123 | && Hashtbl.length st.write_ht = 0 124 | && Hashtbl.length st.sleep_ht = 0 125 | then () (* We are done. *) 126 | else 127 | let now = Unix.gettimeofday () in 128 | let thrd_has_woken_up, next_wakeup_time = wakeup st now in 129 | if thrd_has_woken_up then schedule st 130 | else if next_wakeup_time = max_float then perform_io st (-1.) 131 | else perform_io st (next_wakeup_time -. now) 132 | else (* Still have runnable threads *) 133 | dequeue st 134 | 135 | and perform_io st timeout = 136 | let rd_fds = Hashtbl.fold (fun fd _ acc -> fd :: acc) st.read_ht [] in 137 | let wr_fds = Hashtbl.fold (fun fd _ acc -> fd :: acc) st.write_ht [] in 138 | let rdy_rd_fds, rdy_wr_fds, _ = Unix.select rd_fds wr_fds [] timeout in 139 | let rec resume ht enqueue = function 140 | | [] -> () 141 | | x :: xs -> 142 | enqueue st x (Hashtbl.find ht x); 143 | Hashtbl.remove ht x; 144 | resume ht enqueue xs 145 | in 146 | resume st.read_ht enqueue_read rdy_rd_fds; 147 | resume st.write_ht enqueue_write rdy_wr_fds; 148 | if timeout > 0. then ignore (wakeup st (Unix.gettimeofday ())) else (); 149 | schedule st 150 | 151 | let run main = 152 | let st = init () in 153 | let rec fork st f = 154 | match_with f () 155 | { 156 | retc = (fun () -> schedule st); 157 | exnc = 158 | (fun exn -> 159 | print_string (Printexc.to_string exn); 160 | schedule st); 161 | effc = 162 | (fun (type a) (e : a Effect.t) -> 163 | match e with 164 | | Fork f -> 165 | Some 166 | (fun (k : (a, _) continuation) -> 167 | enqueue_thread st k (); 168 | fork st f) 169 | | Accept fd -> 170 | Some 171 | (fun k -> 172 | if poll_rd fd then 173 | let res = Unix.accept fd in 174 | continue k res 175 | else ( 176 | block_accept st fd k; 177 | schedule st)) 178 | | Recv (fd, buf, pos, len, mode) -> 179 | Some 180 | (fun k -> 181 | if poll_rd fd then 182 | let res = Unix.recv fd buf pos len mode in 183 | continue k res 184 | else ( 185 | block_recv st fd buf pos len mode k; 186 | schedule st)) 187 | | Send (fd, buf, pos, len, mode) -> 188 | Some 189 | (fun k -> 190 | if poll_wr fd then 191 | let res = Unix.send fd buf pos len mode in 192 | continue k res 193 | else ( 194 | block_send st fd buf pos len mode k; 195 | schedule st)) 196 | | Sleep t -> 197 | Some 198 | (fun k -> 199 | if t <= 0. then continue k () 200 | else ( 201 | block_sleep st t k; 202 | schedule st)) 203 | | _ -> None); 204 | } 205 | in 206 | fork st main 207 | -------------------------------------------------------------------------------- /aio/aio.mli: -------------------------------------------------------------------------------- 1 | (* Asynchronous IO library. 2 | * 3 | * For each blocking action, if the action can be performed immediately, then it 4 | * is. Otherwise, the thread performing the blocking task is suspended and 5 | * automatically wakes up when the action completes. The suspend/resume is 6 | * transparent to the programmer. 7 | *) 8 | 9 | val fork : (unit -> unit) -> unit 10 | 11 | type file_descr = Unix.file_descr 12 | type sockaddr = Unix.sockaddr 13 | type msg_flag = Unix.msg_flag 14 | 15 | val accept : file_descr -> file_descr * sockaddr 16 | val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int 17 | val send : file_descr -> bytes -> int -> int -> msg_flag list -> int 18 | val sleep : float -> unit 19 | val run : (unit -> unit) -> unit 20 | -------------------------------------------------------------------------------- /aio/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names echo) 3 | (libraries unix) 4 | (modules aio echo)) 5 | -------------------------------------------------------------------------------- /aio/echo.ml: -------------------------------------------------------------------------------- 1 | (* A simple echo server. 2 | * 3 | * The server listens on localhost port 9301. It accepts multiple clients and 4 | * echoes back to the client any data sent to the server. This server is a 5 | * direct-style reimplementation of the echo server found at [1], which 6 | * illustrates the same server written in CPS style. 7 | * 8 | * Compiling 9 | * --------- 10 | * 11 | * make 12 | * 13 | * Running 14 | * ------- 15 | * The echo server can be tested with a telnet client by starting the server and 16 | * on the same machine, running: 17 | * 18 | * telnet localhost 9301 19 | * 20 | * ----------------------- 21 | * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html 22 | * [2] https://github.com/ocamllabs/opam-repo-dev 23 | *) 24 | 25 | open Printf 26 | 27 | let send sock str = 28 | let len = Bytes.length str in 29 | let total = ref 0 in 30 | (try 31 | while !total < len do 32 | let write_count = Aio.send sock str !total (len - !total) [] in 33 | total := write_count + !total 34 | done 35 | with _ -> ()); 36 | !total 37 | 38 | let recv sock maxlen = 39 | let str = Bytes.create maxlen in 40 | let recvlen = try Aio.recv sock str 0 maxlen [] with _ -> 0 in 41 | Bytes.sub str 0 recvlen 42 | 43 | let close sock = 44 | try Unix.shutdown sock Unix.SHUTDOWN_ALL 45 | with _ -> 46 | (); 47 | Unix.close sock 48 | 49 | let string_of_sockaddr = function 50 | | Unix.ADDR_UNIX s -> s 51 | | Unix.ADDR_INET (inet, port) -> 52 | Unix.string_of_inet_addr inet ^ ":" ^ string_of_int port 53 | 54 | (* Repeat what the client says until the client goes away. *) 55 | let rec echo_server sock addr = 56 | try 57 | let data = recv sock 1024 in 58 | if Bytes.length data > 0 then ( 59 | ignore (send sock data); 60 | echo_server sock addr) 61 | else 62 | let cn = string_of_sockaddr addr in 63 | printf "echo_server : client (%s) disconnected.\n%!" cn; 64 | close sock 65 | with _ -> close sock 66 | 67 | let server () = 68 | (* Server listens on localhost at 9301 *) 69 | let addr, port = (Unix.inet_addr_loopback, 9301) in 70 | printf "Echo server listening on 127.0.0.1:%d\n%!" port; 71 | let saddr = Unix.ADDR_INET (addr, port) in 72 | let ssock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 73 | (* SO_REUSEADDR so we can restart the server quickly. *) 74 | Unix.setsockopt ssock Unix.SO_REUSEADDR true; 75 | Unix.bind ssock saddr; 76 | Unix.listen ssock 20; 77 | (* Socket is non-blocking *) 78 | Unix.set_nonblock ssock; 79 | try 80 | (* Wait for clients, and fork off echo servers. *) 81 | while true do 82 | let client_sock, client_addr = Aio.accept ssock in 83 | let cn = string_of_sockaddr client_addr in 84 | printf "server : client (%s) connected.\n%!" cn; 85 | Unix.set_nonblock client_sock; 86 | Aio.fork (fun () -> echo_server client_sock client_addr) 87 | done 88 | with _ -> close ssock 89 | 90 | let () = Aio.run server 91 | -------------------------------------------------------------------------------- /algorithmic_differentiation.ml: -------------------------------------------------------------------------------- 1 | (* Reverse-mode Algorithmic differentiation using effect handlers. 2 | Adapted from https://twitter.com/tiarkrompf/status/963314799521222656. 3 | See https://openreview.net/forum?id=SJxJtYkPG for more information. *) 4 | open Effect 5 | open Effect.Deep 6 | 7 | module F : sig 8 | type t 9 | 10 | val mk : float -> t 11 | val ( +. ) : t -> t -> t 12 | val ( *. ) : t -> t -> t 13 | val grad : (t -> t) -> float -> float 14 | val grad2 : (t * t -> t) -> float * float -> float * float 15 | end = struct 16 | type t = { v : float; mutable d : float } 17 | 18 | let mk v = { v; d = 0.0 } 19 | 20 | type _ eff += Add : t * t -> t eff 21 | type _ eff += Mult : t * t -> t eff 22 | 23 | let run f = 24 | ignore (match f () with 25 | | r -> r.d <- 1.0; r; 26 | | effect (Add(a,b)), k -> 27 | let x = {v = a.v +. b.v; d = 0.0} in 28 | ignore (continue k x); 29 | a.d <- a.d +. x.d; 30 | b.d <- b.d +. x.d; 31 | x 32 | | effect (Mult(a,b)), k -> 33 | let x = {v = a.v *. b.v; d = 0.0} in 34 | ignore (continue k x); 35 | a.d <- a.d +. (b.v *. x.d); 36 | b.d <- b.d +. (a.v *. x.d); 37 | x) 38 | 39 | let grad f x = 40 | let x = mk x in 41 | run (fun () -> f x); 42 | x.d 43 | 44 | let grad2 f (x, y) = 45 | let x, y = (mk x, mk y) in 46 | run (fun () -> f (x, y)); 47 | (x.d, y.d) 48 | 49 | let ( +. ) a b = perform (Add (a, b)) 50 | let ( *. ) a b = perform (Mult (a, b)) 51 | end 52 | ;; 53 | 54 | (* f = x + x^3 => 55 | df/dx = 1 + 3 * x^2 *) 56 | for x = 0 to 10 do 57 | let x = float_of_int x in 58 | assert (F.(grad (fun x -> x +. (x *. x *. x)) x) = 1.0 +. (3.0 *. x *. x)) 59 | done 60 | ;; 61 | 62 | (* f = x^2 + x^3 => 63 | df/dx = 2*x + 3 * x^2 *) 64 | for x = 0 to 10 do 65 | let x = float_of_int x in 66 | assert ( 67 | F.(grad (fun x -> (x *. x) +. (x *. x *. x)) x) 68 | = (2.0 *. x) +. (3.0 *. x *. x)) 69 | done 70 | ;; 71 | 72 | (* f = x^2 * y^4 => 73 | df/dx = 2 * x * y^4 74 | df/dy = 4 * x^2 * y^3 *) 75 | for x = 0 to 10 do 76 | for y = 0 to 10 do 77 | let x = float_of_int x in 78 | let y = float_of_int y in 79 | assert ( 80 | F.(grad2 (fun (x, y) -> x *. x *. y *. y *. y *. y) (x, y)) 81 | = (2.0 *. x *. y *. y *. y *. y, 4.0 *. x *. x *. y *. y *. y)) 82 | done 83 | done 84 | -------------------------------------------------------------------------------- /callbacks/bar.ml: -------------------------------------------------------------------------------- 1 | (* This example is intended to show that performing an effect in a C Callback, 2 | * whose handler is outside the current callback isn't sensible. This 3 | * corresponds to the stack given below (stack grows downward): 4 | * 5 | * +-----------------+ 6 | * | main | 7 | * | (try .... with) | //OCaml frame 8 | * +-----------------+ 9 | * | caml_to_c | //C frame -- OCaml calls to C 10 | * +-----------------+ 11 | * | c_to_caml | 12 | * | (perform e) | //OCaml frame -- C callback to OCaml 13 | * +-----------------+ 14 | * 15 | * This doesn't work because of the fact that there are intervening C frames 16 | * which cannot be captured as a part of the continuation. Expected output is: 17 | * 18 | * [Caml] Call caml_to_c 19 | * [C] Enter caml_to_c 20 | * [C] Call c_to_caml 21 | * [Caml] Enter c_to_caml 22 | * Fatal error: exception Unhandled 23 | *) 24 | open Effect 25 | open Effect.Deep 26 | 27 | type _ Effect.t += E : unit Effect.t 28 | 29 | let printf = Printf.printf 30 | 31 | let c_to_caml () = 32 | printf "[Caml] Enter c_to_caml\n%!"; 33 | perform E; 34 | printf "[Caml] Leave c_to_caml\n%!" 35 | 36 | let _ = Callback.register "c_to_caml" c_to_caml 37 | 38 | external caml_to_c : unit -> unit = "caml_to_c" 39 | 40 | let _ = 41 | let f () = 42 | printf "[Caml] Call caml_to_c\n%!"; 43 | caml_to_c (); 44 | printf "[Caml] Return from caml_to_c\n%!" 45 | in 46 | try_with f () 47 | { 48 | effc = 49 | (fun (type a) (e : a Effect.t) -> 50 | match e with 51 | | E -> 52 | Some 53 | (fun (k : (a, _) continuation) -> 54 | printf "[Caml] Handle effect E. Continuing..\n%!"; 55 | continue k ()) 56 | | _ -> None); 57 | } 58 | -------------------------------------------------------------------------------- /callbacks/bar.mli: -------------------------------------------------------------------------------- 1 | external caml_to_c : unit -> unit = "caml_to_c" 2 | -------------------------------------------------------------------------------- /callbacks/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (target foo.o) 3 | (deps foo.c) 4 | (action 5 | (run ocamlc -ccopt -DSERIAL -c foo.c))) 6 | 7 | (rule 8 | (target bar.cmi) 9 | (deps bar.mli) 10 | (action 11 | (run ocamlc -c bar.mli))) 12 | 13 | (rule 14 | (target callback) 15 | (deps bar.ml foo.o) 16 | (action 17 | (run ocamlc -custom -o callback foo.o bar.ml -linkall))) 18 | -------------------------------------------------------------------------------- /callbacks/foo.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | value caml_to_c (value unit) { 7 | CAMLparam1 (unit); 8 | printf ("[C] Enter caml_to_c\n"); 9 | 10 | #ifdef MULTI 11 | static value c_to_caml_closure; 12 | static int found = 0; 13 | if (!found) { 14 | c_to_caml_closure = caml_get_named_value ("c_to_caml", &found); 15 | if (!found) { 16 | printf ("caml_to_c: c_to_caml closure not found\n"); 17 | exit(1); 18 | } 19 | } 20 | 21 | printf ("[C] Call c_to_caml\n"); 22 | caml_callback(c_to_caml_closure, Val_unit); 23 | #else 24 | static value * c_to_caml_closure = NULL; 25 | if (c_to_caml_closure == NULL) 26 | c_to_caml_closure = caml_named_value("c_to_caml"); 27 | 28 | printf ("[C] Call c_to_caml\n"); 29 | caml_callback(*c_to_caml_closure, Val_unit); 30 | #endif 31 | printf ("[C] Return from c_to_caml\n"); 32 | 33 | printf ("[C] Leave caml_to_c\n"); 34 | CAMLreturn (Val_unit); 35 | } 36 | -------------------------------------------------------------------------------- /concurrent.ml: -------------------------------------------------------------------------------- 1 | (* Demonstrate the concurrent scheduler 2 | ------------------------------------ 3 | Spawn binary tree of tasks in depth-first order 4 | 5 | ************ 6 | Fiber tree 7 | ************ 8 | 0 9 | / \ 10 | 1 2 11 | / \ / \ 12 | 3 4 5 6 13 | *) 14 | 15 | let log = Printf.printf 16 | 17 | let rec f id depth = 18 | log "Starting number %i\n%!" id; 19 | if depth > 0 then ( 20 | log "Forking number %i\n%!" ((id * 2) + 1); 21 | Sched.fork (fun () -> f ((id * 2) + 1) (depth - 1)); 22 | log "Forking number %i\n%!" ((id * 2) + 2); 23 | Sched.fork (fun () -> f ((id * 2) + 2) (depth - 1))) 24 | else ( 25 | log "Yielding in number %i\n%!" id; 26 | Sched.yield (); 27 | log "Resumed number %i\n%!" id); 28 | log "Finishing number %i\n%!" id 29 | 30 | let () = Sched.run (fun () -> f 0 2) 31 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -w -50 -w -32 -w -27)))) 5 | 6 | (executables 7 | (names concurrent) 8 | (modules sched concurrent)) 9 | 10 | (executables 11 | (names ref) 12 | (modules state ref)) 13 | 14 | (executables 15 | (names transaction) 16 | (modules transaction)) 17 | 18 | (executables 19 | (names dyn_wind) 20 | (modules dyn_wind)) 21 | 22 | (executables 23 | (names dynamic_state) 24 | (modules dynamic_state)) 25 | 26 | (executables 27 | (names generator) 28 | (modules generator)) 29 | 30 | (executables 31 | (names promises) 32 | (modules promises)) 33 | 34 | (executables 35 | (names reify_reflect) 36 | (modules reify_reflect)) 37 | 38 | (executables 39 | (names eratosthenes) 40 | (modules eratosthenes)) 41 | 42 | (executables 43 | (names pipes) 44 | (modules pipes)) 45 | 46 | (executables 47 | (names loop) 48 | (modules loop)) 49 | 50 | (executables 51 | (names fringe) 52 | (modules fringe)) 53 | 54 | (executables 55 | (names algorithmic_differentiation) 56 | (modules algorithmic_differentiation)) 57 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name effects-examples) 3 | (generate_opam_files true) 4 | (source (github ocaml-multicore/effects-examples)) 5 | (authors "KC Sivaramakrishnan ") 6 | (maintainers "KC Sivaramakrishnan ") 7 | (package 8 | (name effects-examples) 9 | (synopsis "A collection of example programs using effects in OCaml 5") 10 | (description "A collection of example programs using effects in OCaml 5") 11 | (depends 12 | (lwt (>= "5.7")) 13 | (multicont (>= "1.0.3")))) 14 | -------------------------------------------------------------------------------- /dyn_wind.ml: -------------------------------------------------------------------------------- 1 | (* User-land dynamic wind: 2 | http://okmij.org/ftp/continuations/implementations.html#dynamic-wind *) 3 | open Effect 4 | open Effect.Deep 5 | 6 | let dynamic_wind before_thunk thunk after_thunk = 7 | before_thunk (); 8 | let res = 9 | match thunk () with 10 | | v -> v 11 | | exception e -> after_thunk (); raise e 12 | | effect e, k -> 13 | after_thunk (); 14 | let res' = perform e in 15 | before_thunk (); 16 | continue k res' 17 | in 18 | after_thunk (); 19 | res 20 | 21 | type _ eff += E : unit eff 22 | 23 | let () = 24 | let bt () = Printf.printf "IN\n" in 25 | let at () = Printf.printf "OUT\n" in 26 | let foo () = 27 | Printf.printf "perform E\n"; perform E; 28 | Printf.printf "perform E\n"; perform E; 29 | Printf.printf "done\n" 30 | in 31 | try dynamic_wind bt foo at with 32 | | effect E, k -> Printf.printf "handled E\n"; continue k () 33 | -------------------------------------------------------------------------------- /dynamic_state.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | (* This file contains a collection of attempts at replicating ML-style 5 | references using algebraic effects and handlers. The difficult thing 6 | to do is the dynamic creation of new reference cells at arbitrary 7 | types, without needing some kind of universal type or dynamic type 8 | checking. *) 9 | 10 | module type Type = sig type t end 11 | module Int = struct type t = int let compare = compare end 12 | 13 | module LocalState (R : sig type t end) = struct 14 | type reff = R.t 15 | type _ eff += New : int -> R.t eff 16 | type _ eff += Get : R.t -> int eff 17 | type _ eff += Put : R.t * int -> unit eff 18 | end 19 | 20 | module type StateOps = sig 21 | type reff 22 | type _ eff += New : int -> reff eff 23 | type _ eff += Get : reff -> int eff 24 | type _ eff += Put : reff * int -> unit eff 25 | end 26 | 27 | (**********************************************************************) 28 | (* version 1 : doesn't work, because declaration of new effect names 29 | is generative, so the handler and the client get different versions of 30 | the 'New', 'Get' and 'Put' effects. *) 31 | 32 | let run main = 33 | let module S = LocalState (Int) in 34 | let module IM = Map.Make (Int) in 35 | let comp = 36 | match main (module Int : Type) with 37 | | effect (S.New i), k -> 38 | fun s -> let r = fst (IM.max_binding s) + 1 39 | in continue k r (IM.add r i s) 40 | | effect (S.Get r), k -> 41 | fun s -> continue k (IM.find r s) s 42 | | effect (S.Put (r, i)), k -> 43 | fun s -> continue k () (IM.add r i s) 44 | | x -> fun s -> x 45 | in 46 | comp IM.empty 47 | 48 | let main (module T : Type) = 49 | let module S = LocalState(T) in 50 | let x = perform (S.New 1) in 51 | perform (S.Put (x, 5)); 52 | perform (S.Get x) 53 | 54 | (**********************************************************************) 55 | (* version 2 : working creation of freshly generated state cells, but 56 | only an int type. *) 57 | 58 | let run2 main = 59 | let module S = LocalState (Int) in 60 | let module IM = Map.Make (Int) in 61 | let comp = 62 | match main (module S : StateOps) with 63 | | effect (S.New i), k -> 64 | fun s -> 65 | let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1 66 | in continue k r (IM.add r i s) 67 | | effect (S.Get r), k -> 68 | fun s -> continue k (IM.find r s) s 69 | | effect (S.Put (r, i)), k -> 70 | fun s -> continue k () (IM.add r i s) 71 | | x -> fun s -> x 72 | in 73 | comp IM.empty 74 | 75 | let main2 (module S : StateOps) = 76 | let open S in 77 | let x = perform (New 1) in 78 | perform (Put (x, 5)); 79 | perform (Get x) 80 | 81 | (**********************************************************************) 82 | (* version 3, static creation of new state cells, requiring nested 83 | handlers. Similar to the example in "state.ml". *) 84 | module type GetPutOps = sig 85 | type t 86 | type _ eff += Get : t eff 87 | type _ eff += Put : t -> unit eff 88 | end 89 | 90 | module MakeGetPut (T : sig type t end) () = struct 91 | type t = T.t 92 | type _ eff += Get : t eff 93 | type _ eff += Put : t -> unit eff 94 | end 95 | 96 | let run3 (type a) (module S : GetPutOps with type t = a) (s : a) main = 97 | let module IM = Map.Make (Int) in 98 | let comp = 99 | match main () with 100 | | effect S.Get, k -> 101 | fun (s : S.t) -> continue k s s 102 | | effect (S.Put i), k -> 103 | fun s -> continue k () i 104 | | x -> fun s -> x 105 | in 106 | comp s 107 | 108 | module S1 = MakeGetPut (struct type t = int end) () 109 | module S2 = MakeGetPut (struct type t = string end) () 110 | 111 | let test3 () = 112 | perform (S1.Put 5); 113 | let x = perform (S1.Get) in 114 | perform (S2.Put (string_of_int x ^ "xx")); 115 | perform S2.Get 116 | 117 | (* XXX avsm: disabled pending port to multicont (uses clone_continuation) 118 | 119 | (**********************************************************************) 120 | (* version 4. Uses dynamic creation of new effect names to simulate 121 | the creation of new reference cells. Initially, there is only one 122 | effect 'New', which can be used to dynamically create new effect 123 | names. The handler for 'New' wraps the continuation in a new 124 | handler that handles the freshly generated effect names. This setup 125 | yields the same interface as ML refs, except that there is no way 126 | to compare references for equality. This is because cells are 127 | represeted as objects with a pair of a 'write' method and a 'read' 128 | method, so it is possible to create new references that reference 129 | the same underlying data without the access objects being 130 | equal. This is similar to the situation in Idealised Algol, where 131 | variables are ways to affect the state, but have no independent 132 | existence of their own. 133 | 134 | Compared to the example in "ref.ml", this implementation does not 135 | require a universal type, nor does it have "impossible" cases. 136 | 137 | This example also includes an unneccessary extra 'Choice' effect to 138 | demonstrate the combination of other effects with state in the same 139 | handler. This uses the experimental Obj.clone_continuation function to clone 140 | continuations. *) 141 | type 'a reff = < get : 'a; put : 'a -> unit; internals : (module GetPutOps with type t = 'a) > 142 | 143 | effect New : 'a -> 'a rEffect.t 144 | effect Choice : bool 145 | 146 | let run4 main = 147 | let donew : type a b. (a reff, b) continuation -> a -> b = fun k -> 148 | let module Ops = MakeGetPut (struct type t = a end) () in 149 | let cell = object 150 | method get = perform Ops.Get 151 | method put x = perform (Ops.Put x) 152 | method internals = (module Ops : GetPutOps with type t = a) 153 | end 154 | in 155 | match continue k cell with 156 | | effect Ops.Get k -> fun s -> continue k s s 157 | | effect (Ops.Put v) k -> fun s -> continue k () v 158 | | x -> fun s -> x 159 | in 160 | match main () with 161 | | effect (New v) k -> donew k v 162 | | effect (Choice) k -> let k' = Obj.clone_continuation k in continue k true; continue k' false 163 | | x -> x 164 | 165 | let newref i = perform (New i) 166 | 167 | let (:=) r x = r#put x 168 | 169 | let (!) r = r#get 170 | 171 | let test4 () = 172 | let a = newref 0 in 173 | let b = newref "str" in 174 | if perform Choice then 175 | begin a := String.length !b; 176 | b := string_of_int !a; 177 | print_endline !b 178 | end 179 | else 180 | print_endline !b 181 | *) 182 | -------------------------------------------------------------------------------- /effects-examples.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A collection of example programs using effects in OCaml 5" 4 | description: "A collection of example programs using effects in OCaml 5" 5 | maintainer: ["KC Sivaramakrishnan "] 6 | authors: ["KC Sivaramakrishnan "] 7 | homepage: "https://github.com/ocaml-multicore/effects-examples" 8 | bug-reports: "https://github.com/ocaml-multicore/effects-examples/issues" 9 | depends: [ 10 | "dune" {>= "2.9"} 11 | "lwt" {>= "5.7"} 12 | "multicont" {>= "1.0.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "--promote-install-files=false" 25 | "@install" 26 | "@runtest" {with-test} 27 | "@doc" {with-doc} 28 | ] 29 | ["dune" "install" "-p" name "--create-install-files" name] 30 | ] 31 | dev-repo: "git+https://github.com/ocaml-multicore/effects-examples.git" 32 | -------------------------------------------------------------------------------- /eratosthenes.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | (** Message-passing parallel prime number generation using Sieve of Eratosthenes **) 3 | 4 | open Effect.Deep 5 | 6 | (* A message is either a [Stop] signal or a [Candidate] prime number *) 7 | type message = Stop | Candidate of int 8 | 9 | let string_of_msg = function 10 | | Stop -> "Stop" 11 | | Candidate i -> Printf.sprintf "%d" i 12 | 13 | type pid = int 14 | (** Process primitives **) 15 | 16 | type _ eff += Spawn : (pid -> unit) -> pid eff 17 | let spawn p = perform (Spawn p) 18 | 19 | type _ eff += Yield : unit eff 20 | let yield () = perform Yield 21 | 22 | (** Communication primitives **) 23 | type _ eff += Send : pid * message -> unit eff 24 | 25 | let send pid data = 26 | perform (Send (pid, data)); 27 | yield () 28 | 29 | type _ eff += Recv : pid -> message option eff 30 | 31 | let rec recv pid = 32 | match perform (Recv pid) with 33 | | Some m -> m 34 | | None -> 35 | yield (); 36 | recv pid 37 | 38 | (** A mailbox is indexed by process ids (PIDs), each process has its own message queue **) 39 | module Mailbox = struct 40 | module Make (Ord : Map.OrderedType) = struct 41 | include Map.Make (Ord) 42 | 43 | let empty = empty 44 | let lookup key mb = try Some (find key mb) with Not_found -> None 45 | 46 | let pop key mb = 47 | ( (match lookup key mb with 48 | | Some msg_q -> 49 | if Queue.is_empty msg_q then None else Some (Queue.pop msg_q) 50 | | None -> None), 51 | mb ) 52 | 53 | let push key msg mb = 54 | match lookup key mb with 55 | | Some msg_q -> 56 | Queue.push msg msg_q; 57 | mb 58 | | None -> 59 | let msg_q = Queue.create () in 60 | Queue.push msg msg_q; 61 | add key msg_q mb 62 | end 63 | end 64 | 65 | (** Communication handler **) 66 | let mailbox f = 67 | let module Mailbox = Mailbox.Make (struct 68 | type t = pid 69 | 70 | let compare = compare 71 | end) in 72 | let mailbox = ref Mailbox.empty in 73 | let lookup pid = 74 | let msg, mb = Mailbox.pop pid !mailbox in 75 | mailbox := mb; 76 | msg 77 | in 78 | match f () with 79 | | v -> v 80 | | effect (Send (pid, msg)), k -> 81 | mailbox := Mailbox.push pid msg !mailbox; 82 | continue k () 83 | | effect (Recv who), k -> 84 | let msg = lookup who in 85 | continue k msg 86 | 87 | (** Process handler 88 | Slightly modified version of sched.ml **) 89 | let run main () = 90 | let run_q = Queue.create () in 91 | let enqueue k = Queue.push k run_q in 92 | let dequeue () = if Queue.is_empty run_q then () else (Queue.pop run_q) () in 93 | let pid = ref (-1) in 94 | let rec spawn f = 95 | pid := 1 + !pid; 96 | match f !pid with 97 | | () -> dequeue () 98 | | effect Yield, k -> 99 | enqueue (fun () -> continue k ()); dequeue () 100 | | effect (Spawn p), k -> 101 | enqueue (fun () -> continue k !pid); spawn p 102 | in 103 | spawn main 104 | 105 | let fromSome = function Some x -> x | _ -> failwith "Attempt to unwrap None" 106 | 107 | (** The prime number generator **) 108 | let rec generator : pid -> unit = 109 | fun _ -> 110 | let n = 111 | if Array.length Sys.argv > 1 then int_of_string Sys.argv.(1) else 101 112 | in 113 | let first = spawn sieve in 114 | (* Spawn first sieve *) 115 | Printf.printf "Primes in [2..%d]: " n; 116 | for i = 2 to n do 117 | send first (Candidate i) (* Send candidate prime to first sieve *) 118 | done; 119 | send first Stop; 120 | (* Stop the pipeline *) 121 | Printf.printf "\n" 122 | 123 | and sieve : pid -> unit = 124 | fun mypid -> 125 | match recv mypid with 126 | | Candidate myprime -> 127 | let _ = Printf.printf "%d " myprime in 128 | let succ = ref None in 129 | let rec loop () = 130 | let msg = recv mypid in 131 | match msg with 132 | | Candidate prime when prime mod myprime <> 0 -> 133 | let succ_pid = 134 | if !succ = None then ( 135 | let pid = spawn sieve in 136 | (* Create a successor process *) 137 | succ := Some pid; 138 | pid) 139 | else fromSome !succ 140 | in 141 | send succ_pid (Candidate prime); 142 | (* Send candidate prime to successor process *) 143 | loop () 144 | | Stop when !succ <> None -> 145 | send (fromSome !succ) Stop (* Forward stop command *) 146 | | Stop -> () 147 | | _ -> loop () 148 | in 149 | loop () 150 | | _ -> () 151 | 152 | (* Run application *) 153 | let _ = mailbox (run generator) 154 | -------------------------------------------------------------------------------- /fringe.ml: -------------------------------------------------------------------------------- 1 | (* Same Fringe Problem 2 | 3 | Definition: Two binary trees have the same fringe if they have exactly 4 | the same leaves reading from left to right. 5 | 6 | Problem: Given two binary trees decide whether they have the same fringe. 7 | 8 | This problem can be elegantly solved using one-shot continuations. 9 | *) 10 | open Effect 11 | open Effect.Deep 12 | 13 | module type EQUATABLE = sig 14 | type t 15 | 16 | val equals : t -> t -> bool 17 | end 18 | 19 | (* Basic binary tree structure *) 20 | type 'a tree = Leaf of 'a | Node of 'a tree * 'a tree 21 | 22 | module SameFringe (E : EQUATABLE) = struct 23 | type nonrec tree = E.t tree 24 | 25 | (* Yielding control *) 26 | type _ eff += Yield : E.t -> unit eff 27 | 28 | let yield e = perform (Yield e) 29 | 30 | (* The walk routine *) 31 | let rec walk : tree -> unit = function 32 | | Leaf e -> yield e 33 | | Node (l, r) -> 34 | walk l; 35 | walk r 36 | 37 | (* Reification of effects *) 38 | type resumption = (unit, step) continuation 39 | and step = Done | Yielded of E.t * resumption 40 | 41 | (* Reifies `Yield' effects *) 42 | let step f = 43 | match f () with 44 | | _ -> Done 45 | | effect Yield e, k -> Yielded (e, k) 46 | 47 | (* The comparator "step walks" two given trees simultaneously *) 48 | let comparator ltree rtree = 49 | let l () = step (fun () -> walk ltree) in 50 | let r () = step (fun () -> walk rtree) in 51 | let rec stepper l r = 52 | (* There are three cases to consider: 53 | 1) Both walk routines are done in which case the trees must have 54 | the same fringe. 55 | 2) Both walk routines have yielded a value. There are two 56 | subcases to consider: 57 | a) the values are equal in which case the walk routines 58 | are continued 59 | b) the values differ which implies that the trees do not have 60 | the same fringe. 61 | 3) Either walk routine is done, while the other yielded, 62 | which implies the one tree has a larger fringe than the other. *) 63 | match (l (), r ()) with 64 | | Done, Done -> true 65 | | Yielded (e, k), Yielded (e', k') -> 66 | if E.equals e e' then 67 | stepper (fun () -> continue k ()) (fun () -> continue k' ()) 68 | else false 69 | | _, _ -> false 70 | in 71 | stepper l r 72 | end 73 | 74 | (* Instantiate SameFringe to work over integers *) 75 | module SameFringe_Int = SameFringe (struct 76 | type t = int 77 | 78 | let equals x y = Stdlib.compare x y = 0 79 | end) 80 | 81 | (* Some examples *) 82 | let ex1 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 83 | let ex2 = Node (Node (Leaf 1, Leaf 2), Leaf 3) 84 | let ex3 = Node (Node (Leaf 3, Leaf 2), Leaf 1) 85 | let ex4 = Leaf 42 86 | let ex5 = Leaf 41 87 | 88 | let _ = 89 | let open SameFringe_Int in 90 | let pairs = 91 | [ (ex1, ex2); (ex2, ex1); (ex1, ex3); (ex3, ex2); (ex4, ex4); (ex5, ex4) ] 92 | in 93 | List.iter 94 | (function 95 | | true -> print_endline "same" | false -> print_endline "different") 96 | (List.map (fun (l, r) -> comparator l r) pairs); 97 | flush stdout 98 | -------------------------------------------------------------------------------- /generator.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Deep 4 | 5 | module type TREE = sig 6 | type 'a t 7 | (** The type of tree. *) 8 | 9 | val leaf : 'a t 10 | (** A tree with only a leaf. *) 11 | 12 | val node : 'a t -> 'a -> 'a t -> 'a t 13 | (** [node l x r] constructs a new tree with a new node [x] as the value, with 14 | [l] and [r] being the left and right sub-trees. *) 15 | 16 | val deep : int -> int t 17 | (** [deep n] constructs a tree of depth n, in linear time, where every node at 18 | level [l] has value [l]. *) 19 | 20 | val to_iter : 'a t -> ('a -> unit) -> unit 21 | (** Iterator function. *) 22 | 23 | val to_gen : 'a t -> unit -> 'a option 24 | (** Generator function. [to_gen t] returns a generator function [g] for the 25 | tree that traverses the tree in depth-first fashion, returning [Some x] 26 | for each node when [g] is invoked. [g] returns [None] once the traversal 27 | is complete. *) 28 | 29 | val to_gen_cps : 'a t -> unit -> 'a option 30 | (** CPS version of the generator function. *) 31 | end 32 | 33 | module Tree : TREE = struct 34 | type 'a t = Leaf | Node of 'a t * 'a * 'a t 35 | 36 | let leaf = Leaf 37 | let node l x r = Node (l, x, r) 38 | 39 | let rec deep = function 40 | | 0 -> Leaf 41 | | n -> 42 | let t = deep (n - 1) in 43 | Node (t, n, t) 44 | 45 | let rec iter f = function 46 | | Leaf -> () 47 | | Node (l, x, r) -> 48 | iter f l; 49 | f x; 50 | iter f r 51 | 52 | (* val to_iter : 'a t -> ('a -> unit) -> unit *) 53 | let to_iter t f = iter f t 54 | 55 | (* val to_gen : 'a t -> (unit -> 'a option) *) 56 | let to_gen (type a) (t : a t) = 57 | let module M = struct type _ eff += Next : a -> unit eff end in 58 | let open M in 59 | let rec step = ref (fun () -> 60 | try 61 | iter (fun x -> perform (Next x)) t; 62 | None 63 | with effect (Next v), k -> 64 | step := (fun () -> continue k ()); 65 | Some v) 66 | in 67 | fun () -> !step () 68 | 69 | let to_gen_cps t = 70 | let next = ref t in 71 | let cont = ref Leaf in 72 | let rec iter t k = 73 | match t with 74 | | Leaf -> run k 75 | | Node (left, x, right) -> iter left (Node (k, x, right)) 76 | and run = function 77 | | Leaf -> None 78 | | Node (k, x, right) -> 79 | next := right; 80 | cont := k; 81 | Some x 82 | in 83 | fun () -> iter !next !cont 84 | end 85 | 86 | let get_mean_sd l = 87 | let get_mean l = 88 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 89 | in 90 | let mean = get_mean l in 91 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 92 | (mean, sd) 93 | 94 | let benchmark f n = 95 | let rec run acc = function 96 | | 0 -> acc 97 | | n -> 98 | let t1 = Sys.time () in 99 | let () = f () in 100 | let d = Sys.time () -. t1 in 101 | run (d :: acc) (n - 1) 102 | in 103 | let r = run [] n in 104 | get_mean_sd r 105 | 106 | (* Main follows *) 107 | 108 | let n = try int_of_string Sys.argv.(1) with _ -> 25 109 | let t = Tree.deep n 110 | let iter_fun () = Tree.to_iter t (fun _ -> ()) 111 | let m, sd = benchmark iter_fun 5 112 | let () = printf "Iter: mean = %f, sd = %f\n%!" m sd 113 | let rec consume_all f = match f () with None -> () | Some _ -> consume_all f 114 | 115 | let gen_cps_fun () = 116 | let f = Tree.to_gen_cps t in 117 | consume_all f 118 | 119 | let m, sd = benchmark gen_cps_fun 5 120 | let () = printf "Gen_cps: mean = %f, sd = %f\n%!" m sd 121 | 122 | let gen_fun () = 123 | let f = Tree.to_gen t in 124 | consume_all f 125 | 126 | let m, sd = benchmark gen_fun 5 127 | let () = printf "Gen_eff: mean = %f, sd = %f\n%!" m sd 128 | -------------------------------------------------------------------------------- /loop.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ eff += Foo : (unit -> 'a) eff 5 | 6 | let f () = perform Foo () 7 | 8 | let res : type a. a = 9 | match f () with 10 | | x -> x 11 | | effect Foo, k -> 12 | continue k (fun () -> perform Foo ()) 13 | -------------------------------------------------------------------------------- /multishot/clone_is_tricky.ml: -------------------------------------------------------------------------------- 1 | (* Multi-shot continuations don't play nicely with linear resources. 2 | * This program illustrates that resuming an inner one-shot continuation 3 | * within an outer multi-shot context causes a runtime error. 4 | *) 5 | open Effect 6 | open Effect.Deep 7 | 8 | type _ Effect.t += Foo : unit Effect.t 9 | type _ Effect.t += Bar : unit Effect.t 10 | 11 | let _ = 12 | let run () = 13 | try_with perform Foo 14 | { 15 | effc = 16 | (fun (type a) (e : a Effect.t) -> 17 | match e with 18 | | Foo -> 19 | Some (fun (k : (a, _) continuation) -> continue k (perform Bar)) 20 | (* This continuation is resumed twice *) 21 | | _ -> None); 22 | } 23 | in 24 | try_with run () 25 | { 26 | effc = 27 | (fun (type a) (e : a Effect.t) -> 28 | match e with 29 | | Bar -> 30 | Some 31 | (fun (k : (a, _) continuation) -> 32 | continue (Multicont.Deep.clone_continuation k) (); 33 | continue k ()) 34 | | _ -> None); 35 | } 36 | -------------------------------------------------------------------------------- /multishot/delimcc.ml: -------------------------------------------------------------------------------- 1 | (* One-shot multi-prompt delimited control : 2 | http://okmij.org/ftp/continuations/implementations.html *) 3 | open Effect 4 | open Effect.Deep 5 | 6 | module type S = sig 7 | type 'a prompt 8 | 9 | (* One-shot continuation. *) 10 | type ('a, 'b) subcont 11 | 12 | val new_prompt : unit -> 'a prompt 13 | val push_prompt : 'a prompt -> (unit -> 'a) -> 'a 14 | val take_subcont : 'b prompt -> (('a, 'b) subcont -> 'b) -> 'a 15 | val push_subcont : ('a, 'b) subcont -> 'a -> 'b 16 | 17 | (* Assorted control operators *) 18 | val reset : ('a prompt -> 'a) -> 'a 19 | val shift : 'a prompt -> (('b -> 'a) -> 'a) -> 'b 20 | val control : 'a prompt -> (('b -> 'a) -> 'a) -> 'b 21 | val shift0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b 22 | val control0 : 'a prompt -> (('b -> 'a) -> 'a) -> 'b 23 | val abort : 'a prompt -> 'a -> 'b 24 | end 25 | 26 | module M : S = struct 27 | type ('a, 'b) subcont = ('a, 'b) continuation 28 | 29 | type 'a prompt = { 30 | take : 'b. (('b, 'a) subcont -> 'a) -> 'b; 31 | push : (unit -> 'a) -> 'a; 32 | } 33 | 34 | let new_prompt (type a) () : a prompt = 35 | let module M = struct 36 | type _ Effect.t += Prompt : (('b, a) subcont -> a) -> 'b Effect.t 37 | end in 38 | let take f = perform (M.Prompt f) in 39 | let push f = 40 | try_with f () 41 | { 42 | effc = 43 | (fun (type a) (e : a Effect.t) -> 44 | match e with M.Prompt f -> Some (fun k -> f k) | _ -> None); 45 | } 46 | in 47 | { take; push } 48 | 49 | let push_prompt prompt = prompt.push 50 | let take_subcont prompt = prompt.take 51 | 52 | let push_subcont k v = 53 | let k' = Multicont.Deep.clone_continuation k in 54 | continue k' v 55 | 56 | (** For the details of the implementation of control and shift0, see 57 | https://hackage.haskell.org/package/CC-delcont-0.2.1.0/docs/src/Control-Monad-CC.html *) 58 | let reset e = 59 | let p = new_prompt () in 60 | push_prompt p (fun () -> e p) 61 | 62 | let shift p f = 63 | take_subcont p (fun sk -> 64 | push_prompt p (fun () -> 65 | f (fun c -> push_prompt p (fun () -> push_subcont sk c)))) 66 | 67 | let control p f = 68 | take_subcont p (fun sk -> 69 | push_prompt p (fun () -> f (fun c -> push_subcont sk c))) 70 | 71 | let shift0 p f = 72 | take_subcont p (fun sk -> 73 | f (fun c -> push_prompt p (fun () -> push_subcont sk c))) 74 | 75 | let control0 p f = take_subcont p (fun sk -> f (fun c -> push_subcont sk c)) 76 | let abort p e = take_subcont p (fun _ -> e) 77 | end 78 | 79 | open M 80 | 81 | let p = new_prompt ();; 82 | 83 | assert ([] = push_prompt p (fun () -> 1 :: 2 :: take_subcont p (fun _k -> []))) 84 | ;; 85 | 86 | assert ( 87 | [ 1; 2 ] 88 | = push_prompt p (fun () -> 89 | 1 :: 2 :: take_subcont p (fun k -> push_subcont k []))) 90 | ;; 91 | 92 | assert ( 93 | 135 94 | = 95 | let p1 = new_prompt () in 96 | let p2 = new_prompt () in 97 | let p3 = new_prompt () in 98 | let pushtwice sk = 99 | sk (fun () -> 100 | sk (fun () -> 101 | shift0 p2 (fun sk2 -> sk2 (fun () -> sk2 (fun () -> 3))) ())) 102 | in 103 | push_prompt p1 (fun () -> 104 | push_prompt p2 (fun () -> 105 | push_prompt p3 (fun () -> shift0 p1 pushtwice ()) + 10) 106 | + 1) 107 | + 100) 108 | -------------------------------------------------------------------------------- /multishot/delimcc_paper_example.ml: -------------------------------------------------------------------------------- 1 | (* Example in the delimcc paper: 2 | * http://okmij.org/ftp/continuations/caml-shift-journal.pdf *) 3 | 4 | open Delimcc.M 5 | 6 | (* A finite map: a search tree *) 7 | type ('k, 'v) tree = Empty | Node of ('k, 'v) tree * 'k * 'v * ('k, 'v) tree 8 | 9 | exception NotFound 10 | 11 | (* Update the value associated with the key k by applying the 12 | update function f. Return the new tree. 13 | If the key is not found, throw an exception. 14 | *) 15 | let rec update1 : 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = 16 | fun k f -> 17 | let rec loop = function 18 | | Empty -> raise NotFound 19 | | Node (l, k1, v1, r) -> ( 20 | match compare k k1 with 21 | | 0 -> Node (l, k1, f v1, r) 22 | | n when n < 0 -> Node (loop l, k1, v1, r) 23 | | _ -> Node (l, k1, v1, loop r)) 24 | in 25 | loop 26 | 27 | (* Add to the tree the association of the key k to the value v, 28 | overriding any existing association with the key k, if any. 29 | *) 30 | let rec insert k v = function 31 | | Empty -> Node (Empty, k, v, Empty) 32 | | Node (l, k1, v1, r) -> ( 33 | match compare k k1 with 34 | | 0 -> Node (l, k1, v, r) 35 | | n when n < 0 -> Node (insert k v l, k1, v1, r) 36 | | _ -> Node (l, k1, v1, insert k v r)) 37 | 38 | (* A re-balancing function; dummy for now *) 39 | let rebalance : ('k, 'v) tree -> ('k, 'v) tree = 40 | fun t -> 41 | print_endline "Rebalancing"; 42 | t 43 | 44 | (* Examples of using update1 *) 45 | let tree1 = 46 | let n1 = Node (Empty, 1, 101, Empty) in 47 | let n9 = Node (Empty, 9, 109, Empty) in 48 | let n5 = Node (n1, 5, 105, Empty) in 49 | let n7 = Node (n5, 7, 107, n9) in 50 | n7 51 | 52 | let (Node 53 | ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 54 | 7, 55 | 107, 56 | Node (Empty, 9, 109, Empty) )) = 57 | try update1 1 succ tree1 with NotFound -> insert 1 100 tree1 58 | 59 | let (Node 60 | ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), 61 | 7, 62 | 107, 63 | Node (Empty, 9, 109, Empty) )) = 64 | try update1 0 succ tree1 with NotFound -> insert 0 100 tree1 65 | 66 | (* The same as update1, but using Delimcc *) 67 | 68 | let rec update2 : 69 | ('k, 'v) tree option prompt -> 70 | 'k -> 71 | ('v -> 'v) -> 72 | ('k, 'v) tree -> 73 | ('k, 'v) tree = 74 | fun pnf k f -> 75 | let rec loop = function 76 | | Empty -> abort pnf None 77 | | Node (l, k1, v1, r) -> ( 78 | match compare k k1 with 79 | | 0 -> Node (l, k1, f v1, r) 80 | | n when n < 0 -> Node (loop l, k1, v1, r) 81 | | _ -> Node (l, k1, v1, loop r)) 82 | in 83 | loop 84 | 85 | let (Node 86 | ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 87 | 7, 88 | 107, 89 | Node (Empty, 9, 109, Empty) )) = 90 | let pnf = new_prompt () in 91 | match push_prompt pnf (fun () -> Some (update2 pnf 1 succ tree1)) with 92 | | Some tree -> tree 93 | | None -> insert 1 100 tree1 94 | 95 | let (Node 96 | ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), 97 | 7, 98 | 107, 99 | Node (Empty, 9, 109, Empty) )) = 100 | let pnf = new_prompt () in 101 | match push_prompt pnf (fun () -> Some (update2 pnf 0 succ tree1)) with 102 | | Some tree -> tree 103 | | None -> insert 0 100 tree1 104 | 105 | (* Resumable exceptions *) 106 | (* upd_handle is very problematic! *) 107 | let upd_handle k = raise NotFound 108 | 109 | let rec update3 : 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = 110 | fun k f -> 111 | let rec loop = function 112 | | Empty -> Node (Empty, k, upd_handle k, Empty) 113 | | Node (l, k1, v1, r) -> ( 114 | match compare k k1 with 115 | | 0 -> Node (l, k1, f v1, r) 116 | | n when n < 0 -> Node (loop l, k1, v1, r) 117 | | _ -> Node (l, k1, v1, loop r)) 118 | in 119 | loop 120 | 121 | let (Node 122 | ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 123 | 7, 124 | 107, 125 | Node (Empty, 9, 109, Empty) )) = 126 | update3 1 succ tree1 127 | 128 | (* Resumable exceptions *) 129 | 130 | type ('k, 'v) res = 131 | | Done of ('k, 'v) tree 132 | | ReqNF of 'k * ('v, ('k, 'v) res) subcont 133 | 134 | let rec update4 : 135 | ('k, 'v) res prompt -> 'k -> ('v -> 'v) -> ('k, 'v) tree -> ('k, 'v) tree = 136 | fun pnf k f -> 137 | let rec loop = function 138 | | Empty -> Node (Empty, k, take_subcont pnf (fun c -> ReqNF (k, c)), Empty) 139 | | Node (l, k1, v1, r) -> ( 140 | match compare k k1 with 141 | | 0 -> Node (l, k1, f v1, r) 142 | | n when n < 0 -> Node (loop l, k1, v1, r) 143 | | _ -> Node (l, k1, v1, loop r)) 144 | in 145 | loop 146 | 147 | let (Node 148 | ( Node (Node (Empty, 1, 102, Empty), 5, 105, Empty), 149 | 7, 150 | 107, 151 | Node (Empty, 9, 109, Empty) )) = 152 | let pnf = new_prompt () in 153 | match push_prompt pnf (fun () -> Done (update4 pnf 1 succ tree1)) with 154 | | Done tree -> tree 155 | | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) 156 | 157 | let (Node 158 | ( Node (Node (Node (Empty, 0, 100, Empty), 1, 101, Empty), 5, 105, Empty), 159 | 7, 160 | 107, 161 | Node (Empty, 9, 109, Empty) )) = 162 | let pnf = new_prompt () in 163 | match push_prompt pnf (fun () -> Done (update4 pnf 0 succ tree1)) with 164 | | Done tree -> tree 165 | | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) 166 | 167 | (* Rebalancing is printed *) 168 | 169 | (* A custom value update function *) 170 | exception TooBig 171 | 172 | let upd_fun n = if n > 5 then raise TooBig else succ n 173 | 174 | (* Several exceptions *) 175 | let Empty = 176 | try try update1 7 upd_fun tree1 with NotFound -> insert 7 100 tree1 177 | with TooBig -> Empty 178 | 179 | let Empty = 180 | try 181 | let pnf = new_prompt () in 182 | match push_prompt pnf (fun () -> Done (update4 pnf 7 upd_fun tree1)) with 183 | | Done tree -> tree 184 | | ReqNF (k, c) -> rebalance (match push_subcont c 100 with Done x -> x) 185 | with TooBig -> Empty 186 | -------------------------------------------------------------------------------- /multishot/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names memo) 3 | (modules memo) 4 | (libraries multicont)) 5 | 6 | (executables 7 | (names nondeterminism) 8 | (modules nondeterminism) 9 | (libraries multicont)) 10 | 11 | (executables 12 | (names nim) 13 | (modules nim) 14 | (libraries multicont)) 15 | 16 | (executables 17 | (names queens) 18 | (modules queens) 19 | (libraries multicont)) 20 | 21 | (executables 22 | (names clone_is_tricky) 23 | (modules clone_is_tricky) 24 | (libraries multicont)) 25 | 26 | (executables 27 | (names delimcc) 28 | (modules delimcc) 29 | (libraries multicont)) 30 | 31 | (executables 32 | (names dynamic_state) 33 | (modules dynamic_state) 34 | (libraries multicont)) 35 | -------------------------------------------------------------------------------- /multishot/dynamic_state.ml: -------------------------------------------------------------------------------- 1 | (* This file contains a collection of attempts at replicating ML-style 2 | references using algebraic effects and handlers. The difficult thing 3 | to do is the dynamic creation of new reference cells at arbitrary 4 | types, without needing some kind of universal type or dynamic type 5 | checking. *) 6 | 7 | open Effect 8 | open Effect.Deep 9 | 10 | module type Type = sig 11 | type t 12 | end 13 | 14 | module Int = struct 15 | type t = int 16 | 17 | let compare = compare 18 | end 19 | 20 | module LocalState (R : sig 21 | type t 22 | end) = 23 | struct 24 | type reff = R.t 25 | type _ Effect.t += New : int -> R.t Effect.t 26 | type _ Effect.t += Get : R.t -> int Effect.t 27 | type _ Effect.t += Put : R.t * int -> unit Effect.t 28 | end 29 | 30 | module type StateOps = sig 31 | type reff 32 | type _ Effect.t += New : int -> reff Effect.t 33 | type _ Effect.t += Get : reff -> int Effect.t 34 | type _ Effect.t += Put : reff * int -> unit Effect.t 35 | end 36 | 37 | (**********************************************************************) 38 | (* version 1 : doesn't work, because declaration of new effect names 39 | is generative, so the handler and the client get different versions of 40 | the 'New', 'Get' and 'Put' effects. *) 41 | 42 | let run main = 43 | let module S = LocalState (Int) in 44 | let module IM = Map.Make (Int) in 45 | let comp = 46 | try_with main 47 | (module Int : Type) 48 | { 49 | effc = 50 | (fun (type a) (e : a Effect.t) -> 51 | match e with 52 | | S.Put (r, i) -> 53 | Some 54 | (fun (k : (a, _) continuation) s -> 55 | continue k () (IM.add r i s)) 56 | | S.Get r -> 57 | Some 58 | (fun (k : (a, _) continuation) s -> 59 | continue k (IM.find r s) s) 60 | | S.New i -> 61 | Some 62 | (fun (k : (a, _) continuation) s -> 63 | let r = fst (IM.max_binding s) + 1 in 64 | continue k r (IM.add r i s)) 65 | | _ -> None); 66 | } 67 | in 68 | comp IM.empty 69 | 70 | let main (module T : Type) = 71 | let module S = LocalState (T) in 72 | let x = perform (S.New 1) in 73 | perform (S.Put (x, 5)); 74 | perform (S.Get x) 75 | 76 | (**********************************************************************) 77 | (* version 2 : working creation of freshly generated state cells, but 78 | only an int type. *) 79 | let run2 main = 80 | let module S = LocalState (Int) in 81 | let module IM = Map.Make (Int) in 82 | let comp = 83 | try_with main 84 | (module S : StateOps) 85 | { 86 | effc = 87 | (fun (type a) (e : a Effect.t) -> 88 | match e with 89 | | S.Put (r, i) -> 90 | Some 91 | (fun (k : (a, _) continuation) s -> 92 | continue k () (IM.add r i s)) 93 | | S.Get r -> 94 | Some 95 | (fun (k : (a, _) continuation) s -> 96 | continue k (IM.find r s) s) 97 | | S.New i -> 98 | Some 99 | (fun (k : (a, _) continuation) s -> 100 | let r = 101 | if IM.is_empty s then 0 else fst (IM.max_binding s) + 1 102 | in 103 | continue k r (IM.add r i s)) 104 | | _ -> None); 105 | } 106 | in 107 | comp IM.empty 108 | 109 | let main2 (module S : StateOps) = 110 | let open S in 111 | let x = perform (New 1) in 112 | perform (Put (x, 5)); 113 | perform (Get x) 114 | 115 | (**********************************************************************) 116 | (* version 3, static creation of new state cells, requiring nested 117 | handlers. Similar to the example in "state.ml". 118 | *) 119 | module type GetPutOps = sig 120 | type t 121 | type _ Effect.t += Get : t Effect.t 122 | type _ Effect.t += Put : t -> unit Effect.t 123 | end 124 | 125 | module MakeGetPut 126 | (T : sig 127 | type t 128 | end) 129 | () = 130 | struct 131 | type t = T.t 132 | type _ Effect.t += Get : t Effect.t 133 | type _ Effect.t += Put : t -> unit Effect.t 134 | end 135 | 136 | let run3 (type a) (module S : GetPutOps with type t = a) (s : a) main = 137 | let module IM = Map.Make (Int) in 138 | let comp = 139 | match_with main () 140 | { 141 | retc = (fun s _ -> s); 142 | exnc = (fun e -> raise e); 143 | effc = 144 | (fun (type a) (e : a Effect.t) -> 145 | match e with 146 | | S.Get -> 147 | Some (fun (k : (a, _) continuation) (s : S.t) -> continue k s s) 148 | | S.Put i -> 149 | Some (fun (k : (a, _) continuation) s -> continue k () i) 150 | | _ -> None); 151 | } 152 | in 153 | comp s 154 | 155 | module S1 = 156 | MakeGetPut 157 | (struct 158 | type t = int 159 | end) 160 | () 161 | 162 | module S2 = 163 | MakeGetPut 164 | (struct 165 | type t = string 166 | end) 167 | () 168 | 169 | let test3 () : string = 170 | perform (S1.Put 5); 171 | let x = perform S1.Get in 172 | perform (S2.Put (string_of_int x ^ "xx")); 173 | perform S2.Get 174 | 175 | (* NOTE we can run with string state inside the integer state. 176 | or swap around the state and have integer state inside the string state. 177 | Both work! 178 | *) 179 | 180 | let main3 () = run3 (module S1) 0 (fun () -> run3 (module S2) "" test3) 181 | let main3' () = run3 (module S2) "" (fun () -> run3 (module S1) 0 test3) 182 | 183 | (**********************************************************************) 184 | (* version 4. Uses dynamic creation of new effect names to simulate 185 | the creation of new reference cells. Initially, there is only one 186 | effect 'New', which can be used to dynamically create new effect 187 | names. The handler for 'New' wraps the continuation in a new 188 | handler that handles the freshly generated effect names. This setup 189 | yields the same interface as ML refs, except that there is no way 190 | to compare references for equality. This is because cells are 191 | represeted as objects with a pair of a 'write' method and a 'read' 192 | method, so it is possible to create new references that reference 193 | the same underlying data without the access objects being 194 | equal. This is similar to the situation in Idealised Algol, where 195 | variables are ways to affect the state, but have no independent 196 | existence of their own. 197 | 198 | Compared to the example in "ref.ml", this implementation does not 199 | require a universal type, nor does it have "impossible" cases. 200 | 201 | This example also includes an unneccessary extra 'Choice' effect to 202 | demonstrate the combination of other effects with state in the same 203 | handler. This uses the external `Multicont.Deep.clone_continuation` 204 | function to clone continuations. *) 205 | type 'a reff = 206 | < get : 'a 207 | ; put : 'a -> unit 208 | ; internals : (module GetPutOps with type t = 'a) > 209 | 210 | type _ Effect.t += New : 'a -> 'a reff t 211 | type _ Effect.t += Choice : bool t 212 | 213 | let run4 main = 214 | let donew : type a b. (a reff, b) continuation -> a -> b = 215 | fun k -> 216 | let module Ops = 217 | MakeGetPut 218 | (struct 219 | type t = a 220 | end) 221 | () 222 | in 223 | let cell = 224 | object 225 | method get = perform Ops.Get 226 | method put x = perform (Ops.Put x) 227 | method internals = (module Ops : GetPutOps with type t = a) 228 | end 229 | in 230 | match_with (continue k) cell 231 | { 232 | retc = (fun s _ -> s); 233 | exnc = (fun e -> raise e); 234 | effc = 235 | (fun (type c) (e : c t) -> 236 | match e with 237 | | Ops.Put v -> 238 | Some (fun (k : (c, _) continuation) _ -> continue k () v) 239 | | Ops.Get -> 240 | Some (fun (k : (c, _) continuation) (s : a) -> continue k s s) 241 | | _ -> None); 242 | } 243 | in 244 | try_with main () 245 | { 246 | effc = 247 | (fun (type a) (e : a t) -> 248 | match e with 249 | | New v -> Some (fun (k : (a, _) continuation) -> donew k v) 250 | | Choice -> 251 | Some 252 | (fun (k : (a, _) continuation) -> 253 | let k' = Multicont.Deep.clone_continuation k in 254 | continue k true; 255 | continue k' false) 256 | | _ -> None); 257 | } 258 | 259 | let newref i = perform (New i) 260 | let ( := ) r x = r#put x 261 | let ( ! ) r = r#get 262 | 263 | let test4 () = 264 | let a = newref 0 in 265 | let b = newref "str" in 266 | if perform Choice then ( 267 | a := String.length !b; 268 | b := string_of_int !a; 269 | print_endline !b) 270 | else print_endline !b 271 | 272 | let main4 () = run4 test4 273 | -------------------------------------------------------------------------------- /multishot/memo.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | (* OCaml 5 removed the ability to clone continuations. See this conversation 5 | https://discuss.ocaml.org/t/multi-shot-continuations-gone-forever/9072. 6 | 7 | It is possible this example could be revived using: 8 | https://github.com/dhil/ocaml-multicont 9 | *) 10 | 11 | module Memo : sig 12 | val memoize : ('a -> 'b) -> 'a -> 'b 13 | (** [memoize f] returns the memoized version of [f] that caches the 14 | * evaluation of [f] from the start of [f] to the last invocation of [cut ()] 15 | * in [f], with respect to some input [x] to the memoized function. 16 | * Subsequent invocations of the memoized function with the same input [x] 17 | * only evaluates the continuation of the [cut ()]. 18 | * 19 | * If the memoized function is applied to [y], where [not (x = y)], the memo 20 | * cache is updated. 21 | *) 22 | 23 | val cut : unit -> unit 24 | (** [cut ()] marks the end of memoization. If a memoized function has 25 | * multiple [cut()], the function is memoized until the last cut. Invoking a 26 | * memoized function without establishing a cut is an error. 27 | *) 28 | end = struct 29 | type _ Effect.t += Cut : unit Effect.t 30 | 31 | let cut () = perform Cut 32 | 33 | type ('a, 'b) cache_entry = { input : 'a; mutable cont : unit -> 'b } 34 | 35 | let memoize f = 36 | let cache = ref None in 37 | fun x -> 38 | try_with 39 | (fun () -> 40 | match !cache with 41 | | Some { input; cont } when x = input -> cont () 42 | | _ -> 43 | let err_msg = "Memoized function was not cut" in 44 | cache := Some { input = x; cont = (fun () -> failwith err_msg) }; 45 | f x) 46 | () 47 | { 48 | effc = 49 | (fun (type a) (e : a Effect.t) -> 50 | match e with 51 | | Cut -> 52 | Some 53 | (fun (k : (a, _) continuation) -> 54 | match !cache with 55 | | Some c -> 56 | let rec save_cont k () = 57 | c.cont <- 58 | save_cont (Multicont.Deep.clone_continuation k); 59 | continue k () 60 | in 61 | save_cont k () 62 | | None -> failwith "impossible") 63 | | _ -> None); 64 | } 65 | end 66 | 67 | let print_succ x = 68 | Printf.printf "input change: %d\n" x; 69 | (* ...... 70 | * expensive computation 71 | * .....*) 72 | Memo.cut (); 73 | Printf.printf "Succ of %d is %d\n" x (x + 1) 74 | 75 | let memoized_print_succ = Memo.memoize print_succ 76 | 77 | let test () = 78 | memoized_print_succ 0; 79 | memoized_print_succ 0; 80 | memoized_print_succ 0; 81 | memoized_print_succ 1; 82 | memoized_print_succ 1; 83 | memoized_print_succ 1 84 | 85 | let _ = test () 86 | -------------------------------------------------------------------------------- /multishot/nim.ml: -------------------------------------------------------------------------------- 1 | (* Nim game (https://en.wikipedia.org/wiki/Nim) 2 | It was Nicolas Oury's original idea to use Nim to show case handlers. 3 | c.f. https://github.com/slindley/effect-handlers/blob/master/Examples/Nim.hs 4 | 5 | This particular implementation is adapted from Hillerström and Lindley. 6 | 7 | Mathematical game Nim 8 | 9 | Rules: 10 | - Two players: Alice and Bob; Alice always starts. 11 | - One heap of N sticks. 12 | - Turn-based, one move per turn. 13 | - A player may pick between 1-3 sticks at each turn. 14 | - The player, who takes the last stick, wins. 15 | *) 16 | open Effect 17 | open Effect.Deep 18 | 19 | (* Data type modelling the players *) 20 | type player = Alice | Bob 21 | 22 | (* String representation of players *) 23 | let string_of_player = function Alice -> "Alice" | Bob -> "Bob" 24 | 25 | (* The [move] operation is centric to the game. The operation is 26 | parameterised by the active player and the number of sticks left in 27 | the game. *) 28 | type _ Effect.t += Move : (player * int) -> int Effect.t 29 | 30 | let move p n = perform (Move (p, n)) 31 | 32 | (* The game is modelled as two mutually recursive functions *) 33 | let rec alice_turn n = if n == 0 then Bob else bob_turn (n - move Alice n) 34 | and bob_turn n = if n == 0 then Alice else alice_turn (n - move Bob n) 35 | 36 | (* Auxiliary function to start a game with [n] sticks. *) 37 | let game n () = alice_turn n 38 | 39 | (* The strategy handler assigns strategy s(p) to player [p] *) 40 | 41 | (** Encoding player strategies **) 42 | let strategy (s : player -> int -> (int, player) continuation -> player) m = 43 | try_with m () 44 | { 45 | effc = 46 | (fun (type a) (e : a Effect.t) -> 47 | match e with 48 | | Move (p, n) -> Some (fun (k : (a, player) continuation) -> s p n k) 49 | | _ -> None); 50 | } 51 | 52 | (* Simple (and naive) strategy *) 53 | let ns _ k = continue k 1 54 | 55 | (* The perfect strategy *) 56 | let ps n k = continue k (max 1 (n mod 4)) 57 | 58 | (* Brute force strategy *) 59 | (* The auxiliary function [valid_moves] computes the set of legal 60 | moves when there are [n] sticks left in the game. *) 61 | let valid_moves n = List.filter (fun m -> m <= n) [ 1; 2; 3 ] 62 | 63 | (* The function [elem_index] returns Some index of the first element 64 | satisfying the predicate [p]. *) 65 | let elem_index p xs = 66 | let rec elem_index' i = function 67 | | x :: xs when p x -> Some i 68 | | x :: xs -> elem_index' (i + 1) xs 69 | | [] -> None 70 | in 71 | elem_index' 0 xs 72 | 73 | (* Nonlinear continue invokes a copy of [k] *) 74 | let nonlinear_continue k = continue (Multicont.Deep.clone_continuation k) 75 | 76 | (* This function maps a continuation [k] over a list *) 77 | let rec mapk k = function 78 | | x :: xs -> nonlinear_continue k x :: mapk k xs 79 | | [] -> [] 80 | 81 | (* Finally, we can define the brute force strategy. In contrast to 82 | [ns] and [ps] it takes an additional parameter [p] which is the player 83 | for whom we are attempting to brute force a winning strategy. *) 84 | let bf p n k = 85 | let winners = mapk k (valid_moves n) in 86 | match elem_index (fun w -> w == p) winners with 87 | | None -> continue k 1 (* Not among the winners *) 88 | | Some i -> continue k (i + 1) 89 | (* Among the winners, play the winning strategy (indices are zero-based) *) 90 | 91 | (* Some example strategy handlers *) 92 | let naive = strategy (fun _ -> ns) 93 | let perfect = strategy (fun _ -> ps) 94 | let bruteforce_bob = strategy (function Alice -> ps | Bob -> bf Bob) 95 | 96 | (** Computing game data **) 97 | (* The strategy handlers produce a single piece of data about games, 98 | namely, the winner of a particular game. We can generalise this idea 99 | to compute the game tree of a game. *) 100 | 101 | type gametree = Winner of player | Take of player * (int * gametree) list 102 | 103 | (* String representation of a gametree *) 104 | let rec string_of_gametree : gametree -> string = function 105 | | Winner p -> "Winner(" ^ string_of_player p ^ ")" 106 | | Take (p, ts) -> 107 | "Take" 108 | ^ string_of_pair string_of_player 109 | (string_of_list (string_of_pair string_of_int string_of_gametree)) 110 | (p, ts) 111 | 112 | and string_of_pair : 113 | 'a 'b. ('a -> string) -> ('b -> string) -> 'a * 'b -> string = 114 | fun string_of_x string_of_y (x, y) -> 115 | "(" ^ string_of_x x ^ ", " ^ string_of_y y ^ ")" 116 | 117 | and string_of_list string_of_x xs = 118 | "[" ^ String.concat "; " (List.map string_of_x xs) ^ "]" 119 | 120 | (* A zip that zips until either list has been exhausted. *) 121 | let rec zip xs ys = 122 | match (xs, ys) with 123 | | [], _ -> [] 124 | | _, [] -> [] 125 | | x :: xs, y :: ys -> (x, y) :: zip xs ys 126 | 127 | (* This function reifies a move as a node in the game tree *) 128 | let reify p n k = 129 | let subgames = mapk k (valid_moves n) in 130 | let subtrees = zip [ 1; 2; 3 ] subgames in 131 | Take (p, subtrees) 132 | 133 | let gametree m = 134 | match_with m () 135 | { 136 | retc = (fun v -> Winner v); 137 | exnc = (fun e -> raise e); 138 | effc = 139 | (fun (type a) (e : a Effect.t) -> 140 | match e with 141 | | Move (p, n) -> Some (fun (k : (a, _) continuation) -> reify p n k) 142 | | _ -> None); 143 | } 144 | 145 | (* We model Cheat as an exception parameterised by the player (the 146 | cheater) and the number of sticks the player took *) 147 | exception Cheat of player * int 148 | (** Cheat detection via effect forwarding **) 149 | 150 | let cheat p n = raise (Cheat (p, n)) 151 | 152 | (* A simple cheating strategy is to take all sticks, thereby winning 153 | in a single move *) 154 | let cs n k = continue k n 155 | let bob_cheats = strategy (function Alice -> ps | Bob -> cs) 156 | 157 | (* The cheat detection mechanism *) 158 | let check_move p n k = 159 | let m = move p n in 160 | if m < 1 || 3 < m then 161 | cheat p m (* player p cheats by making an illegal move m (m < 1 or 3 < m) *) 162 | else continue k m 163 | 164 | let checker m = 165 | try_with m () 166 | { 167 | effc = 168 | (fun (type a) (e : a Effect.t) -> 169 | match e with 170 | | Move (p, n) -> 171 | Some (fun (k : (a, _) continuation) -> check_move p n k) 172 | | _ -> None); 173 | } 174 | 175 | (* The following exception handler reports cheaters *) 176 | let cheat_report m = 177 | try m () 178 | with Cheat (p, n) -> 179 | failwith 180 | ("Cheater: " ^ string_of_player p ^ " took " ^ string_of_int n 181 | ^ " sticks!") 182 | 183 | (* Another way to deal with cheaters is to disqualify them *) 184 | let cheat_lose m = 185 | try m () with Cheat (Alice, _) -> Bob | Cheat (Bob, _) -> Alice 186 | 187 | (* The pipeline operator combines two handlers [h] and [g]. Data flows 188 | from [g] to [h]. *) 189 | let ( -<- ) h g m = h (fun () -> g m) 190 | 191 | (** Choosing between strategies **) 192 | type _ Effect.t += Choose : bool Effect.t 193 | 194 | let choose () = perform Choose 195 | 196 | (* Flip a coin to decide whether to interpret Choose as true or 197 | false *) 198 | let coin m = 199 | try_with m () 200 | { 201 | effc = 202 | (fun (type a) (e : a Effect.t) -> 203 | match e with 204 | | Choose -> 205 | Some 206 | (fun (k : (a, _) continuation) -> 207 | continue k (Random.float 1.0 > 0.5)) 208 | | _ -> None); 209 | } 210 | 211 | let bob_maybe_cheats m = 212 | let h = 213 | if choose () then strategy (fun _ -> ps) 214 | else strategy (function Alice -> ps | Bob -> cs) 215 | in 216 | h m 217 | 218 | (* The state effect is given by two operations 219 | 1) get to retrieve the current state, 220 | 2) and put to update the state *) 221 | (* State module is copied from KC's state example *) 222 | 223 | (** Stateful scoreboard **) 224 | module type STATE = sig 225 | type t 226 | 227 | val put : t -> unit 228 | val get : unit -> t 229 | val run : (unit -> 'a) -> init:t -> 'a 230 | end 231 | 232 | (* From: https://gist.github.com/kayceesrk/3c307d0340fbfc68435d4769ad447e10 *) 233 | module State (S : sig 234 | type t 235 | end) : STATE with type t = S.t = struct 236 | type t = S.t 237 | type _ Effect.t += Put : t -> unit Effect.t 238 | 239 | let put v = perform (Put v) 240 | 241 | type _ Effect.t += Get : t Effect.t 242 | 243 | let get () = perform Get 244 | 245 | let run (type a) (f : unit -> a) ~init : a = 246 | let comp = 247 | match_with f () 248 | { 249 | retc = (fun x s -> (s, x)); 250 | exnc = (fun e -> raise e); 251 | effc = 252 | (fun (type b) (e : b Effect.t) -> 253 | match e with 254 | | Get -> 255 | Some 256 | (fun (k : (b, t -> t * a) continuation) (s : t) -> 257 | continue k s s) 258 | | Put s' -> Some (fun k _s -> continue k () s') 259 | | e -> None); 260 | } 261 | in 262 | snd @@ comp init 263 | end 264 | 265 | type gamestate = (player * int) list 266 | 267 | module GS = State (struct 268 | type t = gamestate 269 | end) 270 | 271 | (* Get and put operations *) 272 | let get = GS.get 273 | let put = GS.put 274 | 275 | (* State handler with seed [s] *) 276 | let state s m = GS.run m ~init:s 277 | 278 | (* Initially both players have zero wins *) 279 | let s0 = [ (Alice, 0); (Bob, 0) ] 280 | 281 | (* Update scoreboard *) 282 | let increment_wins p = 283 | List.map (fun (p', n) -> if p == p' then (p', n + 1) else (p', n)) 284 | 285 | (* Post-processing handler that updates the scoreboard *) 286 | let score_updater m = match m () with p -> put (increment_wins p (get ())) 287 | 288 | (* Print the scoreboard *) 289 | let print_board s = 290 | let rec make_whitespace n = 291 | if n > 0 then " " ^ make_whitespace (n - 1) else "" 292 | in 293 | let s = 294 | List.map 295 | (fun (p, n) -> 296 | let player = string_of_player p in 297 | let wins = string_of_int n in 298 | "| " ^ player 299 | ^ make_whitespace (11 - String.length player) 300 | ^ "|" 301 | ^ make_whitespace (8 - String.length wins) 302 | ^ wins ^ " |") 303 | (List.sort 304 | (fun x y -> 305 | let n, n' = (snd x, snd y) in 306 | if n < n' then 1 else if n > n' then -1 else 0) 307 | s) 308 | in 309 | print_endline "/======================\\"; 310 | print_endline "| NIM HIGHSCORE |"; 311 | print_endline "|======================|"; 312 | print_endline "| Player | #Wins |"; 313 | print_endline "|============|=========|"; 314 | if List.length s > 1 then ( 315 | print_endline (List.hd s); 316 | List.fold_left 317 | (fun _ l -> 318 | print_endline "|============|=========|"; 319 | print_endline l) 320 | () (List.tl s)) 321 | else (); 322 | print_endline "\\======================/" 323 | 324 | (* Post-processing handler that prints the scoreboard *) 325 | let printer m = match m () with _ -> print_board (get ()) 326 | 327 | (* Replays a game after n times *) 328 | let rec replay n m = match m () with _ when n > 0 -> replay (n - 1) m | x -> x 329 | 330 | let run_examples () = 331 | print_endline 332 | (">> game 7 |> perfect :\n" ^ string_of_player (game 7 |> perfect)); 333 | print_endline 334 | (">> game 12 |> perfect :\n" ^ string_of_player (game 12 |> perfect)); 335 | 336 | (* Computing game tree *) 337 | print_endline 338 | (">> game 3 |> gametree:\n" ^ string_of_gametree (game 3 |> gametree)); 339 | 340 | (* A stateful scoreboard *) 341 | print_endline 342 | ">> game 7 |> (state s0) -<- printer -<- (replay 10) -<- coin -<- \ 343 | score_updater -<- bob_maybe_cheats :"; 344 | let _ = 345 | game 7 346 | |> state s0 -<- printer -<- replay 10 -<- coin -<- score_updater 347 | -<- bob_maybe_cheats 348 | in 349 | 350 | (* Cheat detection example *) 351 | print_endline ">> game 7 |> cheat_report -<- bob_cheats -<- checker :\n"; 352 | let _ = game 7 |> cheat_report -<- bob_cheats -<- checker in 353 | () 354 | 355 | let _ = run_examples () 356 | -------------------------------------------------------------------------------- /multishot/nondeterminism.ml: -------------------------------------------------------------------------------- 1 | (* This example is adapted from Kammar et. al (2013) *) 2 | open Effect 3 | (** Coin flipping -- non-determinism as an algebraic effect **) 4 | 5 | open Effect.Deep 6 | 7 | (* Non-determinism is an effect given by an operation Choose, that 8 | returns a boolean. *) 9 | type _ Effect.t += Choose : bool Effect.t 10 | 11 | let choose () = perform Choose 12 | 13 | (* An example non-deterministic computation: A coin toss *) 14 | type toss = Heads | Tails 15 | 16 | let toss () = if choose () then Heads else Tails 17 | 18 | (* Fixed interpretations *) 19 | let make_charged_handler (b : bool) m = 20 | try_with m () 21 | { 22 | effc = 23 | (fun (type a) (e : a Effect.t) -> 24 | match e with 25 | | Choose -> Some (fun (k : (a, _) continuation) -> continue k b) 26 | | _ -> None); 27 | } 28 | 29 | let positive = make_charged_handler true (* always interpret as true *) 30 | let negative = make_charged_handler false (* always interpret as false *) 31 | 32 | (* [all_results] enumerates every possible outcome of a 33 | non-deterministic computation *) 34 | let all_results m = 35 | match_with m () 36 | { 37 | retc = (fun v -> [ v ]); 38 | exnc = raise; 39 | effc = 40 | (fun (type a) (e : a Effect.t) -> 41 | match e with 42 | | Choose -> 43 | Some 44 | (fun (k : (a, _) continuation) -> 45 | continue k true 46 | @ continue (Multicont.Deep.clone_continuation k) false) 47 | | _ -> None); 48 | } 49 | 50 | (* OCaml effects/multicore only supports single-shot 51 | continuations. But, we can simulate multi-shot continuations by 52 | copying a continuation (using Obj.clone) before invocation. *) 53 | 54 | (* Random interpretation *) 55 | let coin m = 56 | try_with m () 57 | { 58 | effc = 59 | (fun (type a) (e : a Effect.t) -> 60 | match e with 61 | | Choose -> 62 | Some 63 | (fun (k : (a, _) continuation) -> 64 | continue k (Random.float 1.0 > 0.5)) 65 | | _ -> None); 66 | } 67 | 68 | (* Another example: A drunken coin toss. A drunkard may fail to catch 69 | the coin. *) 70 | exception Too_drunk 71 | 72 | let too_drunk () = raise Too_drunk 73 | let drunk_toss () = if choose () then too_drunk () else toss () 74 | 75 | (* This exception handler returns Some result if [m] was successful, 76 | otherwise it returns None. *) 77 | let optionalize m = try Some (m ()) with Too_drunk -> None 78 | 79 | (* This exception handler restarts [m] whenever it fails. *) 80 | let rec persevere m = try m () with Too_drunk -> persevere m 81 | 82 | (* The pipeline operator combines two handlers [h] and [g]. Data flows 83 | from [g] to [h]. *) 84 | let ( -<- ) h g m = h (fun () -> g m) 85 | 86 | (* Running some examples + boilerplate conversions *) 87 | let string_of_toss = function Heads -> "Heads" | Tails -> "Tails" 88 | 89 | let string_of_list string_of_e xs = 90 | let xs = List.map string_of_e xs in 91 | "[" 92 | ^ (if List.length xs > 1 then 93 | List.fold_left (fun xs x -> xs ^ ", " ^ x) (List.hd xs) (List.tl xs) 94 | else List.hd xs) 95 | ^ "]" 96 | 97 | let string_of_option string_of_e = function 98 | | Some e -> "Some (" ^ string_of_e e ^ ")" 99 | | None -> "None" 100 | 101 | let run_examples () = 102 | print_endline (">> positive toss : " ^ string_of_toss (positive toss)); 103 | 104 | print_endline (">> negative toss : " ^ string_of_toss (negative toss)); 105 | 106 | print_endline 107 | (">> all_results toss: " ^ string_of_list string_of_toss (all_results toss)); 108 | 109 | print_endline (">> coin toss : " ^ string_of_toss (coin toss)); 110 | 111 | print_endline 112 | (">> toss |> optionalize -<- all_results : " 113 | ^ string_of_option 114 | (string_of_list string_of_toss) 115 | (toss |> optionalize -<- all_results)); 116 | 117 | print_endline 118 | (">> toss |> all_results -<- optionalize : " 119 | ^ string_of_list 120 | (string_of_option string_of_toss) 121 | (toss |> all_results -<- optionalize)); 122 | 123 | print_endline 124 | (">> drunk_toss |> optionalize -<- all_results : " 125 | ^ string_of_option 126 | (string_of_list string_of_toss) 127 | (drunk_toss |> optionalize -<- all_results)); 128 | 129 | print_endline 130 | (">> drunk_toss |> all_results -<- optionalize : " 131 | ^ string_of_list 132 | (string_of_option string_of_toss) 133 | (drunk_toss |> all_results -<- optionalize)); 134 | 135 | print_endline 136 | (">> drunk_toss |> optionalize -<- coin : " 137 | ^ string_of_option string_of_toss (drunk_toss |> optionalize -<- coin)); 138 | 139 | print_endline 140 | (">> drunk_toss |> peservere -<- coin : " 141 | ^ string_of_toss (drunk_toss |> persevere -<- coin)) 142 | 143 | let _ = run_examples () 144 | -------------------------------------------------------------------------------- /multishot/queens.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | (* Ported from: https://github.com/effect-handlers/effect-handlers-bench/blob/d4a32ec337b77859c328a1103e195d3e4b3dcb5b/benchmarks/ocaml/001_nqueens/001_nqueens_ocaml.ml *) 5 | let n = try int_of_string Sys.argv.(1) with _ -> 8 6 | 7 | let rec safe queen diag xs = 8 | match xs with 9 | | [] -> true 10 | | q :: qs -> 11 | queen <> q 12 | && queen <> q + diag 13 | && queen <> q - diag 14 | && safe queen (diag + 1) qs 15 | 16 | type _ Effect.t += Pick : int -> int Effect.t 17 | 18 | exception Fail 19 | 20 | let rec find_solution n col : int list = 21 | if col = 0 then [] 22 | else 23 | let sol = find_solution n (col - 1) in 24 | let queen = perform (Pick n) in 25 | if safe queen 1 sol then queen :: sol else raise Fail 26 | 27 | let queens_count n = 28 | match_with (find_solution n) n 29 | { 30 | retc = (fun _ -> 1); 31 | exnc = (function Fail -> 0 | e -> raise e); 32 | effc = 33 | (fun (type a) (e : a Effect.t) -> 34 | match e with 35 | | Pick n -> 36 | Some 37 | (fun (k : (a, _) continuation) -> 38 | let rec loop i acc = 39 | if i = n then continue k i + acc 40 | else 41 | loop (i + 1) 42 | (continue (Multicont.Deep.clone_continuation k) i + acc) 43 | in 44 | loop 1 0) 45 | | _ -> None); 46 | } 47 | 48 | let queens_choose n = 49 | match_with (find_solution n) n 50 | { 51 | retc = (fun x -> [ x ]); 52 | exnc = (function Fail -> [] | e -> raise e); 53 | effc = 54 | (fun (type a) (e : a Effect.t) -> 55 | match e with 56 | | Pick n -> 57 | Some 58 | (fun (k : (a, _) continuation) -> 59 | let rec loop i acc : int list list = 60 | if i = 1 then continue k i @ acc 61 | else 62 | loop (i - 1) 63 | (continue (Multicont.Deep.clone_continuation k) i @ acc) 64 | in 65 | loop n []) 66 | | _ -> None); 67 | } 68 | 69 | let print_all_solutions () = 70 | let sols = queens_choose n in 71 | List.iter 72 | (fun l -> 73 | List.iter (fun pos -> Printf.printf "%d " pos) l; 74 | print_endline "") 75 | sols 76 | 77 | let _ = 78 | print_all_solutions (); 79 | Printf.printf "%d\n" (queens_count n) 80 | -------------------------------------------------------------------------------- /mvar/MVar.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | 4 | val create : 'a -> 'a t 5 | val create_empty : unit -> 'a t 6 | val put : 'a -> 'a t -> unit 7 | val take : 'a t -> 'a 8 | end 9 | 10 | module type SCHED = sig 11 | type 'a cont 12 | type _ eff += Suspend : ('a cont -> unit) -> 'a eff 13 | type _ eff += Resume : 'a cont * 'a -> unit eff 14 | end 15 | 16 | module Make (S : SCHED) : S = struct 17 | open Effect 18 | 19 | (** The state of mvar is either [Full v q] filled with value [v] and a queue 20 | [q] of threads waiting to fill the mvar, or [Empty q], with a queue [q] of 21 | threads waiting to empty the mvar. *) 22 | type 'a mv_state = 23 | | Full of 'a * ('a * unit S.cont) Queue.t 24 | | Empty of 'a S.cont Queue.t 25 | 26 | type 'a t = 'a mv_state ref 27 | 28 | let create_empty () = ref (Empty (Queue.create ())) 29 | let create v = ref (Full (v, Queue.create ())) 30 | let suspend f = perform @@ S.Suspend f 31 | let resume (a, b) = perform @@ S.Resume (a, b) 32 | 33 | let put v mv = 34 | match !mv with 35 | | Full (v', q) -> suspend (fun k -> Queue.push (v, k) q) 36 | | Empty q -> 37 | if Queue.is_empty q then mv := Full (v, Queue.create ()) 38 | else 39 | let t = Queue.pop q in 40 | resume (t, v) 41 | 42 | let take mv = 43 | match !mv with 44 | | Empty q -> suspend (fun k -> Queue.push k q) 45 | | Full (v, q) -> 46 | if Queue.is_empty q then ( 47 | mv := Empty (Queue.create ()); 48 | v) 49 | else 50 | let v', t = Queue.pop q in 51 | mv := Full (v', q); 52 | resume (t, ()); 53 | v 54 | end 55 | -------------------------------------------------------------------------------- /mvar/MVar.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | (** MVar type. Represents a data structure with a single hole that can be 4 | filled with value. *) 5 | 6 | val create : 'a -> 'a t 7 | (** [create v] allocates a new mvar with the hole filled with value [v]. *) 8 | 9 | val create_empty : unit -> 'a t 10 | (** [create_empty ()] allocates a new mvar with the hole empty. *) 11 | 12 | val put : 'a -> 'a t -> unit 13 | (** [put v m] fills mvar [m] with value v. If the mvar is already filled, 14 | this operation blocks until the hole become empty. *) 15 | 16 | val take : 'a t -> 'a 17 | (** [take m] empties the mvar [m] if it is filled and returns the value. 18 | If [m] is empty, then the operation blocks until the mvar becomes filled. *) 19 | end 20 | 21 | module type SCHED = sig 22 | type 'a cont 23 | (** Represents a blocked computation that waits for a value of type 'a. *) 24 | 25 | type _ eff += 26 | | Suspend : ('a cont -> unit) -> 'a eff 27 | (** [perform @@ Suspend f] applies [f] to the current continuation, and suspends the 28 | execution of the current thread, and switches to the next thread in the 29 | scheduler's queue. *) 30 | 31 | type _ eff += 32 | | Resume : 'a cont * 'a -> unit eff 33 | (** [Perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and 34 | enqueues it to the scheduler queue. *) 35 | end 36 | 37 | module Make (S : SCHED) : S 38 | -------------------------------------------------------------------------------- /mvar/MVar_monad.ml: -------------------------------------------------------------------------------- 1 | module S = Sched_monad 2 | 3 | (** The state of mvar is either [Full v q] filled with value [v] and a queue 4 | [q] of threads waiting to fill the mvar, or [Empty q], with a queue [q] of 5 | threads waiting to empty the mvar. *) 6 | type 'a mv_state = 7 | | Full of 'a * ('a * unit S.cont) Queue.t 8 | | Empty of 'a S.cont Queue.t 9 | 10 | type 'a t = 'a mv_state ref 11 | 12 | let create_empty () = ref (Empty (Queue.create ())) 13 | let create v = ref (Full (v, Queue.create ())) 14 | 15 | let put mv v = 16 | S.suspend (fun k -> 17 | match !mv with 18 | | Full (v', q) -> 19 | Queue.push (v, k) q; 20 | None 21 | | Empty q -> 22 | if Queue.is_empty q then ( 23 | mv := Full (v, Queue.create ()); 24 | Some ((), None)) 25 | else 26 | let t = Queue.pop q in 27 | Some ((), Some (S.prepare t v))) 28 | 29 | let ( >> ) = S.( >> ) 30 | 31 | let take mv = 32 | S.suspend (fun k -> 33 | match !mv with 34 | | Empty q -> 35 | Queue.push k q; 36 | None 37 | | Full (v, q) -> 38 | if Queue.is_empty q then ( 39 | mv := Empty (Queue.create ()); 40 | Some (v, None)) 41 | else 42 | let v', t = Queue.pop q in 43 | mv := Full (v', q); 44 | Printf.printf "take: resume\n"; 45 | Some (v, Some (S.prepare t ()))) 46 | -------------------------------------------------------------------------------- /mvar/MVar_monad.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val create : 'a -> 'a t 4 | val create_empty : unit -> 'a t 5 | val put : 'a t -> 'a -> unit Sched_monad.t 6 | val take : 'a t -> 'a Sched_monad.t 7 | -------------------------------------------------------------------------------- /mvar/MVar_test.ml: -------------------------------------------------------------------------------- 1 | module MVar = MVar.Make (Sched) 2 | open MVar 3 | open Printf 4 | open Sched 5 | 6 | let mv = create_empty () 7 | let fork f = Effect.perform @@ Fork f 8 | 9 | let put x = 10 | printf "Before put: %s\n" x; 11 | put x mv; 12 | printf "After put: %s\n" x 13 | 14 | let get () = 15 | let () = printf "Before get\n" in 16 | let v = take mv in 17 | let () = printf "After get: %s\n" v in 18 | v 19 | 20 | let main () = 21 | put "1"; 22 | fork (fun () -> put "2"); 23 | fork (fun () -> put "3"); 24 | fork (fun () -> ignore (get ())); 25 | fork (fun () -> ignore (get ())); 26 | fork (fun () -> ignore (get ())) 27 | 28 | let () = run main 29 | -------------------------------------------------------------------------------- /mvar/Makefile: -------------------------------------------------------------------------------- 1 | EXE := chameneos.exe chameneos_monad.exe MVar_test.exe chameneos_systhr.exe \ 2 | chameneos_lwt.exe 3 | 4 | all: $(EXE) 5 | 6 | MVar_test.exe: MVar_test.ml 7 | ocamlopt -o MVar_test.exe sched.mli sched.ml MVar.mli MVar.ml MVar_test.ml 8 | 9 | chameneos_systhr.exe: chameneos_systhr.ml 10 | ocamlfind ocamlc -o chameneos-systhr.exe -thread -package threads \ 11 | -linkpkg chameneos_systhr.ml 12 | 13 | chameneos_lwt.exe: chameneos_lwt.ml 14 | ocamlfind ocamlc -o chameneos-lwt.exe -thread -package lwt,lwt.unix,threads \ 15 | -linkpkg chameneos_lwt.ml 16 | 17 | chameneos-ghc.exe: chameneos.hs 18 | ghc -o chameneos-ghc.exe -cpp -XBangPatterns -XScopedTypeVariables \ 19 | -XGeneralizedNewtypeDeriving chameneos.hs 20 | 21 | chameneos.exe: chameneos.ml 22 | ocamlopt -o chameneos.exe sched.mli sched.ml MVar.mli MVar.ml chameneos.ml 23 | 24 | chameneos_monad.exe: chameneos_monad.ml 25 | ocamlopt -o chameneos_monad.exe sched_monad.mli sched_monad.ml \ 26 | MVar_monad.mli MVar_monad.ml chameneos_monad.ml 27 | 28 | clean: 29 | rm -f *.cmi *.cmx a.out *~ eff *.cmo MVar_test chameneos-eff chameneos-ghc \ 30 | *.hi *.o $(EXE) 31 | -------------------------------------------------------------------------------- /mvar/chameneos.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | import Control.Monad 3 | import Data.Char 4 | import Data.IORef 5 | import System.Environment 6 | import System.IO 7 | import GHC.Conc 8 | import Foreign hiding (complement) 9 | 10 | newtype Color = C Int deriving (Storable,Enum) 11 | 12 | #define Y (C 2) 13 | #define R (C 1) 14 | #define B (C 0) 15 | 16 | instance Show Color where 17 | show Y = "yellow" 18 | show R = "red" 19 | show B = "blue" 20 | 21 | complement :: Color -> Color -> Color 22 | complement !a !b = case a of 23 | B -> case b of R -> Y; B -> B; _ -> R 24 | R -> case b of B -> Y; R -> R; _ -> B 25 | Y -> case b of B -> R; Y -> Y; _ -> B 26 | 27 | type Chameneous = Ptr Color 28 | data MP = Nobody !Int | Somebody !Int !Chameneous !(MVar Chameneous) 29 | 30 | arrive :: MVar MP -> MVar (Int, Int) -> Chameneous -> IO () 31 | arrive !mpv !finish !ch = do 32 | waker <- newEmptyMVar 33 | let inc x = (fromEnum (ch == x) +) 34 | go !t !(b::Int) = do 35 | w <- takeMVar mpv 36 | case w of 37 | Nobody 0 -> do 38 | putMVar mpv w 39 | putMVar finish (t, b) 40 | Nobody q -> do 41 | putMVar mpv $ Somebody q ch waker 42 | ch' <- takeMVar waker 43 | go (t+1) $ inc ch' b 44 | 45 | Somebody q ch' waker' -> do 46 | let !q' = q-1 47 | putMVar mpv $ Nobody q' 48 | c <- peek ch 49 | c' <- peek ch' 50 | let !c'' = complement c c' 51 | poke ch c'' 52 | poke ch' c'' 53 | putMVar waker' ch 54 | go (t+1) $ inc ch' b 55 | go 0 0 56 | 57 | showN = unwords . map ((digits !!) . digitToInt) . show 58 | 59 | digits = words "zero one two three four five six seven eight nine" 60 | 61 | run :: Int -> Int -> [Color] -> IO (IO ()) 62 | run n cpu cs = do 63 | fs <- replicateM (length cs) newEmptyMVar 64 | mpv <- newMVar (Nobody n) 65 | withArrayLen cs $ \ n cols -> do 66 | zipWithM_ ((forkOn cpu .) . arrive mpv) fs (take n (iterate (`advancePtr` 1) cols)) 67 | 68 | return $ do 69 | putStrLn . map toLower . unwords . ([]:) . map show $ cs 70 | ns <- mapM takeMVar fs 71 | putStr . map toLower . unlines $ [unwords [show n, showN b] | (n, b) <- ns] 72 | putStrLn . (" "++) . showN . sum . map fst $ ns 73 | putStrLn "" 74 | 75 | main = do 76 | putStrLn . map toLower . unlines $ 77 | [unwords [show a, "+", show b, "->", show $ complement a b] 78 | | a <- [B..Y], b <- [B..Y]] 79 | 80 | n <- readIO . head =<< getArgs 81 | actions <- zipWithM (run n) [0..] [[B..Y],[B,R,Y,R,Y,B,R,Y,R,B]] 82 | sequence_ actions 83 | -------------------------------------------------------------------------------- /mvar/chameneos.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | module List = ListLabels 3 | module String = StringLabels 4 | open Printf 5 | 6 | module Color = struct 7 | type t = Blue | Red | Yellow 8 | 9 | let complement t t' = 10 | match (t, t') with 11 | | Blue, Blue -> Blue 12 | | Blue, Red -> Yellow 13 | | Blue, Yellow -> Red 14 | | Red, Blue -> Yellow 15 | | Red, Red -> Red 16 | | Red, Yellow -> Blue 17 | | Yellow, Blue -> Red 18 | | Yellow, Red -> Blue 19 | | Yellow, Yellow -> Yellow 20 | 21 | let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" 22 | let all = [ Blue; Red; Yellow ] 23 | end 24 | 25 | module MVar = MVar.Make (Sched) 26 | 27 | type chameneos = Color.t ref 28 | type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t 29 | 30 | let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = 31 | let waker = MVar.create_empty () in 32 | let inc x i = if x == ch then i + 1 else i in 33 | let rec go t b = 34 | let w = MVar.take mpv in 35 | match w with 36 | | Nobody 0 -> 37 | MVar.put w mpv; 38 | MVar.put (t, b) finish 39 | | Nobody q -> 40 | MVar.put (Somebody (q, ch, waker)) mpv; 41 | go (t + 1) @@ inc (MVar.take waker) b 42 | | Somebody (q, ch', waker') -> 43 | MVar.put (Nobody (q - 1)) mpv; 44 | let c'' = Color.complement !ch !ch' in 45 | ch := c''; 46 | ch' := c''; 47 | MVar.put ch waker'; 48 | go (t + 1) @@ inc ch' b 49 | in 50 | go 0 0 51 | 52 | let spell_int i = 53 | let spell_char = function 54 | | '0' -> "zero" 55 | | '1' -> "one" 56 | | '2' -> "two" 57 | | '3' -> "three" 58 | | '4' -> "four" 59 | | '5' -> "five" 60 | | '6' -> "six" 61 | | '7' -> "seven" 62 | | '8' -> "eight" 63 | | '9' -> "nine" 64 | | x -> failwith "unexpected char" 65 | in 66 | let s = string_of_int i in 67 | String.iter s ~f:(fun c -> printf " %s" (spell_char c)) 68 | 69 | let print_complements () = 70 | List.iter Color.all ~f:(fun c1 -> 71 | List.iter Color.all ~f:(fun c2 -> 72 | printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) 73 | (Color.to_string (Color.complement c1 c2)))); 74 | printf "\n" 75 | 76 | let rec tabulate' acc f = function 77 | | 0 -> acc 78 | | n -> tabulate' (f () :: acc) f (n - 1) 79 | 80 | let tabulate f n = List.rev @@ tabulate' [] f n 81 | let fork f = perform @@ Sched.Fork f 82 | 83 | let work colors n = 84 | let () = 85 | List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); 86 | printf "\n" 87 | in 88 | let fs = tabulate MVar.create_empty (List.length colors) in 89 | let mpv = MVar.create (Nobody n) in 90 | let chams = List.map ~f:(fun c -> ref c) colors in 91 | let () = 92 | List.iter2 ~f:(fun fin ch -> fork (fun () -> arrive mpv fin ch)) fs chams 93 | in 94 | let ns = List.map ~f:MVar.take fs in 95 | let () = 96 | List.iter 97 | ~f:(fun (n, b) -> 98 | print_int n; 99 | spell_int b; 100 | printf "\n") 101 | ns 102 | in 103 | let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in 104 | spell_int sum_meets; 105 | printf "\n" 106 | 107 | let main () = 108 | let n = try int_of_string Sys.argv.(1) with _ -> 600 in 109 | print_complements (); 110 | let module C = Color in 111 | work [ C.Blue; C.Red; C.Yellow ] n; 112 | printf "\n"; 113 | work 114 | [ 115 | C.Blue; 116 | C.Red; 117 | C.Yellow; 118 | C.Red; 119 | C.Yellow; 120 | C.Blue; 121 | C.Red; 122 | C.Yellow; 123 | C.Red; 124 | C.Blue; 125 | ] 126 | n; 127 | printf "\n" 128 | 129 | let () = Sched.run main 130 | -------------------------------------------------------------------------------- /mvar/chameneos_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let ( >> ) a b = a >>= fun () -> b 4 | 5 | module MVar = Lwt_mvar 6 | module List = ListLabels 7 | module String = StringLabels 8 | open Printf 9 | 10 | module Color = struct 11 | type t = Blue | Red | Yellow 12 | 13 | let complement t t' = 14 | match (t, t') with 15 | | Blue, Blue -> Blue 16 | | Blue, Red -> Yellow 17 | | Blue, Yellow -> Red 18 | | Red, Blue -> Yellow 19 | | Red, Red -> Red 20 | | Red, Yellow -> Blue 21 | | Yellow, Blue -> Red 22 | | Yellow, Red -> Blue 23 | | Yellow, Yellow -> Yellow 24 | 25 | let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" 26 | let all = [ Blue; Red; Yellow ] 27 | end 28 | 29 | type chameneos = Color.t ref 30 | type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t 31 | 32 | let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = 33 | let waker = MVar.create_empty () in 34 | let inc x i = if x == ch then i + 1 else i in 35 | let rec go t b = 36 | MVar.take mpv >>= fun w -> 37 | match w with 38 | | Nobody 0 -> MVar.put mpv w >> MVar.put finish (t, b) 39 | | Nobody q -> 40 | Lwt.pause () 41 | >> MVar.put mpv (Somebody (q, ch, waker)) 42 | >> MVar.take waker 43 | >>= fun w' -> go (t + 1) @@ inc w' b 44 | | Somebody (q, ch', waker') -> 45 | Lwt.pause () 46 | >> MVar.put mpv (Nobody (q - 1)) 47 | >> 48 | let c'' = Color.complement !ch !ch' in 49 | ch := c''; 50 | ch' := c''; 51 | MVar.put waker' ch >> go (t + 1) @@ inc ch' b 52 | in 53 | go 0 0 54 | 55 | let spell_int i = 56 | let spell_char = function 57 | | '0' -> "zero" 58 | | '1' -> "one" 59 | | '2' -> "two" 60 | | '3' -> "three" 61 | | '4' -> "four" 62 | | '5' -> "five" 63 | | '6' -> "six" 64 | | '7' -> "seven" 65 | | '8' -> "eight" 66 | | '9' -> "nine" 67 | | x -> failwith "unexpected char" 68 | in 69 | let s = string_of_int i in 70 | String.iter s ~f:(fun c -> printf " %s" (spell_char c)) 71 | 72 | let print_complements () = 73 | List.iter Color.all ~f:(fun c1 -> 74 | List.iter Color.all ~f:(fun c2 -> 75 | printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) 76 | (Color.to_string (Color.complement c1 c2)))); 77 | printf "\n" 78 | 79 | let rec tabulate' acc f = function 80 | | 0 -> acc 81 | | n -> tabulate' (f () :: acc) f (n - 1) 82 | 83 | let tabulate f n = List.rev @@ tabulate' [] f n 84 | 85 | let work colors n = 86 | let () = 87 | List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); 88 | printf "\n" 89 | in 90 | let fs = tabulate MVar.create_empty (List.length colors) in 91 | let mpv = MVar.create (Nobody n) in 92 | let chams = List.map ~f:(fun c -> ref c) colors in 93 | let comb = List.combine fs chams in 94 | Lwt_list.iter_p (fun (fin, ch) -> arrive mpv fin ch) comb 95 | >> Lwt_list.map_p MVar.take fs 96 | >>= fun ns -> 97 | let () = 98 | List.iter 99 | ~f:(fun (n, b) -> 100 | print_int n; 101 | spell_int b; 102 | printf "\n") 103 | ns 104 | in 105 | let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in 106 | spell_int sum_meets; 107 | printf "\n"; 108 | return () 109 | 110 | let main = 111 | let n = try int_of_string Sys.argv.(1) with _ -> 600 in 112 | print_complements (); 113 | let module C = Color in 114 | work [ C.Blue; C.Red; C.Yellow ] n >>= fun () -> 115 | printf "\n"; 116 | work 117 | [ 118 | C.Blue; 119 | C.Red; 120 | C.Yellow; 121 | C.Red; 122 | C.Yellow; 123 | C.Blue; 124 | C.Red; 125 | C.Yellow; 126 | C.Red; 127 | C.Blue; 128 | ] 129 | n 130 | >>= fun () -> 131 | printf "\n"; 132 | return () 133 | 134 | let () = Lwt_main.run main 135 | -------------------------------------------------------------------------------- /mvar/chameneos_monad.ml: -------------------------------------------------------------------------------- 1 | open Sched_monad 2 | 3 | let ( >> ) a b = a >>= fun () -> b 4 | 5 | module MVar = MVar_monad 6 | module List = ListLabels 7 | module String = StringLabels 8 | open Printf 9 | 10 | module Color = struct 11 | type t = Blue | Red | Yellow 12 | 13 | let complement t t' = 14 | match (t, t') with 15 | | Blue, Blue -> Blue 16 | | Blue, Red -> Yellow 17 | | Blue, Yellow -> Red 18 | | Red, Blue -> Yellow 19 | | Red, Red -> Red 20 | | Red, Yellow -> Blue 21 | | Yellow, Blue -> Red 22 | | Yellow, Red -> Blue 23 | | Yellow, Yellow -> Yellow 24 | 25 | let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" 26 | let all = [ Blue; Red; Yellow ] 27 | end 28 | 29 | type chameneos = Color.t ref 30 | type mp = Nobody of int | Somebody of int * chameneos * chameneos MVar.t 31 | 32 | let arrive (mpv : mp MVar.t) (finish : (int * int) MVar.t) (ch : chameneos) = 33 | let waker = MVar.create_empty () in 34 | let inc x i = if x == ch then i + 1 else i in 35 | let rec go t b = 36 | MVar.take mpv >>= fun w -> 37 | match w with 38 | | Nobody 0 -> MVar.put mpv w >> MVar.put finish (t, b) 39 | | Nobody q -> 40 | yield >> MVar.put mpv (Somebody (q, ch, waker)) >> MVar.take waker 41 | >>= fun w' -> go (t + 1) @@ inc w' b 42 | | Somebody (q, ch', waker') -> 43 | yield 44 | >> MVar.put mpv (Nobody (q - 1)) 45 | >> 46 | let c'' = Color.complement !ch !ch' in 47 | let () = ch := c'' in 48 | let () = ch' := c'' in 49 | MVar.put waker' ch >> go (t + 1) @@ inc ch' b 50 | in 51 | go 0 0 52 | 53 | let spell_int i = 54 | let spell_char = function 55 | | '0' -> "zero" 56 | | '1' -> "one" 57 | | '2' -> "two" 58 | | '3' -> "three" 59 | | '4' -> "four" 60 | | '5' -> "five" 61 | | '6' -> "six" 62 | | '7' -> "seven" 63 | | '8' -> "eight" 64 | | '9' -> "nine" 65 | | x -> failwith "unexpected char" 66 | in 67 | let s = string_of_int i in 68 | String.iter s ~f:(fun c -> printf " %s" (spell_char c)) 69 | 70 | let print_complements () = 71 | List.iter Color.all ~f:(fun c1 -> 72 | List.iter Color.all ~f:(fun c2 -> 73 | printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) 74 | (Color.to_string (Color.complement c1 c2)))); 75 | printf "\n" 76 | 77 | let rec tabulate' acc f = function 78 | | 0 -> acc 79 | | n -> tabulate' (f () :: acc) f (n - 1) 80 | 81 | let tabulate f n = List.rev @@ tabulate' [] f n 82 | 83 | let work colors n = 84 | let () = 85 | List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); 86 | printf "\n" 87 | in 88 | let fs = tabulate MVar.create_empty (List.length colors) in 89 | let mpv = MVar.create (Nobody n) in 90 | let chams = List.map ~f:(fun c -> ref c) colors in 91 | let comb = List.combine fs chams in 92 | iter_p (fun (fin, ch) -> fork (arrive mpv fin ch)) comb >> map_p MVar.take fs 93 | >>= fun ns -> 94 | let () = 95 | List.iter 96 | ~f:(fun (n, b) -> 97 | print_int n; 98 | spell_int b; 99 | printf "\n") 100 | ns 101 | in 102 | let sum_meets = List.fold_left ~init:0 ~f:(fun acc (n, _) -> n + acc) ns in 103 | let () = spell_int sum_meets in 104 | let () = printf "\n" in 105 | return () 106 | 107 | let main = 108 | let n = try int_of_string Sys.argv.(1) with _ -> 600 in 109 | print_complements (); 110 | let module C = Color in 111 | work [ C.Blue; C.Red; C.Yellow ] n >>= fun () -> 112 | printf "\n"; 113 | work 114 | [ 115 | C.Blue; 116 | C.Red; 117 | C.Yellow; 118 | C.Red; 119 | C.Yellow; 120 | C.Blue; 121 | C.Red; 122 | C.Yellow; 123 | C.Red; 124 | C.Blue; 125 | ] 126 | n 127 | >>= fun () -> 128 | printf "\n"; 129 | return () 130 | 131 | let () = run main 132 | -------------------------------------------------------------------------------- /mvar/chameneos_systhr.ml: -------------------------------------------------------------------------------- 1 | module List = ListLabels 2 | module String = StringLabels 3 | open Printf 4 | 5 | module Color = struct 6 | type t = Blue | Red | Yellow 7 | 8 | let complement t t' = 9 | match (t, t') with 10 | | Blue, Blue -> Blue 11 | | Blue, Red -> Yellow 12 | | Blue, Yellow -> Red 13 | | Red, Blue -> Yellow 14 | | Red, Red -> Red 15 | | Red, Yellow -> Blue 16 | | Yellow, Blue -> Red 17 | | Yellow, Red -> Blue 18 | | Yellow, Yellow -> Yellow 19 | 20 | let to_string = function Blue -> "blue" | Red -> "red" | Yellow -> "yellow" 21 | let all = [ Blue; Red; Yellow ] 22 | end 23 | 24 | module Meeting_place = struct 25 | type 'chameneos t = { 26 | mutable state : [ `Empty | `First of 'chameneos | `Second of 'chameneos ]; 27 | mutable meetings_left : int; 28 | mutex : Mutex.t; 29 | wait_for_second : Condition.t; 30 | wait_for_empty : Condition.t; 31 | } 32 | 33 | let create n = 34 | { 35 | state = `Empty; 36 | meetings_left = n; 37 | mutex = Mutex.create (); 38 | wait_for_second = Condition.create (); 39 | wait_for_empty = Condition.create (); 40 | } 41 | 42 | let meet t c = 43 | let rec loop () = 44 | if t.meetings_left = 0 then ( 45 | Condition.broadcast t.wait_for_empty; 46 | None) 47 | else 48 | match t.state with 49 | | `Empty -> ( 50 | t.state <- `First c; 51 | Condition.wait t.wait_for_second t.mutex; 52 | match t.state with 53 | | `Empty | `First _ -> assert false 54 | | `Second c -> 55 | t.state <- `Empty; 56 | Condition.signal t.wait_for_empty; 57 | Condition.signal t.wait_for_empty; 58 | Some c) 59 | | `First c1 -> 60 | t.state <- `Second c; 61 | t.meetings_left <- t.meetings_left - 1; 62 | Condition.signal t.wait_for_second; 63 | Some c1 64 | | `Second _ -> 65 | Condition.wait t.wait_for_empty t.mutex; 66 | loop () 67 | in 68 | Mutex.lock t.mutex; 69 | let res = loop () in 70 | Mutex.unlock t.mutex; 71 | res 72 | end 73 | 74 | module Chameneos = struct 75 | type t = { 76 | id : int; 77 | mutable color : Color.t; 78 | mutable meetings : int; 79 | mutable meetings_with_self : int; 80 | } 81 | 82 | let create = 83 | let id = ref 0 in 84 | let new_id () = 85 | let r = !id in 86 | id := r + 1; 87 | r 88 | in 89 | fun color -> { id = new_id (); color; meetings = 0; meetings_with_self = 0 } 90 | 91 | let run t place = 92 | let rec loop () = 93 | match Meeting_place.meet place t with 94 | | None -> () 95 | | Some other -> 96 | t.meetings <- t.meetings + 1; 97 | if t.id = other.id then 98 | t.meetings_with_self <- t.meetings_with_self + 1; 99 | t.color <- Color.complement t.color other.color; 100 | loop () 101 | in 102 | Thread.create loop () 103 | end 104 | 105 | let print_complements () = 106 | List.iter Color.all ~f:(fun c1 -> 107 | List.iter Color.all ~f:(fun c2 -> 108 | printf "%s + %s -> %s\n" (Color.to_string c1) (Color.to_string c2) 109 | (Color.to_string (Color.complement c1 c2)))); 110 | printf "\n" 111 | 112 | let spell_int i = 113 | let spell_char = function 114 | | '0' -> "zero" 115 | | '1' -> "one" 116 | | '2' -> "two" 117 | | '3' -> "three" 118 | | '4' -> "four" 119 | | '5' -> "five" 120 | | '6' -> "six" 121 | | '7' -> "seven" 122 | | '8' -> "eight" 123 | | '9' -> "nine" 124 | | x -> failwith "unexpected char" 125 | in 126 | let s = string_of_int i in 127 | String.iter s ~f:(fun c -> printf " %s" (spell_char c)) 128 | 129 | let work colors n = 130 | let module C = Chameneos in 131 | List.iter colors ~f:(fun c -> printf " %s" (Color.to_string c)); 132 | printf "\n"; 133 | let place = Meeting_place.create n in 134 | let cs = List.map colors ~f:Chameneos.create in 135 | let threads = List.map cs ~f:(fun c -> Chameneos.run c place) in 136 | List.iter threads ~f:Thread.join; 137 | let sum_meets = ref 0 in 138 | List.iter cs ~f:(fun c -> 139 | printf "%d" c.C.meetings; 140 | spell_int c.C.meetings_with_self; 141 | printf "\n"; 142 | sum_meets := !sum_meets + c.C.meetings); 143 | spell_int !sum_meets; 144 | printf "\n" 145 | 146 | let main () = 147 | let n = try int_of_string Sys.argv.(1) with _ -> 600 in 148 | print_complements (); 149 | let module C = Color in 150 | work [ C.Blue; C.Red; C.Yellow ] n; 151 | printf "\n"; 152 | work 153 | [ 154 | C.Blue; 155 | C.Red; 156 | C.Yellow; 157 | C.Red; 158 | C.Yellow; 159 | C.Blue; 160 | C.Red; 161 | C.Yellow; 162 | C.Red; 163 | C.Blue; 164 | ] 165 | n; 166 | printf "\n" 167 | 168 | let () = main () 169 | -------------------------------------------------------------------------------- /mvar/concurrent_monad.ml: -------------------------------------------------------------------------------- 1 | (* Demonstrate the concurrent scheduler *) 2 | 3 | let log = Printf.printf 4 | 5 | (* ************ 6 | Fiber tree 7 | ************ 8 | 0 9 | / \ 10 | 1 2 11 | / \ / \ 12 | 3 4 5 6 13 | *) 14 | 15 | open Sched_monad 16 | 17 | let ( >> ) a b = a >>= fun _ -> b 18 | 19 | let rec f id depth = 20 | log "Starting number %i\n%!" id; 21 | if depth > 0 then ( 22 | log "Forking (1) number %i\n%!" ((id * 2) + 1); 23 | fork (f ((id * 2) + 1) (depth - 1)) 24 | >> 25 | let () = log "Forking (2) number %i\n%!" ((id * 2) + 2) in 26 | fork (f ((id * 2) + 2) (depth - 1))) 27 | else ( 28 | log "Yielding in number %i\n%!" id; 29 | yield >>= fun _ -> 30 | log "Resumed number %i\n%!" id; 31 | return ()); 32 | log "Finishing number %i\n%!" id; 33 | return () 34 | 35 | let () = run (f 0 2) 36 | -------------------------------------------------------------------------------- /mvar/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names chameneos chameneos_monad chameneos_lwt MVar_test chameneos_systhr) 3 | (libraries threads lwt lwt.unix) 4 | (modules 5 | sched 6 | MVar 7 | sched_monad 8 | MVar_monad 9 | chameneos 10 | chameneos_monad 11 | chameneos_lwt 12 | MVar_test 13 | chameneos_systhr)) 14 | -------------------------------------------------------------------------------- /mvar/sched.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ eff += Fork : (unit -> unit) -> unit eff 5 | type _ eff += Yield : unit eff 6 | type 'a cont = ('a, unit) continuation 7 | type _ eff += Suspend : ('a cont -> unit) -> 'a eff 8 | type _ eff += Resume : 'a cont * 'a -> unit eff 9 | 10 | let run main = 11 | let run_q = Queue.create () in 12 | let enqueue t v = Queue.push (fun () -> continue t v) run_q in 13 | let dequeue () = if Queue.is_empty run_q then () else Queue.pop run_q () in 14 | let rec spawn f = 15 | match_with f () 16 | { 17 | retc = dequeue; 18 | exnc = raise; 19 | effc = 20 | (fun (type a) (e : a Effect.t) -> 21 | match e with 22 | | Yield -> 23 | Some 24 | (fun (k : (a, _) continuation) -> 25 | enqueue k (); 26 | dequeue ()) 27 | | Fork f -> 28 | Some 29 | (fun k -> 30 | enqueue k (); 31 | spawn f) 32 | | Suspend f -> 33 | Some 34 | (fun k -> 35 | f k; 36 | dequeue ()) 37 | | Resume (k', v) -> 38 | Some 39 | (fun k -> 40 | enqueue k' v; 41 | ignore (continue k ())) 42 | | _ -> None); 43 | } 44 | in 45 | spawn main 46 | 47 | let fork f = perform (Fork f) 48 | let yield () = perform Yield 49 | let suspend f = perform (Suspend f) 50 | let resume (k, v) = perform (Resume (k, v)) 51 | -------------------------------------------------------------------------------- /mvar/sched.mli: -------------------------------------------------------------------------------- 1 | type 'a cont 2 | (** Represents a blocked computation that waits for a value of type 'a. *) 3 | 4 | type _ eff += 5 | | Suspend : ('a cont -> unit) -> 'a eff 6 | (** [Perform @@ Suspend f] applies [f] to the current continuation, and suspends the 7 | execution of the current thread, and switches to the next thread in the 8 | scheduler's queue. *) 9 | 10 | type _ eff += 11 | | Resume : 'a cont * 'a -> unit eff 12 | (** [perform @@ Resume (k,v)] prepares the suspended continuation [k] with value [v] and 13 | enqueues it to the scheduler queue. *) 14 | 15 | type _ eff += 16 | | Fork : (unit -> unit) -> unit eff 17 | (** [perform @@ Fork f] forks [f] as a new thread to which control immediately switches to. *) 18 | 19 | type _ eff += 20 | | Yield : unit eff 21 | (** [perform Yield] suspends the current thread and switches to the next thread from 22 | the run queue. *) 23 | 24 | val run : (unit -> unit) -> unit 25 | (** [run f] runs [f] with the cooperative-threaded scheduler. *) 26 | -------------------------------------------------------------------------------- /mvar/sched_monad.ml: -------------------------------------------------------------------------------- 1 | type action = 2 | | Atom of zaction 3 | | Fork of zaction * zaction 4 | | Yield of zaction 5 | | Suspend 6 | | Resume of zaction * zaction 7 | | Stop 8 | 9 | and zaction = unit -> action 10 | 11 | type 'a t = ('a -> action) -> action 12 | type 'a cont = 'a -> action 13 | 14 | let ( >>= ) f k c = f (fun a -> k a c) 15 | let ( >> ) a b = a >>= fun _ -> b 16 | let return x c = c x 17 | 18 | let atom f c = 19 | Atom 20 | (fun () -> 21 | let b = f () in 22 | c b) 23 | 24 | let action f = f (fun () -> Stop) 25 | let fork f c = Fork ((fun () -> action f), c) 26 | let stop c = Stop 27 | let yield c = Yield c 28 | 29 | let suspend f c = 30 | match f c with 31 | | None -> Suspend 32 | | Some (v, None) -> c v 33 | | Some (v, Some l) -> Resume ((fun () -> c v), l) 34 | 35 | type ready_cont = zaction 36 | 37 | let prepare k v () = k v 38 | 39 | let rec round = function 40 | | [] -> () 41 | | x :: xs -> ( 42 | match x with 43 | | Atom th -> 44 | let y = th () in 45 | round (xs @ [ y ]) 46 | | Fork (a1, a2) -> round (a1 () :: a2 () :: xs) 47 | | Yield a -> round (xs @ [ a () ]) 48 | | Suspend -> round xs 49 | | Resume (a1, a2) -> round (a1 () :: a2 () :: xs) 50 | | Stop -> round xs) 51 | 52 | let run m = round [ action m ] 53 | 54 | let rec iter_p f l = 55 | match l with 56 | | [] -> return () 57 | | x :: l -> 58 | let tx = f x and tl = iter_p f l in 59 | tx >>= fun () -> tl 60 | 61 | let map f m = m >>= fun x -> return (f x) 62 | let ( >|= ) t f = map f t 63 | 64 | let rec map_p f l = 65 | match l with 66 | | [] -> return [] 67 | | x :: l -> 68 | let tx = f x and tl = map_p f l in 69 | tx >>= fun x -> 70 | tl >|= fun l -> x :: l 71 | -------------------------------------------------------------------------------- /mvar/sched_monad.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val return : 'a -> 'a t 4 | val ( >> ) : 'a t -> 'b t -> 'b t 5 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 6 | val yield : unit t 7 | val fork : unit t -> unit t 8 | val run : unit t -> unit 9 | val atom : (unit -> unit) -> unit t 10 | 11 | type 'a cont 12 | type ready_cont 13 | 14 | val prepare : 'a cont -> 'a -> ready_cont 15 | val suspend : ('a cont -> ('a * ready_cont option) option) -> 'a t 16 | val iter_p : ('a -> unit t) -> 'a list -> unit t 17 | val map_p : ('a -> 'b t) -> 'a list -> 'b list t 18 | -------------------------------------------------------------------------------- /pipes.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | 3 | (** Deep encoding of pipes. 4 | The example is adapted from Kammar et al. (2013) **) 5 | 6 | (* We specialise our pipes to work only with integers *) 7 | type _ eff += Await : int eff 8 | let await () = perform Await 9 | 10 | type _ eff += Yield : int -> unit eff 11 | let yield s = perform (Yield s) 12 | 13 | type prod = Prod of (unit -> cons -> unit) 14 | and cons = Cons of (int -> prod -> unit) 15 | 16 | let flip f y x = f x y 17 | 18 | (* Parameterised handler that takes a consumer as parameter *) 19 | let up m = 20 | match m () with 21 | | v -> fun _ -> v 22 | | effect (Yield s), k -> 23 | fun (Cons cons) -> 24 | cons s (Prod (fun () -> Effect.Deep.continue k ())) 25 | 26 | (* Refine up to accept the parameter first rather than the computation. It's 27 | more convenient when combining handlers. *) 28 | let up = flip up 29 | 30 | (* Parameterised handler that takes a producer as parameter *) 31 | let down m = 32 | match m () with 33 | | v -> fun _ -> v 34 | | effect Await, k -> 35 | fun (Prod prod) -> 36 | prod () (Cons (fun s -> Effect.Deep.continue k s)) 37 | 38 | let down = flip down 39 | 40 | (** Some convenient combinators **) 41 | let ( <+< ) d u () = down (Prod (fun () cons -> up cons u)) d 42 | 43 | let ( >+> ) d u = u <+< d 44 | 45 | (* Produces an infinite stream of integers starting from [n] *) 46 | 47 | (** Some producers and consumers **) 48 | let rec produceFrom : int -> unit -> unit = 49 | fun n () -> 50 | yield n; 51 | produceFrom (n + 1) () 52 | 53 | (* Accumulates elements from an integer stream until the sum is 54 | greater than or equal to [n]. Moreover, it produces a singleton 55 | integer stream *) 56 | let sumTo : int -> unit -> unit = 57 | let rec sumTo' acc lim = 58 | if acc >= lim then yield acc 59 | else 60 | let x = await () in 61 | sumTo' (acc + x) lim 62 | in 63 | fun n () -> sumTo' 0 n 64 | 65 | (* Skips [n] elements of an arbitrary stream *) 66 | let rec skip : int -> unit -> unit = 67 | fun n () -> 68 | if n <= 0 then ( 69 | yield (await ()); 70 | skip 0 ()) 71 | else ( 72 | ignore (await ()); 73 | skip (n - 1) ()) 74 | 75 | (* Prints a stream of integers *) 76 | let rec printer : unit -> unit = 77 | fun () -> 78 | Printf.printf "%d\n" (await ()); 79 | printer () 80 | 81 | (* Wiring everything together *) 82 | let example = produceFrom 0 >+> skip 99 >+> sumTo 100 >+> printer 83 | let _ = example () 84 | -------------------------------------------------------------------------------- /promises.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | module type Applicative = sig 5 | type 'a t 6 | 7 | val pure : 'a -> 'a t 8 | val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t 9 | end 10 | 11 | module type Promise = sig 12 | include Applicative 13 | 14 | val fork : (unit -> 'a) -> 'a t 15 | val get : 'a t -> ('a, exn) result 16 | val get_val : 'a t -> 'a 17 | val run : (unit -> 'a) -> ('a, exn) result 18 | end 19 | 20 | module Promise : Promise = struct 21 | type cont = Cont : (unit, 'b) continuation -> cont 22 | type tvar = cont option ref 23 | 24 | let mk_tvar k = ref (Some (Cont k)) 25 | 26 | type 'a status = Done of 'a | Cancelled of exn | Waiting of tvar list 27 | type 'a t = 'a status ref 28 | 29 | type _ eff += 30 | | Fork : (unit -> 'a) -> 'a t eff 31 | | Wait : 'a t -> unit eff 32 | 33 | let fork f = perform (Fork f) 34 | let enqueue run_q k v = Queue.push (fun () -> ignore @@ continue k v) run_q 35 | let dequeue run_q = if Queue.is_empty run_q then () else (Queue.pop run_q) () 36 | let mk_status () = ref (Waiting []) 37 | 38 | let finish run_q sr v = 39 | match !sr with 40 | | Waiting l -> 41 | sr := Done v; 42 | List.iter 43 | (fun tv -> 44 | match !tv with 45 | | None -> () 46 | | Some (Cont k) -> 47 | tv := None; 48 | enqueue run_q k ()) 49 | l 50 | | _ -> failwith "Impossible: finish" 51 | 52 | let abort run_q sr e = 53 | match !sr with 54 | | Waiting l -> 55 | sr := Cancelled e; 56 | List.iter 57 | (fun tv -> 58 | match !tv with 59 | | None -> () 60 | | Some (Cont k) -> 61 | tv := None; 62 | enqueue run_q k ()) 63 | l 64 | | _ -> failwith "Impossible: abort" 65 | 66 | let wait sr k = 67 | match !sr with 68 | | Waiting l -> sr := Waiting (mk_tvar k :: l) 69 | | _ -> failwith "Impossible: wait" 70 | 71 | let rec get sr = 72 | match !sr with 73 | | Done v -> Ok v 74 | | Cancelled e -> Error e 75 | | Waiting _ -> 76 | perform (Wait sr); 77 | get sr 78 | 79 | let rec get_val sr = 80 | match !sr with 81 | | Done v -> v 82 | | Cancelled e -> raise e 83 | | Waiting _ -> 84 | perform (Wait sr); 85 | get_val sr 86 | 87 | let pure v = ref (Done v) 88 | 89 | let rec ( <*> ) f g = 90 | match (!f, !g) with 91 | | (Cancelled _ as x), _ -> ref x 92 | | _, (Cancelled _ as x) -> ref x 93 | | Waiting _, _ -> ( 94 | perform (Wait f); 95 | match get f with 96 | | Ok f -> ref (Done f) <*> g 97 | | Error e -> ref (Cancelled e)) 98 | | Done f, Done g -> ref (Done (f g)) 99 | | Done f, Waiting _ -> ( 100 | perform (Wait g); 101 | match get g with 102 | | Ok g -> ref (Done (f g)) 103 | | Error e -> ref (Cancelled e)) 104 | 105 | let run main = 106 | let run_q = Queue.create () in 107 | let rec spawn : 'a. 'a status ref -> (unit -> 'a) -> unit = 108 | fun sr f -> 109 | match f () with 110 | | v -> finish run_q sr v; dequeue run_q 111 | | exception e -> abort run_q sr e; dequeue run_q 112 | | effect (Wait sr), k -> wait sr k; dequeue run_q 113 | | effect (Fork f), k -> 114 | let sr = mk_status () in 115 | enqueue run_q k sr; spawn sr f 116 | in 117 | let sr = mk_status () in 118 | spawn sr main; 119 | get sr 120 | end 121 | 122 | open Promise 123 | open Printf 124 | 125 | let test1 () = 126 | let x = pure 10 in 127 | let y = pure 20 in 128 | let z = pure ( + ) <*> x <*> y in 129 | get_val z 130 | 131 | let _ = 132 | match run test1 with 133 | | Ok v -> Printf.printf "test1: %d\n" v 134 | | Error e -> Printf.printf "test2: error: %s\n" @@ Printexc.to_string e 135 | 136 | let test2 () = 137 | let x = 138 | fork (fun () -> 139 | printf "test2: x\n%!"; 140 | 10) 141 | in 142 | let y = 143 | fork (fun () -> 144 | printf "test2: y\n%!"; 145 | raise Exit) 146 | in 147 | let z = 148 | fork (fun () -> 149 | printf "test2: z\n%!"; 150 | 20) 151 | in 152 | let add3 x y z = 153 | let _ = printf "test2: add %d %d %d\n" x y z in 154 | x + y + z 155 | in 156 | let r = pure add3 <*> x <*> y <*> z in 157 | get_val r 158 | 159 | let _ = 160 | match run test2 with 161 | | Ok v -> Printf.printf "test2: %d\n" v 162 | | Error e -> Printf.printf "test2: error: %s\n" @@ Printexc.to_string e 163 | 164 | let _ = print_endline "SUCCESS" 165 | -------------------------------------------------------------------------------- /ref.ml: -------------------------------------------------------------------------------- 1 | (* ref.ml *) 2 | 3 | (* This file introduces the type [HEAP] formalizing a heap 4 | as a mechanism for dynamically allocating memory cells. 5 | 6 | Two heap implementations are given: 7 | (1) [FCMBasedHeap], where references are implemented as first-class 8 | modules declaring effect names [Get] and [Set]. 9 | (2) [RecordBasedHeap], where references are implemented as pairs of 10 | functions [get] and [set]. 11 | *) 12 | 13 | open Effect 14 | open Effect.Deep 15 | open State 16 | 17 | (* --------------------------------------------------------------------------- *) 18 | (** Type Definitions. *) 19 | 20 | (* [REF] is the interface of dynamically allocated references. *) 21 | module type REF = sig 22 | type 'a t 23 | 24 | val ref : 'a -> 'a t 25 | val ( ! ) : 'a t -> 'a 26 | val ( := ) : 'a t -> 'a -> unit 27 | val run : (unit -> 'a) -> 'a 28 | end 29 | 30 | (* [HEAP] is the type of a functor that, given the implementation of a cell, 31 | implements dynamically allocated references. *) 32 | module type HEAP = functor (_ : CELL) -> REF 33 | 34 | (* --------------------------------------------------------------------------- *) 35 | (** Heap Implementation Based on First-Class Modules. *) 36 | 37 | (* [FCMBasedHeap] implements a heap using first-class modules. 38 | 39 | The idea is to implement the type of references ['a t] as the 40 | type of first-class modules declaring the pair of effect names 41 | [Get] and [Set]. 42 | 43 | The operations [!] and [:=] are then simply implemented as [perform] 44 | instructions to one of the effect names passed as arguments. 45 | 46 | The interpretation of these operations is given by the functions 47 | [get] and [set] obtained from a new instance of [Cell]. 48 | *) 49 | 50 | module FCMBasedHeap : HEAP = functor (Cell : CELL) -> struct 51 | (* [EFF] declares a pair of effect names [Get] and [Set]. *) 52 | module type EFF = sig 53 | type t 54 | type _ eff += Get : t eff | Set : t -> unit eff 55 | end 56 | (* ['a t] is the type of first-class [EFF] modules. 57 | The effect-name declarations in [EFF] become first-class. *) 58 | type 'a t = (module EFF with type t = 'a) 59 | 60 | type _ eff += Ref : 'a -> ('a t) eff 61 | 62 | let ref init = perform (Ref init) 63 | let (!) : type a. a t -> a = 64 | fun (module E) -> perform E.Get 65 | let (:=) : type a. a t -> a -> unit = 66 | fun (module E) y -> perform (E.Set y) 67 | 68 | (* [fresh()] allocates fresh effect names [Get] and [Set], 69 | and packs these names into a first-class module. *) 70 | let fresh (type a) () : a t = 71 | (module struct 72 | type t = a 73 | type _ eff += Get : t eff | Set : t -> unit eff 74 | end) 75 | 76 | let run main = 77 | try main () with 78 | effect (Ref init), k -> 79 | (* trick to name the existential type introduced by the matching: *) 80 | (init, k) |> fun (type a) (init, k : a * (a t, _) continuation) -> 81 | let module E = (val (fresh (): a t)) in 82 | let module C = Cell(struct type t = a end) in 83 | let main () = 84 | try continue k (module E) with 85 | | effect E.Get, k -> continue k (C.get() : a) 86 | | effect (E.Set y), k -> continue k (C.set y) 87 | in 88 | snd (C.run ~init main) 89 | end 90 | 91 | (* --------------------------------------------------------------------------- *) 92 | (** Heap Implementation Based on Records. *) 93 | 94 | (* [RecordBasedHeap] implements a reference as a pair of functions [get] 95 | and [set]. The operations [!] and [:=] need simply to choose between 96 | one these two functions. The operation [ref] is implemented as an 97 | effect [Ref]. When performed, a new instance of [Cell] is created and the 98 | continuation is resumed with the pair of functions [get] and [set] given 99 | by this new cell. 100 | *) 101 | 102 | module RecordBasedHeap : HEAP = functor (Cell : CELL) -> struct 103 | type 'a t = { 104 | get : unit -> 'a; 105 | set : 'a -> unit; 106 | } 107 | type _ eff += Ref : 'a -> 'a t eff 108 | 109 | let ref init = perform (Ref init) 110 | let (!) {get; _} = get() 111 | let (:=) {set; _} y = set y 112 | 113 | let run main = 114 | try main () with 115 | | effect (Ref init), k -> 116 | (init, k) |> fun (type a) ((init, k) : a * (a t, _) continuation) -> 117 | let open Cell(struct type t = a end) in 118 | snd (run ~init (fun _ -> continue k {get; set})) 119 | end 120 | 121 | (* --------------------------------------------------------------------------- *) 122 | (** Examples. *) 123 | 124 | open Printf 125 | 126 | let _ = printf "Opening module Ref...\n" 127 | let _ = printf "Running tests...\n" 128 | 129 | let _ = 130 | let heaps : (module REF) list = 131 | [ 132 | (module FCMBasedHeap (StPassing)); 133 | (module RecordBasedHeap (StPassing)); 134 | (module FCMBasedHeap (LocalMutVar)); 135 | (module RecordBasedHeap (LocalMutVar)); 136 | (module FCMBasedHeap (GlobalMutVar)); 137 | (module RecordBasedHeap (GlobalMutVar)); 138 | ] 139 | in 140 | 141 | List.iter 142 | (fun heap -> 143 | let open (val heap : REF) in 144 | let main () = 145 | let fibs = ref [] in 146 | let a, b = (ref 0, ref 1) in 147 | for _i = 0 to 10 do 148 | let fibsv, av, bv = (!fibs, !a, !b) in 149 | fibs := av :: fibsv; 150 | a := bv; 151 | b := av + bv 152 | done; 153 | let fibsv, av, bv = (!fibs, !a, !b) in 154 | assert ((List.hd fibsv, av, bv) = (55, 89, 144)) 155 | in 156 | run main) 157 | heaps 158 | 159 | let _ = printf "End of tests.\n" 160 | let _ = printf "End of module Ref.\n" 161 | -------------------------------------------------------------------------------- /reify_reflect.ml: -------------------------------------------------------------------------------- 1 | (* Monadic Reflection : 2 | http://www.cs.ioc.ee/mpc-amast06/msfp/filinski-slides.pdf *) 3 | open Effect 4 | open Effect.Deep 5 | 6 | (* The monad signature *) 7 | module type MONAD = sig 8 | type +_ t 9 | 10 | val return : 'a -> 'a t 11 | val bind : 'a t -> ('a -> 'b t) -> 'b t 12 | end 13 | 14 | (* Build reify and reflect operations for any monad *) 15 | module RR (M : MONAD) : sig 16 | val reify : (unit -> 'a) -> 'a M.t 17 | val reflect : 'a M.t -> 'a 18 | end = 19 | struct 20 | type _ eff += E : 'a M.t -> 'a eff 21 | let reify f = match f () with 22 | x -> M.return x 23 | | effect (E m), k -> M.bind m (continue k) 24 | let reflect m = perform (E m) 25 | end 26 | 27 | (* The state monad *) 28 | module State = struct 29 | type 'a t = int -> int * 'a 30 | 31 | let return v s = (s, v) 32 | 33 | let bind m k s = 34 | let s, a = m s in 35 | k a s 36 | 37 | let get s = (s, s) 38 | let put s _ = (s, ()) 39 | let run s ~init = s init 40 | end 41 | 42 | (* Reify and reflect for State *) 43 | module StateR = RR (State) 44 | 45 | (* val put : int -> unit State.t *) 46 | let put v = StateR.reflect (State.put v) 47 | 48 | (* val get : unit -> int State.t *) 49 | let get () = StateR.reflect State.get 50 | 51 | (* val run_state : (unit -> 'a) -> init:int -> 'a *) 52 | let run_state f ~init = 53 | let final, v = State.run (StateR.reify f) ~init in 54 | Printf.printf "Final state: %d\n" final; 55 | v 56 | 57 | (* The exception monad *) 58 | module Exception = struct 59 | type 'a t = Ok of 'a | Exn of exn 60 | 61 | let return v = Ok v 62 | let bind m k = match m with Ok v -> k v | Exn e -> Exn e 63 | let raise exn = Exn exn 64 | let run m ~catch = match m with Ok v -> v | Exn e -> catch e 65 | end 66 | 67 | (* Reify and reflect for Exception *) 68 | module ExceptionR = RR (Exception) 69 | 70 | (* val raise : exn -> 'a *) 71 | let raise e = ExceptionR.reflect (Exception.raise e) 72 | 73 | (* val run_exception : (unit -> 'a) -> catch:(exn -> 'a) -> 'a *) 74 | let run_exception m ~catch = Exception.run (ExceptionR.reify m) ~catch 75 | 76 | (* Using the state monad *) 77 | let state_example () = 78 | let initial = get () in 79 | Printf.printf "Initial state: %d\n" initial; 80 | put 10; 81 | assert (get () = 10); 82 | put (get () + 1); 83 | assert (get () = 11); 84 | put 12; 85 | (`Initial initial, `Final (get ())) 86 | 87 | (* Using the exception monad *) 88 | let exception_example () = 89 | Printf.printf "Raising an exception\n"; 90 | raise (Failure "An error!") |> ignore; 91 | Printf.printf "This shouldn't be displayed\n" 92 | 93 | (* Using both exceptions and state *) 94 | let combined_example () = 95 | Printf.printf "Initial state: %d\n" (get ()); 96 | put 100; 97 | raise (Failure "An error!") |> ignore; 98 | put 200 99 | 100 | let print_exception e = Printf.printf "Exception: %s\n" (Printexc.to_string e) 101 | 102 | let () = 103 | run_state ~init:10 state_example |> ignore; 104 | print_endline "========================================"; 105 | 106 | run_exception ~catch:print_exception exception_example; 107 | print_endline "========================================"; 108 | 109 | ( run_exception ~catch:print_exception @@ fun () -> 110 | run_state ~init:10 @@ fun () -> combined_example () ); 111 | print_endline "========================================"; 112 | 113 | run_state ~init:10 @@ fun () -> 114 | run_exception ~catch:print_exception @@ fun () -> combined_example () 115 | -------------------------------------------------------------------------------- /sched.ml: -------------------------------------------------------------------------------- 1 | type _ eff += Fork : (unit -> unit) -> unit eff 2 | type _ eff += Yield : unit eff 3 | 4 | let fork f = Effect.perform (Fork f) 5 | let yield () = Effect.perform Yield 6 | 7 | (* A concurrent round-robin scheduler *) 8 | let run main = 9 | let run_q = Queue.create () in 10 | let enqueue k = Queue.push k run_q in 11 | let dequeue () = 12 | if Queue.is_empty run_q then () else Effect.Deep.continue (Queue.pop run_q) () 13 | in 14 | let rec spawn f = 15 | (* Effect handler => instantiates fiber *) 16 | match f () with 17 | | () -> dequeue () 18 | | exception e -> 19 | ( print_string (Printexc.to_string e); 20 | dequeue () ) 21 | | effect Yield, k -> 22 | ( enqueue k; dequeue () ) 23 | | effect (Fork f), k -> 24 | ( enqueue k; spawn f ) 25 | in 26 | spawn main 27 | -------------------------------------------------------------------------------- /sched.mli: -------------------------------------------------------------------------------- 1 | (* Control operations on threads *) 2 | val fork : (unit -> unit) -> unit 3 | val yield : unit -> unit 4 | 5 | (* Runs the scheduler. *) 6 | val run : (unit -> unit) -> unit 7 | -------------------------------------------------------------------------------- /state.ml: -------------------------------------------------------------------------------- 1 | (* state.ml *) 2 | 3 | (* This file introduces the type [CELL] formalizing a memory cell 4 | as a functor that, for any given type, implements the [STATE] 5 | interface. 6 | 7 | Three cell implementations are given: 8 | (1) [GlobalMutVar], an implementation using global state. 9 | (2) [LocalMutVar], an implementation using local state. 10 | (3) [StPassing], a functional implementation in state-passing style. 11 | 12 | The stating-passing--style implementation comes from 13 | 14 | https://gist.github.com/kayceesrk/3c307d0340fbfc68435d4769ad447e10 . 15 | *) 16 | 17 | open Effect 18 | open Effect.Deep 19 | 20 | (* --------------------------------------------------------------------------- *) 21 | (** Type Definitions. *) 22 | 23 | (* [TYPE] specifies a type [t]. *) 24 | module type TYPE = sig 25 | type t 26 | end 27 | 28 | (* [STATE] is the type of a module that offers the functions [get] and [set] 29 | for manipulating a piece of mutable state with contents in the type [t]. 30 | This module must also offer a function [run] for handling computations 31 | that perform the operations [get] and [set]. 32 | *) 33 | module type STATE = sig 34 | type t 35 | 36 | val get : unit -> t 37 | val set : t -> unit 38 | val run : init:t -> (unit -> 'a) -> t * 'a 39 | end 40 | 41 | (* [CELL] is the type of a functor that produces an 42 | implementation of [STATE] for any given type. 43 | *) 44 | module type CELL = functor (T : TYPE) -> STATE with type t = T.t 45 | 46 | (* Note. 47 | 48 | The signatures [STATE] and [CELL] are equivalent to the following 49 | record types, respectively: 50 | 51 | ```ocaml 52 | type 's state = { 53 | get : unit -> 's; 54 | set : 's -> unit; 55 | run : 'a. init:'s -> (unit -> 'a) -> 's * 'a 56 | } 57 | 58 | type cell = { 59 | fresh : 's. unit -> 's state 60 | } 61 | ``` 62 | 63 | We prefer the signatures [STATE] and [CELL] over the record types, 64 | because implementations of these interfaces often need to declare 65 | new effect names (which comes more naturally in the scope of a 66 | module definition) and because we need a module signature of cells 67 | to declare the functor signature [HEAP] in the file [ref.ml] (if we 68 | want to avoid types such as [cell -> (module REF)]). 69 | *) 70 | 71 | (* --------------------------------------------------------------------------- *) 72 | (** Global State. *) 73 | 74 | (* [GlobalMutVar] implements a cell using the global state. 75 | 76 | The module produced by this functor allocates a fresh reference [var], 77 | which initially holds the value [None]. The operations [get] and [set] 78 | perform accesses to this reference, but can be called only in the scope 79 | of [run]. 80 | 81 | Nested applications of [run] (given by the same module), such as 82 | 83 | ```ocaml 84 | let open GlobalMutVar(struct type t = int end) in 85 | run ~init:0 (fun _ -> run ~init:1 (fun _ -> ())) 86 | ```, 87 | 88 | are unsafe, because the innermost [run] resets [var] to [None]. 89 | The final read to [var] performed by the outermost [run] (to construct 90 | the pair [t * 'a]) is thus invalidated. 91 | 92 | Parallel applications of [run] (given by the same module) are unsafe, 93 | because an instance of [run] can reset [var] to [None] while parallel 94 | instances are still ongoing. Moreover, accesses to [var] will suffer 95 | from race conditions. 96 | *) 97 | module GlobalMutVar : CELL = 98 | functor 99 | (T : TYPE) 100 | -> 101 | struct 102 | type t = T.t 103 | 104 | let var = ref None 105 | let get () = match !var with Some x -> x | None -> assert false 106 | let set y = var := Some y 107 | 108 | let run ~init main = 109 | set init |> fun _ -> 110 | main () |> fun res -> 111 | get () |> fun x -> 112 | (var := None) |> fun _ -> (x, res) 113 | end 114 | 115 | (* --------------------------------------------------------------------------- *) 116 | (** Local State. *) 117 | 118 | (* [LocalMutVar] implements a cell using effect handlers and local mutable 119 | state. The operations [get] and [set] are opaque: they are simply defined 120 | as [perform] instructions to the effects [Get] and [Set], respectively. 121 | The program [run] interprets these effects as accesses to a local 122 | reference [var]. 123 | 124 | Nested applications of [run] are safe, but [get] and [set] are handled 125 | by the innermost [run]. As an example, the program 126 | 127 | ```ocaml 128 | let open LocalMutVar(struct type t = int end) in 129 | run ~init:0 (fun _ -> set 3; run ~init:1 (fun _ -> get() + get())) 130 | ``` 131 | 132 | evaluates to [(3, (1, 2))]. 133 | 134 | Parallel executions of [run] in separate stacks are safe. Even though 135 | the effect names [Get] and [Set] are shared among multiple instances 136 | of [get] and [set], there is no interference among these instances, 137 | because effect names are immutable. 138 | *) 139 | module LocalMutVar : CELL = functor (T : TYPE) -> struct 140 | type t = T.t 141 | type _ eff += Get : t eff | Set : t -> unit eff 142 | 143 | let get () = perform Get 144 | let set y = perform (Set y) 145 | 146 | let run (type a) ~init main : t * a= 147 | let var = ref init in 148 | match main () with 149 | | res -> !var, res 150 | | effect Get, k -> continue k (!var : t) 151 | | effect (Set y), k -> var := y; continue k () 152 | end 153 | 154 | (* --------------------------------------------------------------------------- *) 155 | (** State-Passing Style. *) 156 | 157 | (* [StPassing] implements a cell using effect handlers and the state-passing 158 | technique. 159 | 160 | Like the functor [LocalMutVar], the operations [get] and [set] are 161 | implemented as [perform] instructions to the effects [Get] and [Set], 162 | respectively. However, instead of interpreting these effects as accesses to 163 | a reference, [run] applies the programming technique state-passing style, 164 | which avoids mutable state, thus assigning a functional interpretation to 165 | [Get] and [Set]. More specifically, the program [run main ~init] performs 166 | the application of the handler that monitors [main()] to the contents of the 167 | cell, which initially is [init]. When [main()] performs an effect, the 168 | effect branch can access the current state of the cell by immediately 169 | returning a lambda abstraction that binds the contents of the cell as its 170 | single formal argument. The continuation captures the evaluation context up 171 | to (and including) the handler, therefore, when resuming the continuation, 172 | the handler must reconstruct its immediately surrounding frame 173 | corresponding to the application to the contents of the cell. 174 | 175 | Nested applications of [run] are safe. Parallel executions of [run] in 176 | separate stacks are safe. The same remarks as for the functor [LocalMutVar] 177 | apply. 178 | *) 179 | module StPassing : CELL = functor (T : TYPE) -> struct 180 | type t = T.t 181 | type _ eff += Get : t eff | Set : t -> unit eff 182 | 183 | let get () = perform Get 184 | let set y = perform (Set y) 185 | 186 | let run (type a) ~init (main : unit -> a) : t * a = 187 | (* In this case the lower-level syntax is less verbose 188 | since we have to rebind the existentials anyway if using 189 | the concrete effect syntax. *) 190 | match_with main () { 191 | retc = (fun res x -> (x, res)); 192 | exnc = raise; 193 | effc = fun (type b) (e : b eff) -> 194 | match e with 195 | | Get -> Some (fun (k : (b, t -> (t * a)) continuation) -> 196 | fun (x : t) -> continue k x x) 197 | | Set y -> Some (fun k -> 198 | fun (_x : t) -> continue k () y) 199 | | _ -> None 200 | } init 201 | end 202 | 203 | (* --------------------------------------------------------------------------- *) 204 | (** Examples. *) 205 | 206 | open Printf 207 | 208 | let _ = printf "Opening module State...\n" 209 | 210 | module IntCell = StPassing (struct 211 | type t = int 212 | end) 213 | 214 | module StrCell = StPassing (struct 215 | type t = string 216 | end) 217 | 218 | let main () : unit = 219 | IntCell.( 220 | printf "%d\n" (get ()); 221 | set 42; 222 | printf "%d\n" (get ()); 223 | set 21; 224 | printf "%d\n" (get ())); 225 | StrCell.( 226 | set "Hello..."; 227 | printf "%s\n" (get ()); 228 | set "...World!"; 229 | printf "%s\n" (get ())) 230 | 231 | let _ = 232 | printf "Running tests...\n"; 233 | ignore (IntCell.run ~init:0 (fun () -> StrCell.run ~init:"" main)); 234 | printf "End of tests.\n" 235 | 236 | let _ = printf "End of module State.\n" 237 | -------------------------------------------------------------------------------- /transaction.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Deep 4 | 5 | type bottom 6 | 7 | module type TXN = sig 8 | type 'a t 9 | 10 | val atomically : (unit -> unit) -> unit 11 | val ref : 'a -> 'a t 12 | val ( ! ) : 'a t -> 'a 13 | val ( := ) : 'a t -> 'a -> unit 14 | end 15 | 16 | module Txn : TXN = struct 17 | type 'a t = 'a ref 18 | 19 | type _ eff += Update : 'a t * 'a -> unit eff 20 | 21 | let atomically f = 22 | let comp = 23 | match f () with 24 | | x -> (fun _ -> x) 25 | | exception e -> (fun rb -> rb (); raise e) 26 | | effect (Update (r,v)), k -> (fun rb -> 27 | let old_v = !r in 28 | r := v; 29 | continue k () (fun () -> r := old_v; rb ())) 30 | in comp (fun () -> ()) 31 | 32 | let ref = ref 33 | let ( ! ) = ( ! ) 34 | let ( := ) r v = perform (Update (r, v)) 35 | end 36 | 37 | exception Res of int 38 | 39 | open Txn 40 | 41 | let () = 42 | atomically (fun () -> 43 | let r = ref 10 in 44 | printf "T0: %d\n" !r; 45 | try 46 | atomically (fun () -> 47 | r := 20; 48 | r := 21; 49 | printf "T1: Before abort %d\n" !r; 50 | raise (Res !r) |> ignore; 51 | printf "T1: After abort %d\n" !r; 52 | r := 30) 53 | with Res v -> 54 | printf "T0: T1 aborted with %d\n" v; 55 | printf "T0: %d\n" !r) 56 | --------------------------------------------------------------------------------