├── .github └── workflows │ └── default.yml ├── .gitignore ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── config ├── configure.ml └── dune ├── dune-project ├── examples ├── README.md ├── async.ml ├── choice.ml ├── dune ├── dune-project ├── generic_count.ml ├── knapsack.ml ├── legacy │ ├── README.md │ ├── async.ml │ ├── choice.ml │ ├── dune │ ├── generic_count.ml │ ├── knapsack.ml │ ├── nqueens.ml │ ├── return.ml │ ├── rollback.ml │ ├── supervised.ml │ └── tautology.ml ├── nqueens.ml ├── return.ml ├── rollback.ml ├── supervised.ml └── tautology.ml ├── lib ├── dune ├── fiber_primitives.h ├── multicont.ml ├── multicont.mli └── multicont_stubs.c ├── multicont.opam └── test ├── async.expected ├── choice.expected ├── dune ├── gen ├── dune └── testrules.ml ├── generic_count.expected ├── knapsack.expected ├── lib ├── dune ├── inspect_fiber.ml ├── inspect_fiber_stubs.c └── unique_fibers.ml ├── nqueens.expected ├── return.expected ├── supervised.expected ├── tautology.expected └── tests.inc /.github/workflows/default.yml: -------------------------------------------------------------------------------- 1 | name: Multicont build, install, and tests 2 | 3 | on: 4 | pull_request: 5 | branches: main 6 | push: 7 | branches: [main] 8 | schedule: 9 | # Prime the caches every Monday 10 | - cron: 0 1 * * MON 11 | 12 | jobs: 13 | examples: 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: 18 | - ubuntu-latest 19 | - macos-latest 20 | ocaml-compiler: 21 | - 5.1.1 22 | - 5.2.0 23 | - 5.3.0 24 | 25 | runs-on: ${{ matrix.os }} 26 | 27 | steps: 28 | - name: Checkout code 29 | uses: actions/checkout@v4 30 | 31 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 32 | uses: ocaml/setup-ocaml@v3 33 | with: 34 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 35 | opam-depext: false 36 | 37 | - name: Install dune 38 | run: opam install dune dune-configurator 39 | shell: bash 40 | 41 | - name: Install library 42 | run: | 43 | opam exec -- dune build 44 | opam exec -- dune install 45 | shell: bash 46 | 47 | - name: Run tests 48 | run: | 49 | opam exec -- dune build @runtest 50 | opam exec -- dune build @runtest 51 | shell: bash 52 | 53 | - name: Clean & uninstall 54 | run: | 55 | opam exec -- dune uninstall 56 | opam exec -- dune clean 57 | shell: bash 58 | 59 | - name: Rebuild library with UNIQUE_FIBERS 60 | run: | 61 | opam exec -- dune build 62 | opam exec -- dune install 63 | env: 64 | UNIQUE_FIBERS: 1 65 | shell: bash 66 | 67 | - name: Rerun tests 68 | run: | 69 | opam exec -- dune build @runtest 70 | opam exec -- dune build @runtest 71 | shell: bash 72 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | *.cmt 11 | *.cmti 12 | *.so 13 | 14 | # ocamlbuild working directory 15 | _build/ 16 | 17 | # ocamlbuild targets 18 | *.byte 19 | *.native 20 | 21 | # oasis generated files 22 | setup.data 23 | setup.log 24 | 25 | # Merlin configuring file for Vim and Emacs 26 | .merlin 27 | 28 | # Dune generated files 29 | *.install 30 | 31 | # Local OPAM switch 32 | _opam/ 33 | 34 | # Temporaries 35 | *~ 36 | \#* 37 | 38 | # Ignore tests.inc modifications 39 | test/tests.inc -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Multicont version 1.0.3 (latest) 2 | 3 | This release restores compatibility with macOS (14.4.1) when using 4 | clang 15 or greater. 5 | 6 | Changes: 7 | 8 | * Patch #8: Explicit declaration of `memcpy` to fix compilation error 9 | when using clang on macOS (thanks to @tmcgilchrist). 10 | * Fixed a regression where enabling feature flag `UNIQUE_FIBERS` 11 | caused compilation to fail. 12 | * Spring cleaning: Removed unused header imports. 13 | * Added an example illustrating how to use the power of multishot 14 | continuation to simulate the `return` operator (e.g. as found in 15 | C/C++/Rust/etc) using a single handler. 16 | 17 | # Multicont version 1.0.2 18 | 19 | This release adds support for the anticipated release of OCaml 5.2. 20 | 21 | Changes: 22 | 23 | * Patch #7: OCaml 5.2 support (thanks to kit-ty-kate for the issue 24 | report #6; thanks to David Allsopp for reviewing the patch). The 25 | change accounts for the new continuation representation. 26 | * Added a basic testsuite runnable via `dune runtest`. 27 | * Fixed a memory leak in the rollback parsing example. 28 | * Added an entry about subtle interactions of unrestricted and linear 29 | effects in the "Cautionary tales" section of the README. 30 | 31 | # Multicont version 1.0.1 32 | 33 | This release is a purely administrative release which ports the build 34 | infrastructure to [dune](https://github.com/ocaml/dune) in order to 35 | resolve the reported build issues 36 | (e.g. https://github.com/ocaml/opam-repository/pull/23972). 37 | 38 | # Multicont version 1.0.0 39 | 40 | To celebrate the recent stable release of OCaml 5, we release a stable 41 | version of this library fully compatible with OCaml 5. The only change 42 | between this version and the previous release candidates is that now 43 | we use the stock OCaml 5 primitives to manage runtime stacks 44 | (c.f. [caml/fiber.h](https://github.com/ocaml/ocaml/blob/trunk/runtime/caml/fiber.h)). 45 | 46 | # Multicont version 1.0.0~rc.2 47 | 48 | Release candidate 2 brings the fiber primitives of multicont in sync 49 | with those in [OCaml trunk @ 50 | b4cfe16](https://github.com/ocaml/ocaml/commit/b4cfe1630263961ce0a9411197032b28c3ac1471). 51 | 52 | # Multicont version 1.0.0~rc.1 53 | 54 | This is release candidate 1 (and initial release) of the multicont 55 | library for OCaml. 56 | 57 | This release is compatible with the [OCaml 5.0 trunk @ 58 | 7f7c0f5](https://github.com/ocaml/ocaml/commit/7f7c0f521b65874f5d102b5a4da14ae116203def) 59 | and x64 architectures. 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Daniel Hillerström 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Project root and build directory 2 | ROOT:=$(shell dirname $(firstword $(MAKEFILE_LIST))) 3 | BUILD_DIR:=$(ROOT)/_build 4 | 5 | .PHONY: all 6 | all: dune-project 7 | dune build --profile=dev --build-dir=$(BUILD_DIR) 8 | 9 | .PHONY: install 10 | install: 11 | dune install --profile=dev --build-dir=$(BUILD_DIR) 12 | 13 | .PHONY: uninstall 14 | uninstall: 15 | dune uninstall --profile=dev --build-dir=$(BUILD_DIR) 16 | 17 | .PHONY: release 18 | release: 19 | dune-release tag v1.0.3 20 | dune-release distrib 21 | dune-release publish 22 | dune-release opam pkg 23 | dune-release opam submit 24 | 25 | .PHONY: test 26 | test: 27 | dune build @runtest 28 | dune build @runtest 29 | 30 | # Clean up rule 31 | .PHONY: clean 32 | clean: 33 | dune clean --build-dir=$(BUILD_DIR) 34 | echo -n "; intentionally left empty" > test/tests.inc 35 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Multicont: Continuations with multi-shot semantics in OCaml 2 | 3 | [![Multicont build, install, and tests](https://github.com/dhil/ocaml-multicont/actions/workflows/default.yml/badge.svg)](https://github.com/dhil/ocaml-multicont/actions/workflows/default.yml) 4 | 5 | This library provides a thin abstraction on top of OCaml's regular 6 | linear continuations that enables programming with multi-shot 7 | continuations, i.e. continuations that can be applied more than once. 8 | 9 | See the 10 | [`examples/`](https://github.com/dhil/ocaml-multicont/tree/master/examples) 11 | directory for concrete uses of this library (or multi-shot 12 | continuations) in practice. 13 | 14 | ## Installing the library 15 | 16 | The library can be installed via [OPAM](https://opam.ocaml.org/). The 17 | latest release can be installed directly from the default OPAM 18 | repository, e.g. 19 | 20 | ``` 21 | $ opam install multicont 22 | ``` 23 | 24 | Alternatively, the latest development version can be installed by 25 | pinning this repository, e.g. 26 | 27 | ``` 28 | $ opam pin multicont git@github.com:dhil/ocaml-multicont.git 29 | ``` 30 | 31 | ### Building and installing from source 32 | 33 | It is straightforward to build and install this library from source as 34 | its only dependencies are an [OCaml 35 | 5.0+](https://github.com/ocaml/ocaml) compiler, 36 | [dune](https://github.com/ocaml/dune), and 37 | [dune-configurator](https://github.com/ocaml/dune). To build the whole 38 | library simply invoke the `all` rule, i.e. 39 | 40 | ```shell 41 | $ make all 42 | ``` 43 | 44 | To install the library built from source simply invoke the `install` 45 | rule: 46 | 47 | ```shell 48 | $ make install 49 | ``` 50 | 51 | Similarly to uninstall the library again invoke the `uninstall` rule: 52 | 53 | ```shell 54 | $ make uninstall 55 | ``` 56 | 57 | ## Configurable options 58 | 59 | The primary reason to build from source is to toggle configurable 60 | options of this library, which are not readily available via OPAM 61 | install. Currently, there is only one configurable option: 62 | 63 | * `UNIQUE_FIBERS` (default: disabled): Since commit 64 | [ocaml/ocaml#e12b508](https://github.com/ocaml/ocaml/commit/e12b508876065723ed5fc35c0945030c9b7cd100) 65 | stock OCaml fibers have been equipped with unique identifiers. Enable 66 | this option to preserve unique identities amongst fibers as without 67 | this option a fiber clone is an exact copy of the original fiber, 68 | including its identity. By enabling this option, a cloned fiber will 69 | be assigned a new unique identity. 70 | 71 | Configurable options are toggled directly on the command line as a 72 | prefix to the `make` command. For instance, the following enables 73 | unique fiber identities: 74 | 75 | ```shell 76 | $ UNIQUE_FIBERS=1 make all 77 | ``` 78 | 79 | Setting an option to `1` enables it, whereas any other possible 80 | assignment disables it. 81 | 82 | ## The multi-shot continuations interface 83 | 84 | This library is designed to be used in tandem with the `Effect` 85 | module, which provides the API for regular linear continuations. The 86 | structure of this library mirrors that of `Effect` as it provides 87 | submodules for the `Deep` and `Shallow` variations of 88 | continuations. This library intentionally uses a slightly different 89 | terminology than `Effect` in order to allow both libraries to be 90 | opened in the same scope. For example, this library uses the 91 | terminology `resumption` in place of `continuation`. A resumption 92 | essentially amounts to a GC managed variation of a regular OCaml 93 | continuation, which in addition can be continued multiple times. The 94 | signature file 95 | [multicont.mli](https://github.com/dhil/ocaml-multicont/blob/master/multicont.mli) 96 | contains the interface for this library, which I have inlined below: 97 | 98 | ```ocaml 99 | module Deep: sig 100 | type ('a, 'b) resumption 101 | (** a [resumption] is a managed variation of 102 | [Effect.Deep.continuation] that can be used multiple times. *) 103 | 104 | val promote : ('a, 'b) Effect.Deep.continuation -> ('a, 'b) resumption 105 | (** [promote k] converts a regular linear deep continuation to a 106 | multi-shot deep resumption. This function fully consumes the 107 | supplied continuation [k]. *) 108 | 109 | val resume : ('a, 'b) resumption -> 'a -> 'b 110 | (** [resume r v] reinstates the context captured by the multi-shot 111 | deep resumption [r] with value [v]. *) 112 | 113 | val abort : ('a, 'b) resumption -> exn -> 'b 114 | (** [abort r e] injects the exception [e] into the context captured 115 | by the multi-shot deep resumption [r]. *) 116 | 117 | val abort_with_backtrace : ('a, 'b) resumption -> exn -> 118 | Printexc.raw_backtrace -> 'b 119 | (** [abort_with_backtrace k e bt] aborts the deep multi-shot 120 | resumption [r] by raising the exception [e] in [k] using [bt] as 121 | the origin for the exception. *) 122 | 123 | (* Primitives *) 124 | val clone_continuation : ('a, 'b) Effect.Deep.continuation -> ('a, 'b) Effect.Deep.continuation 125 | (** [clone_continuation k] clones the linear deep continuation [k]. The 126 | supplied continuation is *not* consumed. *) 127 | 128 | val drop_continuation : ('a, 'b) Effect.Deep.continuation -> unit 129 | (** [drop_continuation k] deallocates the memory occupied by the 130 | continuation [k]. Note, however, that this function does not clean 131 | up acquired resources captured by the continuation. In order to 132 | delete the continuation and free up the resources the programmer 133 | should instead use `discontinue` from the [Effect.Deep] module. *) 134 | end 135 | 136 | module Shallow: sig 137 | type ('a, 'b) resumption 138 | (** a [resumption] is a managed variation of 139 | [Effect.Shallow.continuation] that can be used multiple times. *) 140 | 141 | val promote : ('a, 'b) Effect.Shallow.continuation -> ('a, 'b) resumption 142 | (** [promote k] converts a regular linear shallow continuation to a 143 | multi-shot shallow resumption. This function fully consumes the 144 | supplied continuation [k]. *) 145 | 146 | val resume_with : ('c, 'a) resumption -> 'c -> ('a, 'b) handler -> 'b 147 | (** [resume r v h] reinstates the context captured by the multi-shot 148 | shallow resumption [r] with value [v] under the handler [h]. *) 149 | 150 | val abort_with : ('c, 'a) resumption -> exn -> ('a, 'b) handler -> 'b 151 | (** [abort r e h] injects the exception [e] into the context captured 152 | by the multi-shot shallow resumption [r] under the handler [h]. *) 153 | 154 | val abort_with_backtrace : ('c, 'a) resumption -> exn -> 155 | Printexc.raw_backtrace -> ('a, 'b) handler -> 'b 156 | (** [abort_with_backtrace k e bt] aborts the shallow multi-shot 157 | resumption [r] by raising the exception [e] in [k] using [bt] as 158 | the origin for the exception. *) 159 | 160 | (* Primitives *) 161 | val clone_continuation : ('a, 'b) Effect.Shallow.continuation -> ('a, 'b) Effect.Shallow.continuation 162 | (** [clone_continuation k] clones the linear shallow continuation [k]. The 163 | supplied continuation is *not* consumed. *) 164 | 165 | val drop_continuation : ('a, 'b) Effect.Shallow.continuation -> unit 166 | (** [drop_continuation k] deallocates the memory occupied by the 167 | continuation [k]. Note, however, that this function does not clean 168 | up acquired resources captured by the continuation. In order to 169 | delete the continuation and free up the resources the programmer 170 | should instead use [discontinue_with] from the [Effect.Shallow] module. *) 171 | end 172 | ``` 173 | 174 | It is worth stressing that both `resume`/`resume_with` and 175 | `abort`/`abort_with` exhibit multi-shot semantics, meaning in the 176 | latter case that it is possible to abort a given `resumption` multiple 177 | times. 178 | 179 | ## Cautionary tales in programming with multi-shot continuations in OCaml 180 | 181 | One must exercise caution when programming with multi-shot 182 | continuations in OCaml, as the programming model for continuations was 183 | designed with single-shot continuations in mind. Consequently, there 184 | are a couple of hazards that one should be aware of. Broadly, speaking 185 | we can classify these hazards into two categories: compiler 186 | optimisations and effect ordering. 187 | 188 | ### Compiler optimisation: Heap to stack conversion 189 | 190 | The OCaml compiler and runtime make some assumptions that are false in 191 | the presence of multi-shot continuations. This phenomenon is perhaps 192 | best illustrated by an example. Concretely, we can consider some 193 | optimisations performed by the compiler which are undesirable (or 194 | outright wrong) when programming with multi-shot continuations. An 195 | instance of a wrong compiler optimisation is *heap to stack* 196 | conversion, e.g. 197 | 198 | ```ocaml 199 | (* An illustration of how the heap to stack optimisation is broken. 200 | * This example is adapted from de Vilhena and Pottier (2021) to OCaml 5.3.0. 201 | * file: heap2stack.ml 202 | * compile: ocamlopt -I $(opam var lib)/multicont multicont.cmxa heap2stack.ml 203 | * run: ./a.out *) 204 | 205 | (* We first declare an operation `Twice' which we use to implement 206 | multiple returns. *) 207 | type _ Effect.t += Twice : unit Effect.t 208 | 209 | (* In the code below, we interpret `Twice` by cloning its continuation 210 | and invoking it twice. In the match expression, the compiler will 211 | perform an escape analysis on the reference `i' and deduce that it 212 | does not escape the local scope, because it is unaware of the 213 | semantics of `perform Twice', hence the optimiser will transform 214 | `i' into an immediate on the stack to save a heap allocation. As a 215 | consequence, the assertion `(!i = 1)' will succeed twice, whereas 216 | it should fail after the second return of `perform Twice'. *) 217 | let heap2stack () = 218 | match 219 | let i = ref 0 in 220 | Effect.perform Twice; 221 | i := !i + 1; 222 | Printf.printf "i = %d\n%!" !i; 223 | assert (!i = 1) 224 | with 225 | | x -> x 226 | | effect Twice, k -> 227 | Effect.Deep.continue (Multicont.Deep.clone_continuation k) (); 228 | Effect.Deep.continue k () 229 | 230 | (* The following does not trigger an assertion failure. *) 231 | let _ = heap2stack () 232 | 233 | (* To fix this issue, we can wrap reference allocations in an instance 234 | of `Sys.opaque_identity'. However, this is not really a viable fix 235 | in general, as we may not have access to the client code that 236 | allocates the reference! *) 237 | let heap2stack' () = 238 | match 239 | let i = Sys.opaque_identity (ref 0) in 240 | Effect.perform Twice; 241 | i := !i + 1; 242 | Printf.printf "i = %d\n%!" !i; 243 | assert (!i = 1) 244 | with 245 | | x -> x 246 | | effect Twice, k -> 247 | Effect.Deep.continue (Multicont.Deep.clone_continuation k) (); 248 | Effect.Deep.continue k () 249 | 250 | (* The following triggers an assertion failure. *) 251 | let _ = heap2stack' () 252 | ``` 253 | 254 | The wrong behaviour of `heap2stack` is only observed when compiling 255 | with `ocamlc` or `ocamlopt`. As of writing, the read-eval-print loop 256 | interpreter does not perform the heap to stack conversion, therefore 257 | running it through `ocaml` will cause `heap2stack` to trigger the 258 | assertion failure as desired. 259 | 260 | ### Effect ordering: Array initialisation 261 | 262 | We can use multi-shot continuations to inadvertently observe 263 | implementation details, which would otherwise be unobservable (inside 264 | the language). Lets illustrate this phenomenon with a concrete 265 | example. 266 | 267 | ```ocaml 268 | (* An illustration of how effect ordering is observable with 269 | * multi-shot continuations (OCaml 5.3.0). 270 | * file: efford.ml 271 | * compile: ocamlopt -I $(opam var lib)/multicont multicont.cmxa efford.ml 272 | * run: ./a.out *) 273 | 274 | (* We first require a little bit of setup. The following declares an 275 | operation `Twice' which we use to implement multiple returns. *) 276 | type _ Effect.t += Twice : bool Effect.t 277 | 278 | (* The handler `all' interprets `Twice' by enumerating the possible 279 | outcomes of its continuation. *) 280 | let all : 'a. (unit -> 'a) -> 'a list 281 | = fun f -> 282 | match f () with 283 | | x -> [x] 284 | | effect Twice, k -> 285 | let xs = Effect.Deep.continue (Multicont.Deep.clone_continuation k) true in 286 | let ys = Effect.Deep.continue k false in 287 | xs @ ys 288 | 289 | (* This function uses the `Twice` operation to initialise a bit vector 290 | of length `n`. *) 291 | let init_vec : int -> bool array 292 | = fun n -> 293 | Array.init n (fun _ -> Effect.perform Twice) 294 | 295 | (* The array backing the bit vector is imperative, thus one might 296 | expect the interpretation of `init_vec 1` with `htwice` to evaluate to 297 | `[[|false|];[|false|]]`, where the two arrays have the same 298 | identity. Lets see what it evaluates to... *) 299 | let _ = 300 | match all (fun () -> init_vec 1) with 301 | | [[|true|]; [|false|]] -> () 302 | | _ -> assert false 303 | (* We get two distinct arrays. Lets see what happens if we initialise 304 | a vector of length 2: *) 305 | let _ = 306 | match all (fun () -> init_vec 2) with 307 | | [[|true; false|]; [|true; false|]; [|false; false|]; [|false; false|]] -> () 308 | | _ -> assert false 309 | (* We have four arrays, but only two of them are distinct (both 310 | structurally and referentially). What about vectors of length 3? *) 311 | let _ = 312 | match all (fun () -> init_vec 3) with 313 | | [[|true; false; false|] ; [|true; false; false|] ; [|true; false; false|] ; [|true; false; false|]; 314 | [|false; false; false|]; [|false; false; false|]; [|false; false; false|]; [|false; false; false|]] -> () 315 | | _ -> assert false 316 | (* We have eight arrays, but again only two of them are distinct. This 317 | pattern continues as we increase `n`. So what's going on? It turns 318 | out that we are observing an implementation detail of 319 | `Array.init`. Its definition is: 320 | 321 | let init l f = 322 | if l = 0 then [||] else 323 | if l < 0 then invalid_arg "Array.init" else 324 | let res = create l (f 0) in (* !! *) 325 | for i = 1 to pred l do 326 | unsafe_set res i (f i) 327 | done; 328 | res 329 | 330 | The line with the code responsible for the behaviour is highlighted 331 | by the (* !! *) comment. Here we evaluate `f 0`, i.e. `perform 332 | Twice`, _before_ we allocate the array, meaning the second 333 | invocation of the continuation of the first `Twice` causes another 334 | array to be allocated, explaining why we always have two distinct 335 | arrays and why the first cell is not set to `false` in the first 336 | `n/2` arrays of the list. 337 | 338 | Essentially, we are witnessing the ordering between the user-defined 339 | operation `Twice` and the native operation for array creation. If we 340 | were to swap them, then we get the behaviour we may have expected 341 | initially. *) 342 | 343 | let init' : int -> (int -> bool) -> bool array 344 | = fun l f -> 345 | if l = 0 then [||] else 346 | if l < 0 then invalid_arg "Array.init" else 347 | let res = Array.make l true in 348 | Array.set res 0 (f 0); 349 | for i = 1 to pred l do 350 | Array.unsafe_set res i (f i) 351 | done; 352 | res 353 | 354 | (* Similar to `init_vec`, except we initialise the bit vector with 355 | our modified `init'`. *) 356 | let init_vec' : int -> bool array 357 | = fun n -> 358 | init' n (fun _ -> Effect.perform Twice) 359 | 360 | (* Lets rerun the examples from before. *) 361 | let _ = 362 | match all (fun () -> init_vec' 1) with 363 | | [[|false|]; [|false|]] -> () 364 | | _ -> assert false 365 | (* Here the two arrays are reference equal (i.e. they have the same identity). *) 366 | let _ = 367 | match all (fun () -> init_vec' 2) with 368 | | [[|false; false|]; [|false; false|]; [|false; false|]; [|false; false|]] -> () 369 | | _ -> assert false 370 | let _ = 371 | match all (fun () -> init_vec' 3) with 372 | | [[|false; false; false|]; [|false; false; false|]; [|false; false; false|]; [|false; false; false|]; 373 | [|false; false; false|]; [|false; false; false|]; [|false; false; false|]; [|false; false; false|]] -> () 374 | | _ -> assert false 375 | (* Evidently, the contents of the first cell are overridden by the 376 | second invocation of the initial continuation of `Twice`. *) 377 | ``` 378 | 379 | These behaviours are instances of the behaviour of composing 380 | nondeterminism and state to yield either backtrackable or 381 | non-backtrackable state. Either behaviour can be desirable. The word 382 | of caution here is that certain implementation details of higher-order 383 | functions may be observed to a greater extent than is possible with 384 | single-shot continuations or exceptions. 385 | 386 | ## Notes on the implementation 387 | 388 | Under the hood the library uses regular linear OCaml continuation and 389 | a variation of `clone_continuation` that used to reside in the `Obj` 390 | module of earlier versions of Multicore OCaml. Internally, the 391 | `resumption` types are aliases of the respective `continuation` types 392 | from the `Effect` module. The ability to resume a continuation more 393 | than once is achieved by cloning the original continuation on 394 | demand. The key functions `resume`, `resume_with`, `abort`, and 395 | `abort_with` all clone the provided continuation argument and invoke 396 | the resulting clone rather than the original continuation. The library 397 | guarantees that the original continuation remains cloneable as the 398 | call `promote k` deattaches the stack embedded in the continuation 399 | object `k`, meaning that the programmer cannot inadvertently destroy 400 | the stack by a call to `continue`. 401 | 402 | ## Acknowledgements 403 | 404 | This work was supported by the UKRI Future Leaders Fellowship 405 | "Effect Handler Oriented Programming" (reference number MR/T043830/1). 406 | -------------------------------------------------------------------------------- /config/configure.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let byte_flags = ref [] 4 | let native_flags = ref ["-DNATIVE_CODE"] 5 | 6 | let add_native_flag flag = 7 | native_flags := flag :: !native_flags 8 | 9 | let add_flag flag = 10 | byte_flags := flag :: !byte_flags; 11 | add_native_flag flag 12 | 13 | let () = 14 | let is_dev_profile = 15 | try 16 | let arg = Array.get Sys.argv 1 in 17 | String.equal arg "dev" 18 | with 19 | | Invalid_argument _ -> false 20 | in 21 | let () = 22 | if is_dev_profile then 23 | let debug_options = 24 | [ "-Wall"; "-Wextra"; "-Wpedantic" 25 | ; "-Wformat=2"; "-Wno-unused-parameter"; "-Wshadow" 26 | ; "-Wwrite-strings"; "-Wstrict-prototypes"; "-Wold-style-definition" 27 | ; "-Wredundant-decls"; "-Wnested-externs"; "-Wmissing-include-dirs" ] 28 | in 29 | List.iter add_flag debug_options 30 | in 31 | let options = 32 | [ "UNIQUE_FIBERS" ] 33 | in 34 | let toggle option = 35 | match Sys.getenv_opt option with 36 | | Some "1" -> 37 | add_flag (Printf.sprintf "-D%s" option) 38 | | _ -> () 39 | in 40 | List.iter toggle options; 41 | C.Flags.write_sexp "c_byte_flags.sexp" !byte_flags; 42 | C.Flags.write_sexp "c_native_flags.sexp" !native_flags 43 | -------------------------------------------------------------------------------- /config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name configure) 3 | (libraries dune-configurator)) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.14) 2 | (using mode_specific_stubs 0.1) 3 | 4 | (name multicont) 5 | 6 | (generate_opam_files true) 7 | 8 | (source 9 | (github dhil/ocaml-multicont)) 10 | 11 | (authors "Daniel Hillerström") 12 | (maintainers "Daniel Hillerström") 13 | 14 | (license MIT) 15 | 16 | ; (documentation https://url/to/documentation) 17 | 18 | (package 19 | (name multicont) 20 | (synopsis "Multi-shot continuations in OCaml") 21 | (description "This library provides facilities for programming with multi-shot continuations in OCaml") 22 | (depends (ocaml (>= 5.0.0)) 23 | dune 24 | (dune-configurator (>= 3.14))) 25 | (tags 26 | ("multi-shot continuations" "effect handlers"))) 27 | 28 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 29 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Compiling and running the examples 2 | 3 | To compile and run the examples suite you must first have installed 4 | the library via OPAM. In order to build the suite simply invoke 5 | `dune`, i.e. 6 | 7 | ```shell 8 | $ dune build 9 | ``` 10 | 11 | After successfully building the suite you can run each example via 12 | `dune`, which will run either the native or bytecode version of an 13 | example depending on which suffix you supply, e.g. to run the native 14 | version type 15 | 16 | ```shell 17 | $ dune exec ./nqueens.exe 18 | ``` 19 | 20 | and for the bytecode version type 21 | 22 | ```shell 23 | $ dune exec ./nqueens.bc.exe 24 | ``` 25 | 26 | -------------------------------------------------------------------------------- /examples/async.ml: -------------------------------------------------------------------------------- 1 | (* An algebraically well-behaved implementation of async/await with 2 | multi-shot continuations. *) 3 | 4 | module Async: sig 5 | module Promise: sig 6 | type 'a t 7 | exception Circular_await 8 | end 9 | 10 | val await : 'a Promise.t -> 'a 11 | val async : (unit -> 'a) -> 'a Promise.t 12 | val yield : unit -> unit 13 | val run : (unit -> 'a) -> 'a 14 | end = struct 15 | 16 | module Promise = struct 17 | type 'a promise = Done of 'a 18 | | Pending of ('a -> unit) list 19 | type 'a t = 'a promise ref 20 | 21 | exception Circular_await 22 | 23 | let is_done : 'a t -> bool 24 | = fun pr -> match !pr with 25 | | Done _ -> true 26 | | _ -> false 27 | 28 | let wait : 'a t -> ('a -> unit) -> unit 29 | = fun pr r -> match !pr with 30 | | Done _ -> assert false 31 | | Pending rs -> pr := Pending (r :: rs) 32 | 33 | let value : 'a t -> 'a 34 | = fun pr -> match !pr with 35 | | Done v -> v 36 | | Pending _ -> assert false 37 | 38 | let make_empty : unit -> 'a t 39 | = fun () -> ref (Pending []) 40 | end 41 | 42 | type _ Effect.t += Await : 'a Promise.t -> 'a Effect.t 43 | | Fork : bool Effect.t 44 | | Yield : unit Effect.t 45 | 46 | 47 | exception End_of_strand 48 | 49 | let await : 'a Promise.t -> 'a 50 | = fun pr -> Effect.perform (Await pr) 51 | 52 | let fork : unit -> bool 53 | = fun () -> Effect.perform Fork 54 | 55 | let yield : unit -> unit 56 | = fun () -> Effect.perform Yield 57 | 58 | let async : (unit -> 'a) -> 'a Promise.t 59 | = fun f -> 60 | let pr = Promise.make_empty () in 61 | if fork () (* returns twice *) 62 | then pr 63 | else let v = f () in 64 | (match !pr with 65 | | Done _ -> assert false 66 | | Pending rs -> 67 | pr := Done v; 68 | List.iter (fun r -> r v) rs); 69 | raise End_of_strand 70 | 71 | module Scheduler = struct 72 | 73 | type state = { suspended: (unit -> unit) Queue.t } 74 | 75 | let enqueue : state -> (unit -> unit) -> unit 76 | = fun st r -> 77 | Queue.add r st.suspended 78 | 79 | let run_next : state -> unit 80 | = fun st -> 81 | if Queue.is_empty st.suspended then () 82 | else Queue.take st.suspended () 83 | 84 | let run : (unit -> unit) -> unit 85 | = fun f -> 86 | let state = { suspended = Queue.create () } in 87 | match f () with 88 | | () -> () 89 | | exception End_of_strand -> run_next state 90 | | effect Await pr, k -> 91 | let open Effect.Deep in 92 | (if Promise.is_done pr 93 | then continue k (Promise.value pr) 94 | else Promise.wait pr (fun v -> continue k v)); 95 | run_next state 96 | | effect Fork, k -> 97 | let open Multicont.Deep in 98 | let r = promote k in 99 | enqueue state (fun () -> resume r false); 100 | resume r true 101 | | effect Yield, k -> 102 | let open Effect.Deep in 103 | enqueue state (fun () -> continue k ()); 104 | run_next state 105 | end 106 | 107 | let run : (unit -> 'a) -> 'a 108 | = fun f -> 109 | let result = ref (fun () -> raise Promise.Circular_await) in 110 | let f' () = 111 | let v = f () in 112 | result := (fun () -> v) 113 | in 114 | Scheduler.run f'; 115 | !result () 116 | end 117 | 118 | (* Another effect: dynamic binding *) 119 | module Env = struct 120 | type _ Effect.t += Ask : int Effect.t 121 | 122 | let ask : unit -> int 123 | = fun () -> Effect.perform Ask 124 | 125 | let bind : int -> (unit -> 'b) -> 'b 126 | = fun v f -> 127 | match f () with 128 | | ans -> ans 129 | | effect Ask, k -> Effect.Deep.continue k v 130 | end 131 | 132 | (* The `well-behaveness' of this implementation can be illustrated by 133 | using it in conjunction with another effect. In each async strand 134 | any occurrence of `Ask' is correctly bound by an ambient 135 | `Env.bind'. *) 136 | let main () = 137 | let task name () = 138 | Printf.printf "starting %s\n%!" name; 139 | let v = Env.ask () in 140 | Printf.printf "yielding %s\n%!" name; 141 | Async.yield (); 142 | Printf.printf "ending %s with %d\n%!" name v; 143 | v 144 | in 145 | let pa = 146 | Env.bind 40 147 | (fun () -> Async.async (task "a")) 148 | in 149 | let pb = 150 | Env.bind 2 151 | (fun () -> Async.async (task "b")) 152 | in 153 | let pc = 154 | Async.async 155 | (fun () -> Async.await pa + Async.await pb) 156 | in 157 | Printf.printf "Sum is %d\n" (Async.await pc); 158 | assert Async.(await pa + await pb = await pc) 159 | 160 | let _ = Async.run main 161 | 162 | (* The following program would deadlock if cyclic 163 | promise resolution was allowed *) 164 | (* let try_deadlock () = 165 | * let pr = ref (fun () -> assert false) in 166 | * let task () = 167 | * Async.await (!pr ()) 168 | * in 169 | * print_endline "Fork task"; 170 | * let pr' = Async.async task in 171 | * pr := (fun () -> pr'); 172 | * print_endline "Await"; 173 | * Async.await (!pr ()) 174 | * 175 | * let _ = Async.run try_deadlock *) 176 | -------------------------------------------------------------------------------- /examples/choice.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * McCarthy's locally angelic choice 3 | *) 4 | 5 | type 'a Effect.t += Choose : (unit -> 'a) list -> 'a Effect.t 6 | 7 | let amb : (unit -> 'a) list -> 'a 8 | = fun xs -> Effect.perform (Choose xs) 9 | 10 | let first_success (type b) : ('a -> b) -> (unit -> 'a) list -> b 11 | = fun f gs -> 12 | let exception Success of b in 13 | try 14 | List.iter 15 | (fun g -> 16 | try 17 | let x = g () in 18 | raise (Success (f x)) 19 | with (Success _) as e -> raise e 20 | | _ -> ()) 21 | gs; raise (Failure "no success") 22 | with Success r -> r 23 | 24 | let handle : (unit -> 'a) -> 'a 25 | = fun m -> 26 | (* McCarthy's locally angelic choice operator (angelic modulo 27 | nontermination). *) 28 | match m () with 29 | | ans -> ans 30 | | effect Choose xs, k -> 31 | let open Multicont.Deep in 32 | let r = promote k in 33 | first_success (resume r) xs 34 | 35 | (* The following examples are adapted from Oleg Kiselyov 36 | "Non-deterministic choice amb" 37 | (c.f. https://okmij.org/ftp/ML/ML.html#amb) *) 38 | 39 | (* An angelic choice *always* picks the successful branch. *) 40 | let _branch_example : unit -> int 41 | = fun () -> 42 | handle (fun () -> 43 | if amb [(fun () -> true); (fun () -> false)] 44 | then failwith "Fail" 45 | else 42) 46 | 47 | (* More involved example, requiring `amb` to make three correct 48 | choices. *) 49 | let pyth : int list -> (int * int * int) 50 | = fun numbers -> 51 | let numbers' = List.map (fun n -> (fun () -> n)) numbers in 52 | handle (fun () -> 53 | let i = amb numbers' in 54 | let j = amb numbers' in 55 | let k = amb numbers' in 56 | if i*i + j*j = k*k 57 | then (i, j, k) 58 | else failwith "no solution") 59 | 60 | let pyth_example () = pyth [1;2;3;4;5] 61 | 62 | let _ = 63 | let (x, y, z) = pyth_example () in 64 | Printf.printf "(%d, %d, %d)\n%!" x y z 65 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name nqueens) 3 | (modules nqueens) 4 | (modes byte_complete native) 5 | (enabled_if (>= %{ocaml_version} "5.3.0")) 6 | (libraries multicont)) 7 | 8 | (executable 9 | (name generic_count) 10 | (modules generic_count) 11 | (modes byte_complete native) 12 | (enabled_if (>= %{ocaml_version} "5.3.0")) 13 | (libraries multicont)) 14 | 15 | (executable 16 | (name choice) 17 | (modules choice) 18 | (modes byte_complete native) 19 | (enabled_if (>= %{ocaml_version} "5.3.0")) 20 | (libraries multicont)) 21 | 22 | (executable 23 | (name rollback) 24 | (modules rollback) 25 | (modes byte_complete native) 26 | (enabled_if (>= %{ocaml_version} "5.3.0")) 27 | (libraries multicont unix)) 28 | 29 | (executable 30 | (name supervised) 31 | (modules supervised) 32 | (modes byte_complete native) 33 | (enabled_if (>= %{ocaml_version} "5.3.0")) 34 | (libraries multicont)) 35 | 36 | (executable 37 | (name async) 38 | (modules async) 39 | (modes byte_complete native) 40 | (enabled_if (>= %{ocaml_version} "5.3.0")) 41 | (libraries multicont)) 42 | 43 | (executable 44 | (name return) 45 | (modules return) 46 | (modes byte_complete native) 47 | (enabled_if (>= %{ocaml_version} "5.3.0")) 48 | (libraries multicont)) 49 | 50 | (executable 51 | (name tautology) 52 | (modules tautology) 53 | (modes byte_complete native) 54 | (enabled_if (>= %{ocaml_version} "5.3.0")) 55 | (libraries multicont)) 56 | 57 | (executable 58 | (name knapsack) 59 | (modules knapsack) 60 | (modes byte_complete native) 61 | (enabled_if (>= %{ocaml_version} "5.3.0")) 62 | (libraries multicont)) 63 | 64 | -------------------------------------------------------------------------------- /examples/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | -------------------------------------------------------------------------------- /examples/generic_count.ml: -------------------------------------------------------------------------------- 1 | (* Generic counting example based on Hillerström et al. (2020) https://arxiv.org/abs/2007.00605 *) 2 | 3 | type _ Effect.t += Branch : bool Effect.t 4 | 5 | type point = int -> bool 6 | type predicate = point -> bool 7 | 8 | let xor : bool -> bool -> bool 9 | = fun p q -> (p || q) && not (p && q) 10 | 11 | let xor_predicate : int -> predicate 12 | = fun n p -> 13 | match List.init n p with 14 | | [] -> false 15 | | v :: vs -> List.fold_left xor v vs 16 | 17 | let generic_count : ((int -> bool) -> bool) -> int 18 | = fun f -> 19 | match f (fun _ -> Effect.perform Branch) with 20 | | ans -> if ans then 1 else 0 21 | | effect Branch, k -> 22 | let open Multicont.Deep in 23 | let r = promote k in 24 | let tt = resume r true in 25 | let ff = resume r false in 26 | tt + ff 27 | 28 | let _ = 29 | let n = try int_of_string Sys.argv.(1) with _ -> 8 in 30 | let solutions = generic_count (xor_predicate n) in 31 | Printf.printf "%d\n" solutions 32 | -------------------------------------------------------------------------------- /examples/knapsack.ml: -------------------------------------------------------------------------------- 1 | (* Solving the knapsack problem with continuations *) 2 | 3 | type response = Skip 4 | | Take 5 | 6 | type _ Effect.t += Pick : int * int -> response Effect.t 7 | 8 | let pick i c = Effect.perform (Pick (i, c)) 9 | 10 | (** A fast implementation of knapsack that uses an oracle to pick 11 | elements. The time complexity is pseudo-quadratic O(|ps| * c) *) 12 | let knapsack : int array -> int array -> int -> int 13 | = fun ps ws cap -> 14 | assert (Array.length ps = Array.length ws); 15 | assert (cap >= 0); 16 | let recall = 17 | Array.make_matrix (Array.length ps) (cap+1) (-1) 18 | (* ^ +1 here to make indexing slightly nicer, i.e. recall[i][c] rather than recall[i][c - 1]. *) 19 | in 20 | match 21 | let rec solver i n c = 22 | if i >= n || c <= 0 then 0 23 | else match pick i c with 24 | | Take -> solver (i + 1) n (c - ws.(i)) 25 | | Skip -> solver (i + 1) n c 26 | in 27 | solver 0 (Array.length ps) cap 28 | with 29 | | ans -> ans 30 | | effect Pick (i, c), k -> 31 | let open Multicont.Deep in 32 | let r = promote k in 33 | let payoff = recall.(i).(c) in 34 | if payoff < 0 35 | then if ws.(i) <= c 36 | then let tt = ps.(i) + resume r Take in 37 | let ff = resume r Skip in 38 | let ans = max tt ff in 39 | recall.(i).(c) <- ans; 40 | ans 41 | else let ans = resume r Skip in 42 | recall.(i).(c) <- ans; 43 | ans 44 | else payoff 45 | 46 | (** For comparison, a naive implementation with exponential time 47 | complexity. *) 48 | (* let knapsack_naive ps ws cap = *) 49 | (* assert (Array.length ps = Array.length ws); *) 50 | (* assert (cap >= 0); *) 51 | (* let rec solver i n c = *) 52 | (* if i >= n || c <= 0 then 0 *) 53 | (* else if ws.(i) <= c *) 54 | (* then let tt = ps.(i) + solver (i + 1) n (c - ws.(i)) in *) 55 | (* let ff = solver (i + 1) n c in *) 56 | (* max tt ff *) 57 | (* else solver (i + 1) n c *) 58 | 59 | (* in *) 60 | (* solver 0 (Array.length ps) cap *) 61 | 62 | (** For comparison, a fast implementation without continuations. *) 63 | (* let knapsack_nocont ps ws cap = *) 64 | (* assert (Array.length ps = Array.length ws); *) 65 | (* assert (cap >= 0); *) 66 | (* let recall = *) 67 | (* Array.make_matrix (Array.length ps) (cap+1) (-1) *) 68 | (* in *) 69 | (* let rec solver i n c = *) 70 | (* if i >= n || c <= 0 then 0 *) 71 | (* else if recall.(i).(c) < 0 *) 72 | (* then if ws.(i) <= c *) 73 | (* then let tt = ps.(i) + solver (i + 1) n (c - ws.(i)) in *) 74 | (* let ff = solver (i + 1) n c in *) 75 | (* let ans = max tt ff in *) 76 | (* recall.(i).(c) <- ans; *) 77 | (* ans *) 78 | (* else let ans = solver (i + 1) n c in *) 79 | (* recall.(i).(c) <- solver (i + 1) n c; *) 80 | (* ans *) 81 | (* else recall.(i).(c) *) 82 | (* in *) 83 | (* solver 0 (Array.length ps) cap *) 84 | 85 | let _ = 86 | let inputs = 87 | [ ([|4;5;6|], [|1;3;2|], 4) 88 | ; ([|4;5;6|], [|1;3;2|], 6) 89 | ; ([|1;2;3|], [|4;5;1|], 4) 90 | ; ([|10;15;40|], [|1;2;3|], 6) 91 | ; ([|60;100;120|], [|10;20;30|], 50) 92 | ; ([|135;139;149;150;156;163;173;184;192;201;210;214;221;229;240|], [|70;73;77;80;82;87;90;94;98;106;110;113;115;118;120|], 750) 93 | ; ([| 360; 83; 59; 130; 431; 67; 230; 52; 93; 125; 670; 892; 600; 38; 48; 147; 78; 256; 63; 17; 120; 164; 432; 35; 92; 110; 22; 42; 50; 323; 514; 28; 87; 73; 78; 15; 26; 78; 210; 36; 85; 189; 274; 43; 33; 10; 19; 389; 276; 312|], [|7; 0; 30; 22; 80; 94; 11; 81; 70; 64; 59; 18; 0; 36; 3; 8; 15; 42; 9; 0; 42; 47; 52; 32; 26; 48; 55; 6; 29; 84; 2; 4; 18; 56; 7; 29; 93; 44; 71; 3; 86; 66; 31; 65; 0; 79; 20; 65; 52; 13|], 850) ] 94 | in 95 | List.iter (fun (ps, ws, c) -> print_endline (string_of_int (knapsack ps ws c))) inputs 96 | (* List.iter (fun (ps, ws, c) -> print_endline (string_of_int (knapsack_nocont ps ws c))) inputs *) 97 | (* List.iter (fun (ps, ws, c) -> print_endline (string_of_int (knapsack_naive ps ws c))) inputs *) 98 | -------------------------------------------------------------------------------- /examples/legacy/README.md: -------------------------------------------------------------------------------- 1 | # Compiling and running the legacy examples 2 | 3 | The legacy examples do not make use of the effect handler syntax added 4 | in OCaml 5.3. To compile and run the examples suite you must first 5 | have installed the library via OPAM. In order to build the suite 6 | simply invoke `dune`, i.e. 7 | 8 | ```shell 9 | $ dune build 10 | ``` 11 | 12 | After successfully building the suite you can run each example via 13 | `dune`, which will run either the native or bytecode version of an 14 | example depending on which suffix you supply, e.g. to run the native 15 | version type 16 | 17 | ```shell 18 | $ dune exec ./nqueens.exe 19 | ``` 20 | 21 | and for the bytecode version type 22 | 23 | ```shell 24 | $ dune exec ./nqueens.bc.exe 25 | ``` -------------------------------------------------------------------------------- /examples/legacy/async.ml: -------------------------------------------------------------------------------- 1 | (* An algebraically well-behaved implementation of async/await with 2 | multi-shot continuations. *) 3 | 4 | module Async: sig 5 | module Promise: sig 6 | type 'a t 7 | exception Circular_await 8 | end 9 | 10 | val await : 'a Promise.t -> 'a 11 | val async : (unit -> 'a) -> 'a Promise.t 12 | val yield : unit -> unit 13 | val run : (unit -> 'a) -> 'a 14 | end = struct 15 | 16 | module Promise = struct 17 | type 'a promise = Done of 'a 18 | | Pending of ('a -> unit) list 19 | type 'a t = 'a promise ref 20 | 21 | exception Circular_await 22 | 23 | let is_done : 'a t -> bool 24 | = fun pr -> match !pr with 25 | | Done _ -> true 26 | | _ -> false 27 | 28 | let wait : 'a t -> ('a -> unit) -> unit 29 | = fun pr r -> match !pr with 30 | | Done _ -> assert false 31 | | Pending rs -> pr := Pending (r :: rs) 32 | 33 | let value : 'a t -> 'a 34 | = fun pr -> match !pr with 35 | | Done v -> v 36 | | Pending _ -> assert false 37 | 38 | let make_empty : unit -> 'a t 39 | = fun () -> ref (Pending []) 40 | end 41 | 42 | type _ Effect.t += Await : 'a Promise.t -> 'a Effect.t 43 | | Fork : bool Effect.t 44 | | Yield : unit Effect.t 45 | 46 | 47 | exception End_of_strand 48 | 49 | let await : 'a Promise.t -> 'a 50 | = fun pr -> Effect.perform (Await pr) 51 | 52 | let fork : unit -> bool 53 | = fun () -> Effect.perform Fork 54 | 55 | let yield : unit -> unit 56 | = fun () -> Effect.perform Yield 57 | 58 | let async : (unit -> 'a) -> 'a Promise.t 59 | = fun f -> 60 | let pr = Promise.make_empty () in 61 | if fork () (* returns twice *) 62 | then pr 63 | else let v = f () in 64 | (match !pr with 65 | | Done _ -> assert false 66 | | Pending rs -> 67 | pr := Done v; 68 | List.iter (fun r -> r v) rs); 69 | raise End_of_strand 70 | 71 | module Scheduler = struct 72 | 73 | type state = { suspended: (unit -> unit) Queue.t } 74 | 75 | let enqueue : state -> (unit -> unit) -> unit 76 | = fun st r -> 77 | Queue.add r st.suspended 78 | 79 | let run_next : state -> unit 80 | = fun st -> 81 | if Queue.is_empty st.suspended then () 82 | else Queue.take st.suspended () 83 | 84 | let hsched : unit -> (unit, unit) Effect.Deep.handler 85 | = fun () -> 86 | let state = { suspended = Queue.create () } in 87 | let open Effect.Deep in 88 | { retc = (fun () -> run_next state) 89 | ; exnc = (fun e -> 90 | match e with 91 | | End_of_strand -> run_next state 92 | | e -> raise e) 93 | ; effc = (fun (type a) (eff : a Effect.t) -> 94 | match eff with 95 | | Await pr -> Some (fun (k : (a, unit) continuation) -> 96 | (if Promise.is_done pr 97 | then continue k (Promise.value pr) 98 | else Promise.wait pr (fun v -> continue k v)); 99 | run_next state) 100 | | Fork -> Some (fun (k : (bool, unit) continuation) -> 101 | let open Multicont.Deep in 102 | let r = promote k in 103 | enqueue state (fun () -> resume r false); 104 | resume r true) 105 | | Yield -> Some (fun (k : (unit, unit) continuation) -> 106 | enqueue state (fun () -> continue k ()); 107 | run_next state) 108 | | _ -> None) } 109 | end 110 | 111 | let run : (unit -> 'a) -> 'a 112 | = fun f -> 113 | let result = ref (fun () -> raise Promise.Circular_await) in 114 | let f' () = 115 | let v = f () in 116 | result := (fun () -> v) 117 | in 118 | let () = Effect.Deep.match_with f' () (Scheduler.hsched ()) in 119 | !result () 120 | end 121 | 122 | (* Another effect: dynamic binding *) 123 | module Env = struct 124 | type _ Effect.t += Ask : int Effect.t 125 | 126 | let ask : unit -> int 127 | = fun () -> Effect.perform Ask 128 | 129 | let bind : int -> (unit -> 'b) -> 'b 130 | = fun v f -> 131 | let open Effect.Deep in 132 | let hdynbind : ('b, 'b) Effect.Deep.handler = 133 | { retc = (fun x -> x) 134 | ; exnc = (fun e -> raise e) 135 | ; effc = (fun (type a) (eff : a Effect.t) -> 136 | match eff with 137 | | Ask -> Some (fun (k : (a, _) continuation) -> 138 | continue k v) 139 | | _ -> None) } 140 | in 141 | match_with f () hdynbind 142 | end 143 | 144 | (* The `well-behaveness' of this implementation can be illustrated by 145 | using it in conjunction with another effect. In each async strand 146 | any occurrence of `Ask' is correctly bound by an ambient 147 | `Env.bind'. *) 148 | let main () = 149 | let task name () = 150 | Printf.printf "starting %s\n%!" name; 151 | let v = Env.ask () in 152 | Printf.printf "yielding %s\n%!" name; 153 | Async.yield (); 154 | Printf.printf "ending %s with %d\n%!" name v; 155 | v 156 | in 157 | let pa = 158 | Env.bind 40 159 | (fun () -> Async.async (task "a")) 160 | in 161 | let pb = 162 | Env.bind 2 163 | (fun () -> Async.async (task "b")) 164 | in 165 | let pc = 166 | Async.async 167 | (fun () -> Async.await pa + Async.await pb) 168 | in 169 | Printf.printf "Sum is %d\n" (Async.await pc); 170 | assert Async.(await pa + await pb = await pc) 171 | 172 | let _ = Async.run main 173 | 174 | (* The following program would deadlock if cyclic 175 | promise resolution was allowed *) 176 | (* let try_deadlock () = 177 | * let pr = ref (fun () -> assert false) in 178 | * let task () = 179 | * Async.await (!pr ()) 180 | * in 181 | * print_endline "Fork task"; 182 | * let pr' = Async.async task in 183 | * pr := (fun () -> pr'); 184 | * print_endline "Await"; 185 | * Async.await (!pr ()) 186 | * 187 | * let _ = Async.run try_deadlock *) 188 | -------------------------------------------------------------------------------- /examples/legacy/choice.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * McCarthy's locally angelic choice 3 | *) 4 | 5 | open Effect.Deep 6 | 7 | type 'a Effect.t += Choose : (unit -> 'a) list -> 'a Effect.t 8 | 9 | let amb : (unit -> 'a) list -> 'a 10 | = fun xs -> Effect.perform (Choose xs) 11 | 12 | let first_success (type b) : ('a -> b) -> (unit -> 'a) list -> b 13 | = fun f gs -> 14 | let exception Success of b in 15 | try 16 | List.iter 17 | (fun g -> 18 | try 19 | let x = g () in 20 | raise (Success (f x)) 21 | with (Success _) as e -> raise e 22 | | _ -> ()) 23 | gs; raise (Failure "no success") 24 | with Success r -> r 25 | 26 | let handle : (unit -> 'a) -> 'a 27 | = fun m -> 28 | (* McCarthy's locally angelic choice operator (angelic modulo 29 | nontermination). *) 30 | let hamb = 31 | { retc = (fun x -> x) 32 | ; exnc = (fun e -> raise e) 33 | ; effc = (fun (type b) (eff : b Effect.t) -> 34 | match eff with 35 | | Choose xs -> 36 | Some 37 | (fun (k : (b, _) continuation) -> 38 | let open Multicont.Deep in 39 | let r = promote k in 40 | first_success (resume r) xs) 41 | | _ -> None) } 42 | in 43 | match_with m () hamb 44 | 45 | (* The following examples are adapted from Oleg Kiselyov 46 | "Non-deterministic choice amb" 47 | (c.f. https://okmij.org/ftp/ML/ML.html#amb) *) 48 | 49 | (* An angelic choice *always* picks the successful branch. *) 50 | let _branch_example : unit -> int 51 | = fun () -> 52 | handle (fun () -> 53 | if amb [(fun () -> true); (fun () -> false)] 54 | then failwith "Fail" 55 | else 42) 56 | 57 | (* More involved example, requiring `amb` to make three correct 58 | choices. *) 59 | let pyth : int list -> (int * int * int) 60 | = fun numbers -> 61 | let numbers' = List.map (fun n -> (fun () -> n)) numbers in 62 | handle (fun () -> 63 | let i = amb numbers' in 64 | let j = amb numbers' in 65 | let k = amb numbers' in 66 | if i*i + j*j = k*k 67 | then (i, j, k) 68 | else failwith "no solution") 69 | 70 | let pyth_example () = pyth [1;2;3;4;5] 71 | 72 | let _ = 73 | let (x, y, z) = pyth_example () in 74 | Printf.printf "(%d, %d, %d)\n%!" x y z 75 | -------------------------------------------------------------------------------- /examples/legacy/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name nqueens) 3 | (modules nqueens) 4 | (modes byte_complete native) 5 | (libraries multicont)) 6 | 7 | (executable 8 | (name generic_count) 9 | (modules generic_count) 10 | (modes byte_complete native) 11 | (libraries multicont)) 12 | 13 | (executable 14 | (name choice) 15 | (modules choice) 16 | (modes byte_complete native) 17 | (libraries multicont)) 18 | 19 | (executable 20 | (name rollback) 21 | (modules rollback) 22 | (modes byte_complete native) 23 | (libraries multicont unix)) 24 | 25 | (executable 26 | (name supervised) 27 | (modules supervised) 28 | (modes byte_complete native) 29 | (libraries multicont)) 30 | 31 | (executable 32 | (name async) 33 | (modules async) 34 | (modes byte_complete native) 35 | (libraries multicont)) 36 | 37 | (executable 38 | (name return) 39 | (modules return) 40 | (modes byte_complete native) 41 | (libraries multicont)) 42 | 43 | (executable 44 | (name tautology) 45 | (modules tautology) 46 | (modes byte_complete native) 47 | (libraries multicont)) 48 | 49 | (executable 50 | (name knapsack) 51 | (modules knapsack) 52 | (modes byte_complete native) 53 | (libraries multicont)) 54 | -------------------------------------------------------------------------------- /examples/legacy/generic_count.ml: -------------------------------------------------------------------------------- 1 | (* Generic counting example based on Hillerström et al. (2020) https://arxiv.org/abs/2007.00605 *) 2 | 3 | open Effect.Deep 4 | 5 | type _ Effect.t += Branch : bool Effect.t 6 | 7 | type point = int -> bool 8 | type predicate = point -> bool 9 | 10 | let xor : bool -> bool -> bool 11 | = fun p q -> (p || q) && not (p && q) 12 | 13 | let xor_predicate : int -> predicate 14 | = fun n p -> 15 | match List.init n p with 16 | | [] -> false 17 | | v :: vs -> List.fold_left xor v vs 18 | 19 | let generic_count : (bool, int) handler = 20 | { retc = (fun x -> if x then 1 else 0) 21 | ; exnc = (fun e -> raise e) 22 | ; effc = (fun (type a) (eff : a Effect.t) -> 23 | match eff with 24 | | Branch -> 25 | Some (fun (k : (a, _) continuation) -> 26 | let open Multicont.Deep in 27 | let r = promote k in 28 | let tt = resume r true in 29 | let ff = resume r false in 30 | tt + ff) 31 | | _ -> None) } 32 | 33 | let _ = 34 | let n = try int_of_string Sys.argv.(1) with _ -> 8 in 35 | let solutions = match_with (xor_predicate n) (fun _ -> Effect.perform Branch) generic_count in 36 | Printf.printf "%d\n" solutions 37 | -------------------------------------------------------------------------------- /examples/legacy/knapsack.ml: -------------------------------------------------------------------------------- 1 | (* Solving the knapsack problem with continuations *) 2 | 3 | type response = Skip 4 | | Take 5 | 6 | type _ Effect.t += Pick : int * int -> response Effect.t 7 | 8 | let pick i c = Effect.perform (Pick (i, c)) 9 | 10 | let hmemo ps ws cap = 11 | let open Effect.Deep in 12 | let recall = 13 | Array.make_matrix (Array.length ps) (cap+1) (-1) 14 | in 15 | { retc = (fun ans -> ans) 16 | ; exnc = raise 17 | ; effc = (fun (type a) (eff : a Effect.t) -> 18 | match eff with 19 | | Pick (i, c) -> 20 | Some (fun (k : (a, _) continuation) -> 21 | let open Multicont.Deep in 22 | let r = promote k in 23 | let payoff = recall.(i).(c) in 24 | if payoff < 0 25 | then if ws.(i) <= c 26 | then let tt = ps.(i) + resume r Take in 27 | let ff = resume r Skip in 28 | let ans = max tt ff in 29 | recall.(i).(c) <- ans; 30 | ans 31 | else let ans = resume r Skip in 32 | recall.(i).(c) <- ans; 33 | ans 34 | else payoff) 35 | | _ -> None) } 36 | 37 | (** A fast implementation of knapsack that uses an oracle to pick 38 | elements. The time complexity is pseudo-quadratic O(|ps| * c) *) 39 | let knapsack : int array -> int array -> int -> int 40 | = fun ps ws cap -> 41 | assert (Array.length ps = Array.length ws); 42 | assert (cap >= 0); 43 | let rec solver i n c = 44 | if i >= n || c <= 0 then 0 45 | else match pick i c with 46 | | Take -> solver (i + 1) n (c - ws.(i)) 47 | | Skip -> solver (i + 1) n c 48 | in 49 | Effect.Deep.match_with (fun () -> solver 0 (Array.length ps) cap) () (hmemo ps ws cap) 50 | 51 | let _ = 52 | let inputs = 53 | [ ([|4;5;6|], [|1;3;2|], 4) 54 | ; ([|4;5;6|], [|1;3;2|], 6) 55 | ; ([|1;2;3|], [|4;5;1|], 4) 56 | ; ([|10;15;40|], [|1;2;3|], 6) 57 | ; ([|60;100;120|], [|10;20;30|], 50) 58 | ; ([|135;139;149;150;156;163;173;184;192;201;210;214;221;229;240|], [|70;73;77;80;82;87;90;94;98;106;110;113;115;118;120|], 750) 59 | ; ([| 360; 83; 59; 130; 431; 67; 230; 52; 93; 125; 670; 892; 600; 38; 48; 147; 78; 256; 63; 17; 120; 164; 432; 35; 92; 110; 22; 42; 50; 323; 514; 28; 87; 73; 78; 15; 26; 78; 210; 36; 85; 189; 274; 43; 33; 10; 19; 389; 276; 312|], [|7; 0; 30; 22; 80; 94; 11; 81; 70; 64; 59; 18; 0; 36; 3; 8; 15; 42; 9; 0; 42; 47; 52; 32; 26; 48; 55; 6; 29; 84; 2; 4; 18; 56; 7; 29; 93; 44; 71; 3; 86; 66; 31; 65; 0; 79; 20; 65; 52; 13|], 850) ] 60 | in 61 | List.iter (fun (ps, ws, c) -> print_endline (string_of_int (knapsack ps ws c))) inputs 62 | -------------------------------------------------------------------------------- /examples/legacy/nqueens.ml: -------------------------------------------------------------------------------- 1 | (* Prints the number of solutions to a given n-Queens problem. 2 | 3 | Adapted from 4 | https://github.com/effect-handlers/effect-handlers-bench/blob/ca4ed12fc2265c16c562016ec09f0466d81d1ddd/benchmarks/ocaml/001_nqueens/001_nqueens_ocaml.ml 5 | *) 6 | 7 | open Effect.Deep 8 | 9 | let n = try int_of_string Sys.argv.(1) with _ -> 8 10 | 11 | (* n-Queens logic. *) 12 | let rec safe queen diag xs = 13 | match xs with 14 | | [] -> true 15 | | q :: qs -> queen <> q && queen <> q + diag && queen <> q - diag && 16 | safe queen (diag + 1) qs 17 | 18 | type _ Effect.t += Pick : int -> int Effect.t 19 | exception Fail 20 | 21 | let rec find_solution n col : int list = 22 | if col = 0 then [] 23 | else let sol = find_solution n (col - 1) in 24 | let queen = Effect.perform (Pick n) in 25 | if safe queen 1 sol then queen::sol else raise Fail 26 | 27 | (* Deep effect handler that counts the number of solutions to an 28 | n-Queens problem. *) 29 | let count_queens_solutions = 30 | { retc = (fun _ -> 1) (* If the computation returns, then we have found a solution. *) 31 | ; exnc = (fun e -> match e with Fail -> 0 | _ -> raise e) (* If the computation fails, then we have not found a solution. *) 32 | ; effc = (fun (type a) (eff : a Effect.t) -> 33 | match eff with 34 | | Pick n -> (* We handle [Pick] by successively trying to place 35 | Queens on the board by invoking the provided 36 | continuation with different values. Each invocation 37 | returns the number of solutions in the 38 | subcomputation. *) 39 | Some (fun (k : (a, _) continuation) -> 40 | let open Multicont.Deep in 41 | (* Convert [k] into a multi-shot resumption *) 42 | let r = promote k in 43 | let rec loop i acc = 44 | if i > n then acc 45 | else (* Invoke the resumption. This branch may be 46 | executed many times. *) 47 | let nsol = resume r i in 48 | loop (i + 1) (nsol + acc) 49 | in 50 | loop 1 0) 51 | | _ -> None) } 52 | 53 | let queens_count n = 54 | match_with (fun () -> find_solution n n) () count_queens_solutions 55 | 56 | let _ = 57 | Printf.printf "%d\n" (queens_count n) 58 | -------------------------------------------------------------------------------- /examples/legacy/return.ml: -------------------------------------------------------------------------------- 1 | (* Illustrating the `return' operator as an effect. 2 | * 3 | * This encoding utilises only a single handler by leveraging the 4 | * power of multi-shot continuations to fork two strands of 5 | * computations. We use the first strand as the context wherein we 6 | * evaluate the function, whilst we use the second strand as a sort of 7 | * identity context wherein we return the value of the function 8 | * application without applying the function. In terms of effects, 9 | * exceptions, and handlers, we are going to use one operations: Fork 10 | * : () => [|Apply|Done:a|] which forks the current context, the 11 | * return value signals which strand of computation to execute; and 12 | * one exception Return of a. Concretely the idea is to invoke Fork 13 | * before a function application to capture the current continuation 14 | * of the application (i.e. the return point). Inside the handler for 15 | * Fork and Return we maintain a stack of continuations arising from 16 | * invocations of Fork. 17 | *) 18 | 19 | module type ALG = sig 20 | type t 21 | val apply : (t -> t) -> t -> t 22 | val return : t -> 'a 23 | val toplevel : (unit -> t) -> t 24 | end 25 | 26 | module Alg(D : sig type t end) : ALG with type t := D.t = struct 27 | type t = D.t 28 | 29 | type cmd = Apply 30 | | Done of t 31 | exception Return of t 32 | type _ Effect.t += Fork : cmd Effect.t 33 | 34 | let return x = raise (Return x) 35 | 36 | let apply f x = 37 | match Effect.perform Fork with 38 | | Apply -> return (f x) 39 | | Done ans -> ans 40 | 41 | let htoplevel : unit -> (t, t) Effect.Deep.handler 42 | = fun () -> 43 | let open Effect.Deep in 44 | let open Multicont.Deep in 45 | let conts = ref [] in 46 | let backup ans = 47 | match !conts with 48 | | r :: conts' -> 49 | conts := conts'; 50 | resume r (Done ans) 51 | | _ -> ans 52 | in 53 | let push r = 54 | conts := r :: !conts 55 | in 56 | { retc = (fun ans -> ans) 57 | ; exnc = 58 | (function 59 | Return ans -> backup ans 60 | | e -> raise e) 61 | ; effc = (fun (type a) (eff : a Effect.t) -> 62 | match eff with 63 | | Fork -> 64 | Some (fun (k : (a, _) continuation) -> 65 | let r = promote k in 66 | push r; 67 | resume r Apply) 68 | | _ -> None) } 69 | 70 | let toplevel f = 71 | Effect.Deep.match_with f () (htoplevel ()) 72 | end 73 | 74 | let fac n = 75 | let module I = Alg(struct type t = int end) in 76 | let rec fac n = 77 | if n = 0 then 1 78 | else n * (I.apply fac (n - 1)) 79 | in 80 | let negate x = 81 | I.apply ((-) 0) x 82 | in 83 | I.toplevel 84 | (fun () -> 85 | I.apply negate (I.apply fac n)) 86 | 87 | let fac' n = 88 | let module I = Alg(struct type t = int end) in 89 | let rec fac n = 90 | if n = 0 then I.return 1; 91 | n * (I.apply fac (n - 1)) 92 | in 93 | let negate x = 94 | I.apply ((-) 0) x 95 | in 96 | I.toplevel 97 | (fun () -> 98 | I.apply negate (I.apply fac n)) 99 | 100 | let _ = 101 | Printf.printf "%d\n%!" (fac 7); 102 | Printf.printf "%d\n%!" (fac' 7); 103 | -------------------------------------------------------------------------------- /examples/legacy/rollback.ml: -------------------------------------------------------------------------------- 1 | (* Modular rollback parsing. Adapted from Lindley et al. (2017), 2 | c.f. https://arxiv.org/pdf/1611.09259.pdf *) 3 | 4 | module IO = struct 5 | let term_io = Unix.(tcgetattr stdin) 6 | 7 | let get_char () = 8 | (* Disable canonical processing and echoing of input 9 | characters. *) 10 | Unix.(tcsetattr 11 | stdin 12 | TCSADRAIN 13 | { term_io with c_icanon = false; c_echo = false }); 14 | let ch = input_char stdin in 15 | (* Restore terminal defaults. *) 16 | Unix.(tcsetattr stdin TCSADRAIN term_io); 17 | ch 18 | 19 | let put_char ch = 20 | output_char stdout ch; flush stdout 21 | end 22 | 23 | type _ Effect.t += Peek : (unit -> char) Effect.t (* Returning a thunk is necessary to avoid a memory leak. See below. *) 24 | | Accept : unit Effect.t 25 | 26 | exception Abort 27 | 28 | let peek : unit -> char 29 | = fun () -> (Effect.perform Peek) () 30 | 31 | let accept : unit -> unit 32 | = fun () -> Effect.perform Accept 33 | 34 | let abort : unit -> 'a 35 | = fun () -> raise Abort 36 | 37 | type 'a log = Start of (unit, 'a) Multicont.Shallow.resumption 38 | | Inched of 'a log * ((unit -> char), 'a) Multicont.Shallow.resumption 39 | | Ouched of 'a log 40 | 41 | 42 | (* let identity : ('a, 'a) Effect.Shallow.handler 43 | * = { retc = (fun x -> x) 44 | * ; exnc = (fun e -> raise e) 45 | * ; effc = (fun (type a) (_ : a Effect.t) -> None) } *) 46 | 47 | let rec input : 'a log -> char option -> ('a, 'a) Effect.Shallow.handler 48 | = fun l buf -> 49 | let open Effect.Shallow in 50 | { retc = (fun x -> x) 51 | ; exnc = (function Abort -> rollback l | e -> raise e) 52 | ; effc = (fun (type a) (eff : a Effect.t) -> 53 | match eff with 54 | | Peek -> Some (fun (k : (a, _) continuation) -> 55 | let open Multicont.Shallow in 56 | let r = promote k in 57 | match buf with 58 | | Some c -> resume_with r (fun () -> c) (input l buf) 59 | | None -> match IO.get_char () with 60 | | '\b' -> rollback l 61 | | c -> resume_with r (fun () -> c) (input (Inched (l, r)) (Some c))) 62 | | Accept -> Some (fun (k : (a, _) continuation) -> 63 | let open Multicont.Shallow in 64 | let r = promote k in 65 | match buf with 66 | | Some c -> IO.put_char c; 67 | resume_with r () (input (Ouched l) None) 68 | | None -> resume_with r () (input l None)) 69 | | _ -> None) } 70 | and rollback : 'a log -> 'a = function 71 | | Start p -> parse p 72 | | Ouched l -> IO.put_char '\b'; 73 | rollback l 74 | | Inched (l, r) -> 75 | (* Here we want to inject a computation into the 76 | continuation. Specifically, we want to run the `peek` 77 | computation at the suspension point. For this reason the 78 | operation `Peek` returns a thunk of type `unit -> 79 | char`. Alternatively, we could wrap the composition `peek (); 80 | resume_with r (Input l None)` in an identity handler. Though, 81 | this introduces to a memory leak.*) 82 | let open Multicont.Shallow in 83 | resume_with r peek (input l None) 84 | and parse : (unit, 'a) Multicont.Shallow.resumption -> 'a 85 | = fun r -> 86 | let open Multicont.Shallow in 87 | resume_with r () (input (Start r) None) 88 | 89 | let rec zeros : int -> int 90 | = fun n -> 91 | match peek () with 92 | | '0' -> accept (); zeros (n+1) 93 | | ' ' -> accept (); n 94 | | _ -> abort () 95 | 96 | let _t1 () = 97 | let open Effect.Shallow in 98 | let open Multicont.Shallow in 99 | let i = parse (promote (fiber (fun () -> zeros 0))) in 100 | Printf.printf "%d\n%!" i 101 | 102 | let rec nest : char list -> int -> char list 103 | = fun cs n -> 104 | if n = 0 105 | then match peek () with 106 | | '(' -> accept (); nest cs 1 107 | | '\n' -> accept (); cs 108 | | _ -> abort () 109 | else match peek () with 110 | | '(' -> accept (); nest cs (n + 1) 111 | | ')' -> accept (); nest cs (n - 1) 112 | | c -> accept (); nest (c :: cs) n 113 | 114 | let t2 () = 115 | let open Effect.Shallow in 116 | let open Multicont.Shallow in 117 | let cs = List.rev (parse (promote (fiber (fun () -> nest [] 0)))) in 118 | Printf.printf "%s\n" (String.init (List.length cs) (fun i -> List.nth cs i)) 119 | 120 | let _ = t2 () 121 | -------------------------------------------------------------------------------- /examples/legacy/supervised.ml: -------------------------------------------------------------------------------- 1 | (* Restartable processes *) 2 | 3 | module Pid = struct 4 | type t = Zero 5 | | NonZero of int 6 | 7 | let is_zero : t -> bool = function 8 | | Zero -> true 9 | | _ -> false 10 | 11 | let zero : t = Zero 12 | 13 | let make : int -> t 14 | = fun ident -> NonZero ident 15 | end 16 | 17 | type _ Effect.t += Fork : Pid.t Effect.t 18 | | Join : Pid.t -> unit Effect.t 19 | 20 | exception Fail 21 | 22 | 23 | let fork : unit -> Pid.t 24 | = fun () -> Effect.perform Fork 25 | 26 | let join : Pid.t -> unit 27 | = fun pid -> Effect.perform (Join pid) 28 | 29 | let fail : unit -> 'a 30 | = fun () -> raise Fail 31 | 32 | 33 | (* Supervisor state *) 34 | type sstate = { mutable suspended: (Pid.t * (unit -> unit)) list 35 | ; mutable blocked: (Pid.t * (Pid.t * (unit -> unit)) list) list 36 | ; mutable finished: Pid.t list 37 | ; mutable active: Pid.t * (unit -> unit) 38 | ; mutable nextpid: int } 39 | 40 | let supervise : (unit -> unit) -> unit 41 | = fun f -> 42 | let state = 43 | { suspended = [] 44 | ; blocked = [] 45 | ; finished = [] 46 | ; active = (Pid.zero, (fun () -> assert false)) 47 | ; nextpid = 2 } 48 | in 49 | let supervisor = 50 | let open Effect.Deep in 51 | { retc = (fun _ -> 52 | let (pid, _) = state.active in 53 | state.finished <- pid :: state.finished; 54 | let rs, blocked = 55 | match List.assoc_opt pid state.blocked with 56 | | None -> [], state.blocked 57 | | Some rs -> rs, List.remove_assoc pid state.blocked 58 | in 59 | match state.suspended @ rs with 60 | | [] -> () 61 | | (pid, r) :: rs -> 62 | state.suspended <- rs; 63 | state.blocked <- blocked; 64 | state.active <- (pid, r); 65 | r ()) 66 | ; exnc = (fun e -> 67 | match e with 68 | | Fail -> 69 | begin match state.suspended @ [state.active] with 70 | | [] -> assert false 71 | | (pid, r) :: rs -> 72 | state.active <- (pid, r); 73 | state.suspended <- rs; 74 | r () 75 | end 76 | | _ -> raise e) 77 | ; effc = (fun (type a) (eff : a Effect.t) -> 78 | match eff with 79 | | Fork -> 80 | Some (fun (k : (a, _) continuation) -> 81 | let open Multicont.Deep in 82 | let r = promote k in 83 | let pid = 84 | let i = state.nextpid in 85 | state.nextpid <- i + 1; 86 | Pid.make i 87 | in 88 | state.suspended <- state.suspended @ [pid, (fun () -> resume r Pid.zero)]; 89 | resume r pid) 90 | | Join (pid : Pid.t) -> 91 | Some (fun (k : (a, _) continuation) -> 92 | let open Multicont.Deep in 93 | let r = promote k in 94 | if List.mem pid state.finished 95 | then resume r () 96 | else let blocked = 97 | match List.assoc_opt pid state.blocked with 98 | | None -> (pid, [fst state.active, (fun () -> resume r ())]) :: state.blocked 99 | | Some _ -> state.blocked 100 | in 101 | state.blocked <- blocked; 102 | match state.suspended with 103 | | [] -> assert false 104 | | (pid', r) :: rs -> 105 | state.active <- (pid', r); 106 | state.suspended <- rs; 107 | r ()) 108 | | _ -> None) } 109 | in 110 | state.active <- (Pid.make 1, (fun () -> Effect.Deep.match_with f () supervisor)); 111 | Effect.Deep.match_with f () supervisor 112 | 113 | let child : int -> int -> int ref -> unit 114 | = fun i n st -> 115 | if !st < n 116 | then (incr st 117 | ; Printf.printf "Child %d failed!\n%!" i 118 | ; fail ()) 119 | else Printf.printf "Child %d succeeded!\n%!" i 120 | 121 | let example () = 122 | let s = ref 0 in 123 | let pid = fork () in 124 | if Pid.is_zero pid 125 | then let pid = fork () in 126 | if Pid.is_zero pid 127 | then child 2 5 s 128 | else (child 1 3 s 129 | ; Printf.printf "Child 1 joining with Child 2\n%!" 130 | ; join pid 131 | ; Printf.printf "Child 1 joined with Child 2\n%!") 132 | else (print_endline "Parent joining with Child 1" 133 | ; join pid 134 | ; print_endline "Parent joined with Child 1") 135 | 136 | let _ = supervise example 137 | 138 | -------------------------------------------------------------------------------- /examples/legacy/tautology.ml: -------------------------------------------------------------------------------- 1 | (** Example adapted from Campbell et al. (2024) "Effectful Assembly 2 | Programming with AsmFX" at HOPE@ICFP'24 *) 3 | 4 | type _ Effect.t += Guess : bool Effect.t 5 | 6 | let guess () = Effect.perform Guess 7 | 8 | (* (A && B) || not A || not B *) 9 | let prop () = 10 | let a = guess () in 11 | let b = guess () in 12 | (a && b) || not a || not b 13 | 14 | let tautology p = 15 | let h = 16 | let open Effect.Deep in 17 | { retc = (fun ans -> ans) 18 | ; exnc = raise 19 | ; effc = (fun (type a) (eff : a Effect.t) -> 20 | match eff with 21 | | Guess -> 22 | Some (fun (k : (a, _) continuation) -> 23 | let open Multicont.Deep in 24 | let r = promote k in 25 | resume r true && resume r false) 26 | | _ -> None) } 27 | in 28 | Effect.Deep.match_with p () h 29 | 30 | let _ = if tautology prop 31 | then print_endline "true" 32 | else print_endline "false" 33 | -------------------------------------------------------------------------------- /examples/nqueens.ml: -------------------------------------------------------------------------------- 1 | (* Prints the number of solutions to a given n-Queens problem. 2 | 3 | Adapted from 4 | https://github.com/effect-handlers/effect-handlers-bench/blob/ca4ed12fc2265c16c562016ec09f0466d81d1ddd/benchmarks/ocaml/001_nqueens/001_nqueens_ocaml.ml 5 | *) 6 | 7 | let n = try int_of_string Sys.argv.(1) with _ -> 8 8 | 9 | (* n-Queens logic. *) 10 | let rec safe queen diag xs = 11 | match xs with 12 | | [] -> true 13 | | q :: qs -> queen <> q && queen <> q + diag && queen <> q - diag && 14 | safe queen (diag + 1) qs 15 | 16 | type _ Effect.t += Pick : int -> int Effect.t 17 | exception Fail 18 | 19 | let rec find_solution n col : int list = 20 | if col = 0 then [] 21 | else let sol = find_solution n (col - 1) in 22 | let queen = Effect.perform (Pick n) in 23 | if safe queen 1 sol then queen::sol else raise Fail 24 | 25 | (* Deep effect handler that counts the number of solutions to an 26 | n-Queens problem. *) 27 | let queens_count n = 28 | match find_solution n n with 29 | | _ -> 1 (* If the computation returns, then we have found a solution. *) 30 | | exception Fail -> 0 (* If the computation fails, then we have not found a solution. *) 31 | | effect Pick n, k -> 32 | (* We handle [Pick] by successively trying to place Queens on the 33 | board by invoking the provided continuation with different 34 | values. Each invocation returns the number of solutions in the 35 | subcomputation. *) 36 | let open Multicont.Deep in 37 | (* Convert [k] into a multi-shot resumption *) 38 | let r = promote k in 39 | let rec loop i acc = 40 | if i > n then acc 41 | else (* Invoke the resumption. This branch may be executed many 42 | times. *) 43 | let nsol = resume r i in 44 | loop (i + 1) (nsol + acc) 45 | in 46 | loop 1 0 47 | 48 | let _ = 49 | Printf.printf "%d\n" (queens_count n) 50 | -------------------------------------------------------------------------------- /examples/return.ml: -------------------------------------------------------------------------------- 1 | (* Illustrating the `return' operator as an effect. 2 | * 3 | * This encoding utilises only a single handler by leveraging the 4 | * power of multi-shot continuations to fork two strands of 5 | * computations. We use the first strand as the context wherein we 6 | * evaluate the function, whilst we use the second strand as a sort of 7 | * identity context wherein we return the value of the function 8 | * application without applying the function. In terms of effects, 9 | * exceptions, and handlers, we are going to use one operations: Fork 10 | * : () => [|Apply|Done:a|] which forks the current context, the 11 | * return value signals which strand of computation to execute; and 12 | * one exception Return of a. Concretely the idea is to invoke Fork 13 | * before a function application to capture the current continuation 14 | * of the application (i.e. the return point). Inside the handler for 15 | * Fork and Return we maintain a stack of continuations arising from 16 | * invocations of Fork. 17 | *) 18 | 19 | module type ALG = sig 20 | type t 21 | val apply : (t -> t) -> t -> t 22 | val return : t -> 'a 23 | val toplevel : (unit -> t) -> t 24 | end 25 | 26 | module Alg(D : sig type t end) : ALG with type t := D.t = struct 27 | type t = D.t 28 | 29 | type cmd = Apply 30 | | Done of t 31 | exception Return of t 32 | type _ Effect.t += Fork : cmd Effect.t 33 | 34 | let return x = raise (Return x) 35 | 36 | let apply f x = 37 | match Effect.perform Fork with 38 | | Apply -> return (f x) 39 | | Done ans -> ans 40 | 41 | let toplevel : (unit -> t) -> t 42 | = fun f -> 43 | let open Multicont.Deep in 44 | let conts = ref [] in 45 | let backup ans = 46 | match !conts with 47 | | r :: conts' -> 48 | conts := conts'; 49 | resume r (Done ans) 50 | | _ -> ans 51 | in 52 | let push r = 53 | conts := r :: !conts 54 | in 55 | match f () with 56 | | ans -> ans 57 | | exception Return ans -> backup ans 58 | | effect Fork, k -> 59 | let r = promote k in 60 | push r; 61 | resume r Apply 62 | end 63 | 64 | let fac n = 65 | let module I = Alg(struct type t = int end) in 66 | let rec fac n = 67 | if n = 0 then 1 68 | else n * (I.apply fac (n - 1)) 69 | in 70 | let negate x = 71 | I.apply ((-) 0) x 72 | in 73 | I.toplevel 74 | (fun () -> 75 | I.apply negate (I.apply fac n)) 76 | 77 | let fac' n = 78 | let module I = Alg(struct type t = int end) in 79 | let rec fac n = 80 | if n = 0 then I.return 1; 81 | n * (I.apply fac (n - 1)) 82 | in 83 | let negate x = 84 | I.apply ((-) 0) x 85 | in 86 | I.toplevel 87 | (fun () -> 88 | I.apply negate (I.apply fac n)) 89 | 90 | let _ = 91 | Printf.printf "%d\n%!" (fac 7); 92 | Printf.printf "%d\n%!" (fac' 7); 93 | -------------------------------------------------------------------------------- /examples/rollback.ml: -------------------------------------------------------------------------------- 1 | (* Modular rollback parsing. Adapted from Lindley et al. (2017), 2 | c.f. https://arxiv.org/pdf/1611.09259.pdf *) 3 | 4 | module IO = struct 5 | let attrs = Unix.(tcgetattr stdin) 6 | let buf = Bytes.create 1 7 | (* Restore terminal defaults at exit. *) 8 | let _ = at_exit (fun _ -> Unix.(tcsetattr stdin TCSAFLUSH attrs)) 9 | 10 | let get_char () = 11 | (* Disable canonical processing and echoing of input 12 | characters. *) 13 | Unix.(tcsetattr stdin TCSAFLUSH 14 | { attrs with c_icanon = false; c_echo = false; c_vmin = 1; c_vtime = 0 }); 15 | let len = Unix.(read stdin) buf 0 1 in 16 | if len = 0 then raise End_of_file 17 | else Bytes.get buf 0 18 | 19 | let put_char ch = 20 | Bytes.set buf 0 ch; 21 | let len = Unix.(write stdout buf 0 1) in 22 | if len = 0 then raise (Failure "write failed") 23 | 24 | let backspace () = 25 | put_char '\b'; put_char ' '; put_char '\b' 26 | end 27 | 28 | type _ Effect.t += Peek : (unit -> char) Effect.t (* Returning a thunk is necessary to avoid a memory leak. See below. *) 29 | | Accept : unit Effect.t 30 | 31 | exception Abort 32 | 33 | let peek : unit -> char 34 | = fun () -> (Effect.perform Peek) () 35 | 36 | let accept : unit -> unit 37 | = fun () -> Effect.perform Accept 38 | 39 | let abort : unit -> 'a 40 | = fun () -> raise Abort 41 | 42 | type 'a log = Start of (unit -> 'a) 43 | | Inched of 'a state * ((unit -> char), ('a state -> 'a)) Multicont.Deep.resumption 44 | | Ouched of 'a state 45 | and 'a state = { log: 'a log; buf: char option } 46 | 47 | let rec input : (unit -> 'a) -> 'a state -> 'a 48 | = fun f -> 49 | match f () with 50 | | ans -> (fun _ -> ans) 51 | | exception Abort -> (fun st -> rollback st) 52 | | effect Peek, k -> (fun st -> 53 | let open Multicont.Deep in 54 | let r = promote k in 55 | match st.buf with 56 | | Some c -> resume r (fun () -> c) st 57 | | None -> match IO.get_char () with 58 | | '\b' -> IO.backspace (); rollback st 59 | | c -> let st' = { log = Inched (st, r); buf = Some c } in 60 | resume r (fun () -> c) st') 61 | | effect Accept, k -> (fun st -> 62 | let open Multicont.Deep in 63 | let r = promote k in 64 | match st.buf with 65 | | Some c -> IO.put_char c; 66 | let st' = { log = Ouched st; buf = None } in 67 | resume r () st' 68 | | None -> let st' = { st with buf = None } in 69 | resume r () st') 70 | and rollback : 'a state -> 'a 71 | = fun st -> 72 | match st.log with 73 | | Start f -> parse f 74 | | Ouched st' -> rollback st' 75 | | Inched (st', r) -> 76 | (* Here we want to inject a computation into the 77 | continuation. Specifically, we want to run the `peek` 78 | computation at the suspension point. For this reason the 79 | operation `Peek` returns a thunk of type `unit -> 80 | char`. Alternatively, we could wrap the composition `peek (); 81 | resume_with r (Input l None)` in an identity handler. Though, 82 | this introduces to a memory leak.*) 83 | let open Multicont.Deep in 84 | resume r peek { st' with buf = None } 85 | and parse : (unit -> 'a) -> 'a 86 | = fun f -> 87 | input f { log = Start f; buf = None } 88 | 89 | let rec zeros : int -> int 90 | = fun n -> 91 | match peek () with 92 | | '0' -> accept (); zeros (n+1) 93 | | ' ' -> accept (); n 94 | | _ -> abort () 95 | 96 | let _t1 () = 97 | let i = parse (fun () -> zeros 0) in 98 | Printf.printf "%d\n%!" i 99 | 100 | let rec nest : char list -> int -> char list 101 | = fun cs n -> 102 | if n = 0 103 | then match peek () with 104 | | '(' -> accept (); nest cs 1 105 | | '\n' -> accept (); cs 106 | | _ -> abort () 107 | else match peek () with 108 | | '(' -> accept (); nest cs (n + 1) 109 | | ')' -> accept (); nest cs (n - 1) 110 | | c -> accept (); nest (c :: cs) n 111 | 112 | let t2 () = 113 | let cs = List.rev (parse (fun () -> nest [] 0)) in 114 | Printf.printf "%s\n" (String.init (List.length cs) (fun i -> List.nth cs i)) 115 | 116 | let _ = t2 () 117 | -------------------------------------------------------------------------------- /examples/supervised.ml: -------------------------------------------------------------------------------- 1 | (* Restartable processes *) 2 | 3 | module Pid = struct 4 | type t = Zero 5 | | NonZero of int 6 | 7 | let is_zero : t -> bool = function 8 | | Zero -> true 9 | | _ -> false 10 | 11 | let zero : t = Zero 12 | 13 | let make : int -> t 14 | = fun ident -> NonZero ident 15 | end 16 | 17 | type _ Effect.t += Fork : Pid.t Effect.t 18 | | Join : Pid.t -> unit Effect.t 19 | 20 | exception Fail 21 | 22 | 23 | let fork : unit -> Pid.t 24 | = fun () -> Effect.perform Fork 25 | 26 | let join : Pid.t -> unit 27 | = fun pid -> Effect.perform (Join pid) 28 | 29 | let fail : unit -> 'a 30 | = fun () -> raise Fail 31 | 32 | 33 | (* Supervisor state *) 34 | type sstate = { mutable suspended: (Pid.t * (unit -> unit)) list 35 | ; mutable blocked: (Pid.t * (Pid.t * (unit -> unit)) list) list 36 | ; mutable finished: Pid.t list 37 | ; mutable active: Pid.t * (unit -> unit) 38 | ; mutable nextpid: int } 39 | 40 | let supervise : (unit -> unit) -> unit 41 | = fun f -> 42 | let state = 43 | { suspended = [] 44 | ; blocked = [] 45 | ; finished = [] 46 | ; active = (Pid.make 1, (fun () -> assert false)) 47 | ; nextpid = 2 } 48 | in 49 | match f () with 50 | | () -> 51 | let (pid, _) = state.active in 52 | state.finished <- pid :: state.finished; 53 | let rs, blocked = 54 | match List.assoc_opt pid state.blocked with 55 | | None -> [], state.blocked 56 | | Some rs -> rs, List.remove_assoc pid state.blocked 57 | in 58 | begin match state.suspended @ rs with 59 | | [] -> () 60 | | (pid, r) :: rs -> 61 | state.suspended <- rs; 62 | state.blocked <- blocked; 63 | state.active <- (pid, r); 64 | r () 65 | end 66 | | exception Fail -> 67 | begin match state.suspended @ [state.active] with 68 | | [] -> assert false 69 | | (pid, r) :: rs -> 70 | state.active <- (pid, r); 71 | state.suspended <- rs; 72 | r () 73 | end 74 | | effect Fork, k -> 75 | let open Multicont.Deep in 76 | let r = promote k in 77 | let pid = 78 | let i = state.nextpid in 79 | state.nextpid <- i + 1; 80 | Pid.make i 81 | in 82 | state.suspended <- state.suspended @ [pid, (fun () -> resume r Pid.zero)]; 83 | resume r pid 84 | | effect Join pid, k -> 85 | let open Multicont.Deep in 86 | let r = promote k in 87 | if List.mem pid state.finished 88 | then resume r () 89 | else let blocked = 90 | match List.assoc_opt pid state.blocked with 91 | | None -> (pid, [fst state.active, (fun () -> resume r ())]) :: state.blocked 92 | | Some _ -> state.blocked 93 | in 94 | state.blocked <- blocked; 95 | match state.suspended with 96 | | [] -> assert false 97 | | (pid', r) :: rs -> 98 | state.active <- (pid', r); 99 | state.suspended <- rs; 100 | r () 101 | 102 | let child : int -> int -> int ref -> unit 103 | = fun i n st -> 104 | if !st < n 105 | then (incr st 106 | ; Printf.printf "Child %d failed!\n%!" i 107 | ; fail ()) 108 | else Printf.printf "Child %d succeeded!\n%!" i 109 | 110 | let example () = 111 | let s = ref 0 in 112 | let pid = fork () in 113 | if Pid.is_zero pid 114 | then let pid = fork () in 115 | if Pid.is_zero pid 116 | then child 2 5 s 117 | else (child 1 3 s 118 | ; Printf.printf "Child 1 joining with Child 2\n%!" 119 | ; join pid 120 | ; Printf.printf "Child 1 joined with Child 2\n%!") 121 | else (print_endline "Parent joining with Child 1" 122 | ; join pid 123 | ; print_endline "Parent joined with Child 1") 124 | 125 | let _ = supervise example 126 | 127 | -------------------------------------------------------------------------------- /examples/tautology.ml: -------------------------------------------------------------------------------- 1 | (** Example adapted from Campbell et al. (2024) "Effectful Assembly 2 | Programming with AsmFX" at HOPE@ICFP'24 *) 3 | 4 | type _ Effect.t += Guess : bool Effect.t 5 | 6 | let guess () = Effect.perform Guess 7 | 8 | (* (A && B) || not A || not B *) 9 | let prop () = 10 | let a = guess () in 11 | let b = guess () in 12 | (a && b) || not a || not b 13 | 14 | let tautology p = 15 | match p () with 16 | | ans -> ans 17 | | effect Guess, k -> 18 | let open Multicont.Deep in 19 | let r = promote k in 20 | resume r true && resume r false 21 | 22 | let _ = if tautology prop 23 | then print_endline "true" 24 | else print_endline "false" 25 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name multicont) 3 | (public_name multicont) 4 | (modes byte best) 5 | (foreign_stubs 6 | (language c) 7 | (mode byte) 8 | (flags :standard (:include c_byte_flags.sexp)) 9 | (names multicont_stubs)) 10 | (foreign_stubs 11 | (language c) 12 | (mode native) 13 | (flags :standard (:include c_native_flags.sexp)) 14 | (names multicont_stubs))) 15 | 16 | (rule 17 | (targets c_byte_flags.sexp c_native_flags.sexp) 18 | (action (run ../config/configure.exe %{profile}))) 19 | -------------------------------------------------------------------------------- /lib/fiber_primitives.h: -------------------------------------------------------------------------------- 1 | #ifndef MULTICONT_FIBER_PRIMITIVES_H 2 | #define MULTICONT_FIBER_PRIMITIVES_H 3 | 4 | #ifdef UNIQUE_FIBERS 5 | // Since commit ocaml/ocaml#e12b508 fibers are equipped with a unique 6 | // identifier. The fiber id generator is hidden/private in the OCaml 7 | // runtime. Thus if we want to maintain uniqueness of cloned fibers, 8 | // then we have to roll our own generator. Looking at the 9 | // implementation of the stock OCaml generator it seems that it only 10 | // uses the non-negative range of `int64_t`, therefore to ensure 11 | // uniqueness amongst all fibers, we can use the negative range of 12 | // `int64_t` to assign identifiers to cloned fibers. 13 | static _Atomic int64_t multicont_fiber_id; 14 | #define MULTICONT_NEXT_FIBER_ID atomic_fetch_sub(&multicont_fiber_id, 1) 15 | #endif 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /lib/multicont.ml: -------------------------------------------------------------------------------- 1 | (* The modules [Deep] and [Shallow] provide a multi-shot semantics for 2 | OCaml's regular deep and shallow continuations, respectively. This 3 | semantics is achieved by performing a shallow copy of linear 4 | continuations on demand (i.e. prior to invocation). *) 5 | 6 | module Deep = struct 7 | open Effect.Deep 8 | 9 | type ('a, 'b) resumption = ('a, 'b) continuation 10 | 11 | (* Primitives *) 12 | external clone_continuation : ('a, 'b) continuation -> ('a, 'b) continuation 13 | = "multicont_clone_continuation" 14 | external drop_continuation : ('a, 'b) continuation -> unit 15 | = "multicont_drop_continuation" 16 | external promote : ('a, 'b) continuation -> ('a, 'b) resumption 17 | = "multicont_promote" 18 | 19 | let promote : ('a, 'b) continuation -> ('a, 'b) resumption 20 | = fun k -> 21 | let r = promote k in 22 | Gc.finalise drop_continuation r; r 23 | 24 | let resume : ('a, 'b) resumption -> 'a -> 'b 25 | = fun r v -> continue (clone_continuation r) v 26 | 27 | let abort : ('a, 'b) resumption -> exn -> 'b 28 | = fun r exn -> discontinue (clone_continuation r) exn 29 | 30 | let abort_with_backtrace : ('a, 'b) resumption -> exn -> 31 | Printexc.raw_backtrace -> 'b 32 | = fun r exn bt -> 33 | discontinue_with_backtrace (clone_continuation r) exn bt 34 | end 35 | 36 | 37 | module Shallow = struct open Effect.Shallow 38 | 39 | type ('a, 'b) resumption = ('a, 'b) continuation 40 | 41 | (* Primitives *) 42 | external clone_continuation : ('a, 'b) continuation -> ('a, 'b) continuation 43 | = "multicont_clone_continuation" 44 | external drop_continuation : ('a, 'b) continuation -> unit 45 | = "multicont_drop_continuation" 46 | external promote : ('a, 'b) continuation -> ('a, 'b) resumption 47 | = "multicont_promote" 48 | 49 | let promote : ('a, 'b) continuation -> ('a, 'b) resumption 50 | = fun k -> 51 | let r = promote k in 52 | Gc.finalise drop_continuation r; r 53 | 54 | let resume_with : ('c, 'a) resumption -> 'c -> ('a, 'b) handler -> 'b 55 | = fun r v h -> continue_with (clone_continuation r) v h 56 | 57 | let abort_with : ('c, 'a) resumption -> exn -> ('a, 'b) handler -> 'b 58 | = fun r exn h -> discontinue_with (clone_continuation r) exn h 59 | 60 | let abort_with_backtrace : ('c, 'a) resumption -> exn -> 61 | Printexc.raw_backtrace -> ('a, 'b) handler -> 'b 62 | = fun r exn bt h -> 63 | discontinue_with_backtrace (clone_continuation r) exn bt h 64 | end 65 | -------------------------------------------------------------------------------- /lib/multicont.mli: -------------------------------------------------------------------------------- 1 | (** This module provides multi-shot semantics on top of OCaml's 2 | regular linear continuations. *) 3 | 4 | module Deep: sig 5 | open Effect.Deep 6 | 7 | type ('a, 'b) resumption 8 | (** a [resumption] is a managed variation of 9 | [Effect.Deep.continuation] that can be used multiple times. *) 10 | 11 | val promote : ('a, 'b) continuation -> ('a, 'b) resumption 12 | (** [promote k] converts a regular linear deep continuation to a 13 | multi-shot deep resumption. This function fully consumes the 14 | supplied continuation [k]. *) 15 | 16 | val resume : ('a, 'b) resumption -> 'a -> 'b 17 | (** [resume r v] reinstates the context captured by the multi-shot 18 | deep resumption [r] with value [v]. *) 19 | 20 | val abort : ('a, 'b) resumption -> exn -> 'b 21 | (** [abort r e] injects the exception [e] into the context captured 22 | by the multi-shot deep resumption [r]. *) 23 | 24 | val abort_with_backtrace : ('a, 'b) resumption -> exn -> 25 | Printexc.raw_backtrace -> 'b 26 | (** [abort_with_backtrace k e bt] aborts the deep multi-shot 27 | resumption [r] by raising the exception [e] in [k] using [bt] as 28 | the origin for the exception. *) 29 | 30 | (* Primitives *) 31 | val clone_continuation : ('a, 'b) continuation -> ('a, 'b) continuation 32 | (** [clone_continuation k] clones the linear deep continuation [k]. The 33 | supplied continuation is *not* consumed. *) 34 | 35 | val drop_continuation : ('a, 'b) continuation -> unit 36 | (** [drop_continuation k] deallocates the memory occupied by the 37 | continuation [k]. Note, however, that this function does not clean 38 | up acquired resources captured by the continuation. In order to 39 | delete the continuation and free up the resources the programmer 40 | should instead use `discontinue` from the [Effect.Deep] module. *) 41 | end 42 | 43 | module Shallow: sig 44 | open Effect.Shallow 45 | 46 | type ('a, 'b) resumption 47 | (** a [resumption] is a managed variation of 48 | [Effect.Shallow.continuation] that can be used multiple times. *) 49 | 50 | val promote : ('a, 'b) continuation -> ('a, 'b) resumption 51 | (** [promote k] converts a regular linear shallow continuation to a 52 | multi-shot shallow resumption. This function fully consumes the 53 | supplied continuation [k]. *) 54 | 55 | val resume_with : ('c, 'a) resumption -> 'c -> ('a, 'b) handler -> 'b 56 | (** [resume r v h] reinstates the context captured by the multi-shot 57 | shallow resumption [r] with value [v] under the handler [h]. *) 58 | 59 | val abort_with : ('c, 'a) resumption -> exn -> ('a, 'b) handler -> 'b 60 | (** [abort r e h] injects the exception [e] into the context captured 61 | by the multi-shot shallow resumption [r] under the handler [h]. *) 62 | 63 | val abort_with_backtrace : ('c, 'a) resumption -> exn -> 64 | Printexc.raw_backtrace -> ('a, 'b) handler -> 'b 65 | (** [abort_with_backtrace k e bt] aborts the shallow multi-shot 66 | resumption [r] by raising the exception [e] in [k] using [bt] as 67 | the origin for the exception. *) 68 | 69 | (* Primitives *) 70 | val clone_continuation : ('a, 'b) continuation -> ('a, 'b) continuation 71 | (** [clone_continuation k] clones the linear shallow continuation [k]. The 72 | supplied continuation is *not* consumed. *) 73 | 74 | val drop_continuation : ('a, 'b) continuation -> unit 75 | (** [drop_continuation k] deallocates the memory occupied by the 76 | continuation [k]. Note, however, that this function does not clean 77 | up acquired resources captured by the continuation. In order to 78 | delete the continuation and free up the resources the programmer 79 | should instead use [discontinue_with] from the [Effect.Shallow] module. *) 80 | end 81 | -------------------------------------------------------------------------------- /lib/multicont_stubs.c: -------------------------------------------------------------------------------- 1 | #define CAML_INTERNALS 2 | 3 | #include // provides basic CAML macros and type definitions 4 | #include // provides [caml_raise_out_of_memory] 5 | #include // provides [caml_alloc_1] 6 | #include // provides Stack_* macros, [struct stack_info] 7 | #include // provides CAMLparam* and CAMLreturn* macros 8 | #include // provides [CAMLnoalloc] macro 9 | #include // provides OCaml versioning macros 10 | 11 | #include 12 | 13 | #ifdef NATIVE_CODE 14 | #include 15 | #include 16 | #endif 17 | 18 | #include "fiber_primitives.h" // provides [MULTICONT_NEXT_FIBER_ID] 19 | // generator. 20 | 21 | // NOTE(dhil): The representation of continuations was changed in 22 | // OCaml 5.2. In OCaml 5.2+ a continuation is a pair of stack segments 23 | // (first_segment, last_segment) which together forms the complete 24 | // stack chain from effect invocation site to handle site. Here, 25 | // first_segment is the segment where the effect was initially 26 | // performed and last_segment is segment that had the appropriate 27 | // handler installed. 28 | // 29 | // Prior to OCaml 5.2 the continuation was simply a pointer to 30 | // previous stack segment that performed or reperformed the effect. 31 | #if OCAML_VERSION_MAJOR >= 5 && OCAML_VERSION_MINOR > 1 32 | #define MULTICONT52 1 33 | #else 34 | #define MULTICONT52 0 35 | #endif 36 | 37 | CAMLprim value multicont_promote(value k) { 38 | CAMLparam1(k); 39 | CAMLlocal1(r); 40 | 41 | value null_stk = Val_ptr(NULL); 42 | 43 | #if MULTICONT52 44 | r = caml_alloc_2(Cont_tag, null_stk, null_stk); 45 | #else 46 | r = caml_alloc_1(Cont_tag, null_stk); 47 | #endif 48 | 49 | // Move the stack from [k] to [r] 50 | { 51 | // Prevent the GC from running between [caml_continuation_use] and 52 | // [caml_continuation_replace] 53 | CAMLnoalloc; 54 | caml_continuation_replace(r, Ptr_val(caml_continuation_use(k))); 55 | #if MULTICONT52 56 | caml_modify(&Field(r, 1), Field(k, 1)); 57 | #endif 58 | } 59 | 60 | CAMLreturn(r); 61 | } 62 | 63 | CAMLprim value multicont_clone_continuation(value k) { 64 | CAMLparam1(k); // input continuation object 65 | CAMLlocal1(kclone); // resulting continuation object clone 66 | 67 | intnat space_used; 68 | value null_stk = Val_ptr(NULL); 69 | 70 | struct stack_info *source, // original stack segment pointed to by [k] 71 | *current, // iterator; points to the current stack segment 72 | *clone, // clone of [current] 73 | *result; // clone of [source] 74 | struct stack_info **link = &result; 75 | #if MULTICONT52 76 | struct stack_info *last_segment; // the last segment of the stack chain 77 | #endif 78 | 79 | // Allocate an OCaml object with the continuation tag 80 | #if MULTICONT52 81 | kclone = caml_alloc_2(Cont_tag, null_stk, null_stk); 82 | #else 83 | kclone = caml_alloc_1(Cont_tag, null_stk); 84 | #endif 85 | { 86 | // Prevent the GC from running between the use of 87 | // [caml_continuation_use] and [caml_continuation_replace] 88 | CAMLnoalloc; 89 | 90 | // Retrieve the stack pointed to by the continuation [k] 91 | source = current = Ptr_val(caml_continuation_use(k)); 92 | 93 | // NOTE: We know now that [current] is non-null, as otherwise 94 | // [caml_continuation_use] would have raised an exception. 95 | // Copy each stack segment in the chain 96 | do { 97 | space_used = Stack_high(current) - (value*)current->sp; 98 | 99 | int64_t fiber_id; 100 | #ifdef UNIQUE_FIBERS 101 | fiber_id = MULTICONT_NEXT_FIBER_ID; 102 | #else 103 | fiber_id = current->id; 104 | #endif 105 | 106 | // Allocate a fresh stack segment the size of [current] 107 | clone = caml_alloc_stack_noexc(Stack_high(current) - Stack_base(current), 108 | Stack_handle_value(current), 109 | Stack_handle_exception(current), 110 | Stack_handle_effect(current), 111 | fiber_id); 112 | // Check whether allocation failed 113 | if (!clone) caml_raise_out_of_memory(); 114 | 115 | // Copy the contents of [current] onto [clone] 116 | memcpy(Stack_high(clone) - space_used, 117 | Stack_high(current) - space_used, 118 | space_used * sizeof(value)); 119 | 120 | #ifdef NATIVE_CODE 121 | // Rewrite exception pointer on the new stack segment 122 | clone->exception_ptr = current->exception_ptr; 123 | caml_rewrite_exception_stack(current, (value**)&clone->exception_ptr, clone); 124 | #endif 125 | 126 | // Set stack pointer on [clone] 127 | clone->sp = Stack_high(clone) - space_used; 128 | 129 | // Prepare to handle the next stack segment 130 | #if MULTICONT52 131 | last_segment = clone; 132 | #endif 133 | *link = clone; 134 | link = &Stack_parent(clone); 135 | current = Stack_parent(current); 136 | } while (current != NULL); 137 | 138 | #if MULTICONT52 139 | caml_modify(&Field(kclone, 1), Val_ptr(last_segment)); 140 | #endif 141 | 142 | // Reattach the [source] stack to [k] (necessary as 143 | // [caml_continuation_use] deattaches it) and attach [result] to 144 | // [kclone] 145 | caml_continuation_replace(k, source); 146 | caml_continuation_replace(kclone, result); 147 | } 148 | 149 | CAMLreturn(kclone); 150 | } 151 | 152 | CAMLprim value multicont_drop_continuation(value k) { 153 | CAMLparam1(k); 154 | struct stack_info *current, 155 | *next = Ptr_val(caml_continuation_use(k)); 156 | while (next != NULL) { 157 | current = next; 158 | next = Stack_parent(current); 159 | caml_free_stack(current); 160 | } 161 | CAMLreturn(Val_unit); 162 | } 163 | 164 | #undef MULTICONT52 165 | -------------------------------------------------------------------------------- /multicont.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Multi-shot continuations in OCaml" 4 | description: 5 | "This library provides facilities for programming with multi-shot continuations in OCaml" 6 | maintainer: ["Daniel Hillerström"] 7 | authors: ["Daniel Hillerström"] 8 | license: "MIT" 9 | tags: ["multi-shot continuations" "effect handlers"] 10 | homepage: "https://github.com/dhil/ocaml-multicont" 11 | bug-reports: "https://github.com/dhil/ocaml-multicont/issues" 12 | depends: [ 13 | "ocaml" {>= "5.0.0"} 14 | "dune" {>= "3.14"} 15 | "dune-configurator" {>= "3.14"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/dhil/ocaml-multicont.git" 33 | -------------------------------------------------------------------------------- /test/async.expected: -------------------------------------------------------------------------------- 1 | starting a 2 | yielding a 3 | starting b 4 | yielding b 5 | ending a with 40 6 | ending b with 2 7 | Sum is 42 8 | -------------------------------------------------------------------------------- /test/choice.expected: -------------------------------------------------------------------------------- 1 | (3, 4, 5) 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (alias runtest) 3 | (targets tests.inc) 4 | (deps (:gen gen/testrules.exe)) 5 | (mode promote) 6 | (action (run %{gen} -ocamlc %{ocamlc} -ocaml_version %{ocaml_version} -output %{targets}))) 7 | 8 | (include tests.inc) 9 | -------------------------------------------------------------------------------- /test/gen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name testrules) 3 | (libraries dune.configurator unix)) 4 | -------------------------------------------------------------------------------- /test/gen/testrules.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let detect_native_compiler ocamlc = 4 | let input_lines ic = 5 | let ans = ref [] in 6 | let rec next_line ic = 7 | ans := input_line ic :: !ans; 8 | next_line ic 9 | in 10 | (try next_line ic with _ -> ()); 11 | !ans 12 | in 13 | try 14 | let ic = Unix.open_process_in (Filename.quote_command ocamlc ["-config"]) in 15 | let lines = input_lines ic in 16 | ignore (Unix.close_process_in ic); 17 | List.exists (fun s -> String.equal s "native_compiler: true") lines 18 | with _ -> false 19 | 20 | let make_diff_stanzas is_version_53 native testname = 21 | let stanzas exe_prefix = 22 | let output legacy = 23 | Printf.sprintf 24 | "(rule\n\ 25 | \ (with-stdout-to %s%s.output\n\ 26 | \ (setenv \"LD_LIBRARY_PATH\" \".\"\n\ 27 | \ (run %s/examples/%s%s.exe))))" 28 | exe_prefix (if legacy then "-legacy" else "") 29 | "%{workspace_root}" (if legacy then "legacy/" else "") exe_prefix 30 | in 31 | let runtest legacy = 32 | Printf.sprintf 33 | "(rule\n\ 34 | \ (alias runtest)\n\ 35 | \ (action (diff %s.expected %s%s.output)))" 36 | testname exe_prefix (if legacy then "-legacy" else "") 37 | in 38 | let _53_tests = 39 | if is_version_53 40 | then [output false; ""; runtest false; ""] 41 | else [] 42 | in 43 | _53_tests @ [output true; ""; runtest true; ""] 44 | in 45 | let bc = stanzas (Printf.sprintf "%s.bc" testname) in 46 | let nc = if native then stanzas testname else [] in 47 | (Printf.sprintf "; %s tests" testname) :: (nc @ bc) 48 | 49 | let write_content filename stanzas = 50 | let stanzas = 51 | List.concat (List.map (String.split_on_char '\n') stanzas) 52 | in 53 | C.Flags.write_lines filename stanzas 54 | 55 | (* Currently only for the test/lib/unique_fibers.ml test *) 56 | let make_nondiff_stanzas native testname : string list = 57 | let stanza exe_prefix = 58 | Printf.sprintf 59 | "(rule\n\ 60 | \ (alias runtest)\n\ 61 | \ (action\n\ 62 | \ (setenv \"TEST_UNIQUE_FIBERS\" \"%s\"\n\ 63 | \ (setenv \"LD_LIBRARY_PATH\" \".\"\n\ 64 | \ (run %s/test/lib/%s.exe)))))" 65 | (match Sys.getenv_opt "UNIQUE_FIBERS" with 66 | | Some "1" -> "true" | _ -> "false") 67 | "%{workspace_root}" exe_prefix 68 | in 69 | let bc = stanza (Printf.sprintf "%s.bc" testname) in 70 | let nc = if native then [stanza testname] else [] in 71 | (Printf.sprintf "; %s tests" testname) :: bc :: "" :: nc 72 | 73 | let _ = 74 | let diff_testnames = 75 | ["async"; "choice"; "generic_count"; "knapsack"; "nqueens"; "return"; "supervised"; "tautology"] 76 | in 77 | let nondiff_testnames = 78 | ["unique_fibers"] 79 | in 80 | let incfile = ref "tests.inc" in 81 | let is_native_available = ref false in 82 | let is_version_53 = ref false in 83 | C.main ~name:"tests" 84 | ~args:[ 85 | "-ocamlc", Arg.String (fun ocamlc -> 86 | is_native_available := detect_native_compiler ocamlc), 87 | "Name of the ocamlc executable"; 88 | "-ocaml_version", Arg.String (fun version -> 89 | is_version_53 := String.length version >= 3 90 | && Char.compare (String.get version 0) '5' >= 0 91 | && Char.compare (String.get version 2) '3' >= 0), 92 | "OCaml version"; 93 | "-output", Arg.String (fun s -> incfile := s), 94 | "Name for the tests sexp output (default tests.inc)" 95 | ] 96 | (fun _ -> 97 | let diff_tests = List.map (make_diff_stanzas !is_version_53 !is_native_available) diff_testnames in 98 | let nondiff_tests = List.map (make_nondiff_stanzas !is_native_available) nondiff_testnames in 99 | write_content !incfile (List.concat [List.concat diff_tests; List.concat nondiff_tests])) 100 | -------------------------------------------------------------------------------- /test/generic_count.expected: -------------------------------------------------------------------------------- 1 | 128 2 | -------------------------------------------------------------------------------- /test/knapsack.expected: -------------------------------------------------------------------------------- 1 | 10 2 | 15 3 | 3 4 | 65 5 | 220 6 | 1458 7 | 7534 8 | -------------------------------------------------------------------------------- /test/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name multicont_testlib) 3 | (modes byte best) 4 | (modules inspect_fiber) 5 | (foreign_stubs 6 | (language c) 7 | (mode byte) 8 | (flags :standard (:include c_byte_flags.sexp)) 9 | (names inspect_fiber_stubs)) 10 | (foreign_stubs 11 | (language c) 12 | (mode native) 13 | (flags :standard (:include c_native_flags.sexp)) 14 | (names inspect_fiber_stubs))) 15 | 16 | (rule 17 | (targets c_byte_flags.sexp c_native_flags.sexp) 18 | (action (run ../../config/configure.exe %{profile}))) 19 | 20 | (executable 21 | (name unique_fibers) 22 | (modes byte_complete native) 23 | (modules unique_fibers) 24 | (libraries multicont multicont_testlib)) 25 | -------------------------------------------------------------------------------- /test/lib/inspect_fiber.ml: -------------------------------------------------------------------------------- 1 | type fiber 2 | external fiber_id : fiber -> Int64.t = "multicont_test_lib_fiber_id" 3 | -------------------------------------------------------------------------------- /test/lib/inspect_fiber_stubs.c: -------------------------------------------------------------------------------- 1 | #define CAML_INTERNALS 2 | 3 | #include // provides Stack_* macros, [struct stack_info] 4 | #include // provides CAMLparam* and CAMLreturn* macros 5 | 6 | CAMLextern value caml_copy_int64 (int64_t); // defined in [ocaml/runtime/ints.c] 7 | 8 | CAMLprim value multicont_test_lib_fiber_id(value fiber) { 9 | CAMLparam1(fiber); 10 | CAMLlocal1(id); 11 | struct stack_info *stack = Ptr_val(Field(fiber, 0)); 12 | id = caml_copy_int64(stack->id); 13 | CAMLreturn(id); 14 | } 15 | -------------------------------------------------------------------------------- /test/lib/unique_fibers.ml: -------------------------------------------------------------------------------- 1 | open Effect.Deep 2 | open Multicont.Deep 3 | 4 | type _ Effect.t += Clone : unit Effect.t 5 | 6 | let test unique_fibers_enabled = 7 | let result = ref [] in 8 | match_with Effect.perform Clone 9 | { retc = (fun _ -> ()) 10 | ; exnc = raise 11 | ; effc = (fun (type a) (eff : a Effect.t) -> 12 | match eff with 13 | | Clone -> Some (fun (k : (a, _) continuation) -> 14 | let open Multicont_testlib.Inspect_fiber in 15 | let k' = clone_continuation k in 16 | let k'' = clone_continuation k' in 17 | (* NOTE(dhil): The fiber and continuation 18 | representation is the same for deep and 19 | shallow continuations. *) 20 | result := [ fiber_id (Obj.magic k) 21 | ; fiber_id (Obj.magic k') 22 | ; fiber_id (Obj.magic k'')]) 23 | | _ -> None ) }; 24 | match !result with 25 | | [original_id; clone_id; clone_clone_id] when unique_fibers_enabled -> 26 | assert (not (Int64.equal original_id clone_id)); 27 | assert (not (Int64.equal clone_id clone_clone_id)) 28 | | [original_id; clone_id; clone_clone_id ] when not unique_fibers_enabled -> 29 | assert (Int64.equal original_id clone_id); 30 | assert (Int64.equal clone_id clone_clone_id) 31 | | _ -> assert false 32 | 33 | let _ = 34 | match Sys.getenv_opt "TEST_UNIQUE_FIBERS" with 35 | | Some "true" -> test true 36 | | _ -> test false 37 | -------------------------------------------------------------------------------- /test/nqueens.expected: -------------------------------------------------------------------------------- 1 | 92 2 | -------------------------------------------------------------------------------- /test/return.expected: -------------------------------------------------------------------------------- 1 | -5040 2 | -5040 3 | -------------------------------------------------------------------------------- /test/supervised.expected: -------------------------------------------------------------------------------- 1 | Parent joining with Child 1 2 | Child 1 failed! 3 | Child 2 failed! 4 | Child 1 failed! 5 | Child 2 failed! 6 | Child 2 failed! 7 | Child 1 succeeded! 8 | Child 1 joining with Child 2 9 | Child 2 succeeded! 10 | Child 2 succeeded! 11 | Child 2 succeeded! 12 | Child 1 joined with Child 2 13 | Parent joined with Child 1 14 | -------------------------------------------------------------------------------- /test/tautology.expected: -------------------------------------------------------------------------------- 1 | true 2 | -------------------------------------------------------------------------------- /test/tests.inc: -------------------------------------------------------------------------------- 1 | ; intentionally left empty --------------------------------------------------------------------------------