├── .github └── workflows │ └── prs.yml ├── .gitignore ├── .travis-ocaml.sh ├── .travis.sh ├── Dockerfile ├── LICENSE ├── README.md └── sources ├── Makefile ├── async_await.ml ├── cooperative.ml ├── echo.ml ├── echo_async.ml ├── echo_unix.ml ├── exceptions.ml ├── fringe.ml ├── gdb.ml ├── generator.ml ├── input_line_eff.ml ├── input_line_eff2.ml ├── input_line_exn.ml ├── input_line_exn2.ml ├── msg_passing.ml ├── solved ├── Makefile ├── async_await.ml ├── deep_generator.ml ├── echo.ml ├── echo_async.ml ├── exceptions.ml ├── fringe.ml ├── generator.ml ├── myfringe.ml └── state2.ml ├── state1.ml └── state2.ml /.github/workflows/prs.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | matrix: 13 | os: 14 | - ubuntu-latest 15 | - macos-latest 16 | ocaml-compiler: 17 | - 5.2 18 | 19 | runs-on: ${{ matrix.os }} 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v4 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 26 | uses: ocaml/setup-ocaml@v3 27 | with: 28 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 29 | opam-repositories: | 30 | default: https://github.com/ocaml/opam-repository.git 31 | cache-prefix: ${{ steps.multicore_hash.outputs.commit }} 32 | opam-depext: false 33 | 34 | - run: opam install ocamlbuild ocamlfind 35 | 36 | - run: | 37 | cd sources 38 | opam exec -- make all 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # vim 23 | *~ 24 | -------------------------------------------------------------------------------- /.travis-ocaml.sh: -------------------------------------------------------------------------------- 1 | ## basic OCaml and opam installation 2 | 3 | full_apt_version () { 4 | package=$1 5 | version=$2 6 | case "${version}" in 7 | latest) echo -n "${package}" ;; 8 | *) echo -n "${package}=" 9 | apt-cache show "$package" \ 10 | | sed -n "s/^Version: \(${version}\)/\1/p" \ 11 | | head -1 12 | esac 13 | } 14 | 15 | set -uex 16 | 17 | if [ "${INSTALL_LOCAL+x}" = x ] ; then 18 | if [ "$TRAVIS_OS_NAME" = osx ] ; then 19 | echo INSTALL_LOCAL not permitted for macOS targets 20 | exit 1 21 | fi 22 | 23 | if [ "${OPAM_SWITCH:=system}" != system ] ; then 24 | echo "INSTALL_LOCAL requires OPAM_SWITCH=system (or unset/null)" 25 | exit 1 26 | fi 27 | fi 28 | 29 | # the ocaml version to test 30 | OCAML_VERSION=${OCAML_VERSION:-latest} 31 | OPAM_VERSION=${OPAM_VERSION:-1.2.2} 32 | OPAM_INIT=${OPAM_INIT:-true} 33 | 34 | # the base opam repository to use for bootstrapping and catch-all namespace 35 | BASE_REMOTE=${BASE_REMOTE:-git://github.com/ocaml/opam-repository} 36 | 37 | # whether we need a new gcc and binutils 38 | UPDATE_GCC_BINUTILS=${UPDATE_GCC_BINUTILS:-"0"} 39 | 40 | # Install Trusty remotes 41 | UBUNTU_TRUSTY=${UBUNTU_TRUSTY:-"0"} 42 | 43 | # Install XQuartz on OSX 44 | INSTALL_XQUARTZ=${INSTALL_XQUARTZ:-"true"} 45 | 46 | install_on_linux () { 47 | case "$OCAML_VERSION,$OPAM_VERSION" in 48 | 4.02.2+multicore,1.2.2) 49 | OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.02.2+multicore 50 | ppa=avsm/ocaml42+opam12 ;; 51 | 4.04.2+multicore,1.2.2) 52 | OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.04.2+multicore 53 | ppa=avsm/ocaml42+opam12 ;; 54 | 4.06.1+multicore,1.2.2) 55 | OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.06.1+multicore 56 | ppa=avsm/ocaml42+opam12 ;; 57 | *) echo "Unknown OCAML_VERSION=$OCAML_VERSION OPAM_VERSION=$OPAM_VERSION" 58 | echo "(An unset OCAML_VERSION used to default to \"latest\", but you must now specify it." 59 | echo "Try something like \"OCAML_VERSION=3.12\", \"OCAML_VERSION=4.06\", or see README-travis.md at https://github.com/ocaml/ocaml-ci-scripts )" 60 | exit 1 ;; 61 | esac 62 | 63 | sudo add-apt-repository --yes ppa:${ppa} 64 | sudo apt-get update -qq 65 | if [ "${INSTALL_LOCAL:=0}" = 0 ] ; then 66 | sudo apt-get install -y \ 67 | "$(full_apt_version ocaml $OCAML_VERSION)" \ 68 | "$(full_apt_version ocaml-base $OCAML_VERSION)" \ 69 | "$(full_apt_version ocaml-native-compilers $OCAML_VERSION)" \ 70 | "$(full_apt_version ocaml-compiler-libs $OCAML_VERSION)" \ 71 | "$(full_apt_version ocaml-interp $OCAML_VERSION)" \ 72 | "$(full_apt_version ocaml-base-nox $OCAML_VERSION)" \ 73 | "$(full_apt_version ocaml-nox $OCAML_VERSION)" \ 74 | "$(full_apt_version camlp4 $OCAML_VERSION)" \ 75 | "$(full_apt_version camlp4-extra $OCAML_VERSION)" \ 76 | opam 77 | else 78 | sudo apt-get install -y opam 79 | fi 80 | 81 | TRUSTY="deb mirror://mirrors.ubuntu.com/mirrors.txt trusty main restricted universe" 82 | 83 | if [ "$UPDATE_GCC_BINUTILS" != "0" ] ; then 84 | echo "installing a recent gcc and binutils (mainly to get mirage-entropy-xen working!)" 85 | sudo add-apt-repository "${TRUSTY}" 86 | sudo add-apt-repository --yes ppa:ubuntu-toolchain-r/test 87 | sudo apt-get -qq update 88 | sudo apt-get install -y gcc-4.8 89 | sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-4.8 90 90 | sudo add-apt-repository -r "${TRUSTY}" 91 | fi 92 | 93 | if [ "$UBUNTU_TRUSTY" != "0" ] ; then 94 | echo "Adding Ubuntu Trusty mirrors" 95 | sudo add-apt-repository "${TRUSTY}" 96 | sudo apt-get -qq update 97 | fi 98 | 99 | if [ "$INSTALL_LOCAL" != 0 ] ; then 100 | echo -en "travis_fold:start:build.ocaml\r" 101 | echo "Building a local OCaml; this may take a few minutes..." 102 | wget "http://caml.inria.fr/pub/distrib/ocaml-${OCAML_FULL_VERSION%.*}/ocaml-$OCAML_FULL_VERSION.tar.gz" 103 | tar -xzf "ocaml-$OCAML_FULL_VERSION.tar.gz" 104 | cd "ocaml-$OCAML_FULL_VERSION" 105 | ./configure -prefix /usr/local ${OCAML_CONFIGURE_ARGS:=--with-debug-runtime} 106 | make world.opt 107 | sudo make install 108 | cd .. 109 | echo -en "travis_fold:end:build.ocaml\r" 110 | fi 111 | } 112 | 113 | install_on_osx () { 114 | case $INSTALL_XQUARTZ in 115 | true) 116 | curl -OL "http://xquartz.macosforge.org/downloads/SL/XQuartz-2.7.6.dmg" 117 | sudo hdiutil attach XQuartz-2.7.6.dmg 118 | sudo installer -verbose -pkg /Volumes/XQuartz-2.7.6/XQuartz.pkg -target / 119 | ;; 120 | esac 121 | brew update &> /dev/null 122 | case "$OCAML_VERSION,$OPAM_VERSION" in 123 | 4.02.2+multicore,1.2.2) OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.02.2+multicore 124 | brew unlink python; brew install opam ;; 125 | 4.04.2+multicore,1.2.2) OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.04.2+multicore 126 | brew unlink python; brew install opam ;; 127 | 4.06.1+multicore,1.2.2) OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.06.1+multicore 128 | brew unlink python; brew install opam ;; 129 | *) echo "Unknown OCAML_VERSION=$OCAML_VERSION OPAM_VERSION=$OPAM_VERSION" 130 | exit 1 ;; 131 | esac 132 | } 133 | 134 | case $TRAVIS_OS_NAME in 135 | osx) install_on_osx ;; 136 | linux) install_on_linux ;; 137 | esac 138 | 139 | OPAM_SWITCH=${OPAM_SWITCH:-${OCAML_VERSION}.3} 140 | 141 | export OPAMYES=1 142 | 143 | case $OPAM_INIT in 144 | true) 145 | opam init -a "$BASE_REMOTE" --comp="$OPAM_SWITCH" 146 | opam remote add multicore https://github.com/ocamllabs/multicore-opam.git 147 | opam switch $OCAML_FULL_VERSION 148 | eval $(opam config env) 149 | ;; 150 | esac 151 | 152 | echo OCAML_VERSION=$OCAML_VERSION > .travis-ocaml.env 153 | echo OPAM_SWITCH=$OPAM_SWITCH >> .travis-ocaml.env 154 | 155 | ocaml -version 156 | opam --version 157 | opam --git-version 158 | -------------------------------------------------------------------------------- /.travis.sh: -------------------------------------------------------------------------------- 1 | set -uex 2 | 3 | sh .travis-ocaml.sh 4 | export OPAMYES=1 5 | eval $(opam config env) 6 | 7 | opam install ocamlfind ocamlbuild 8 | make -C sources 9 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:ubuntu-lts-ocaml-5.0 2 | 3 | RUN opam install ocamlbuild ocamlfind 4 | 5 | COPY sources/Makefile ./sources/ 6 | COPY sources/*.ml ./sources/ 7 | 8 | COPY sources/solved/Makefile ./sources/solved/ 9 | COPY sources/solved/*.ml ./sources/solved/ 10 | 11 | WORKDIR sources 12 | 13 | RUN sudo bash -c "eval $(opam env) make all" 14 | 15 | WORKDIR solved 16 | 17 | RUN sudo bash -c "eval $(opam env) make all" 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Concurrent Programming with Effect Handlers 2 | 3 | [![Build Status](https://github.com/ocamllabs/ocaml-effects-tutorial/actions/workflows/prs.yml/badge.svg)](https://github.com/ocamllabs/ocaml-effects-tutorial/actions/workflows/prs.yml) 4 | 5 | Originally written as materials for the [CUFP 17 tutorial](http://cufp.org/2017/c3-daniel-hillerstrom-kc-concurrent-programming-with-effect-handlers.html). 6 | 7 | ## Setting up 8 | 9 | ### Install a compatible OCaml compiler 10 | 11 | Up to date instructions can be found at https://github.com/ocaml-multicore/awesome-multicore-ocaml#installation 12 | 13 | ### Install required tools 14 | 15 | ```sh-session 16 | $ opam install ocamlbuild ocamlfind 17 | ``` 18 | 19 | 20 | ## Outline 21 | 22 | The tutorial is structured as follows: 23 | 24 | 1. [Algebraic Effects and Handlers.](#1-algebraic-effects-and-handlers) 25 | 1.1. [Recovering from errors](#11-recovering-from-errors) 26 | 1.2. [Basics](#12-basics) 27 | 2. [Shallow vs Deep Handlers.](#2-shallow-vs-deep-handlers) 28 | 3. [Delimited Continuations: A deep dive.](#3-delimited-continuations-a-deep-dive) 29 | 3.1. [Examining effect handlers through GDB](#31-examining-effect-handlers-through-gdb) 30 | 4. [Generators & Streams.](#4-generators--streams) 31 | 4.1. [Message passing](#41-message-passing) 32 | 4.2. [Generators from iterators](#42-generators-from-iterators) 33 | 4.3. [Using the generator](#43-using-the-generator) 34 | 4.4. [Streams](#44-streams) 35 | 5. [Cooperative Concurrency.](#5-cooperative-concurrency) 36 | 5.1. [Coroutines](#51-coroutines) 37 | 5.2. [Async/Await](#52-asyncawait) 38 | 6. [Asynchronous I/O.](#6-asynchronous-io) 39 | 6.1. [Blocking echo server](#61-blocking-echo-server) 40 | 6.2. [Asynchronous echo server](#62-asynchronous-echo-server) 41 | 7. [Conclusion.](#7-conclusion) 42 | 43 | The tutorial also includes the following exercises: 44 | 45 | 1. [Implement exceptions from effects ★☆☆☆☆](#exercise-1-implement-exceptions-from-effects-) 46 | 2. [Implement state put and history ★★☆☆☆](#exercise-2-implement-state-put-and-history-) 47 | 3. [Derive generator for an arbitrary iterator ★★★★☆](#exercise-3-derive-generator-for-an-arbitrary-iterator-) 48 | 4. [Same fringe problem ★☆☆☆☆](#exercise-4-same-fringe-problem-) 49 | 5. [Implement async/await functionality ★★★☆☆](#exercise-5-implement-asyncawait-functionality-) 50 | 6. [Implement asynchronous accept and send ★☆☆☆☆](#exercise-6-implement-asynchronous-accept-and-send-) 51 | 52 | ## 1. Algebraic Effects and Handlers 53 | 54 | An algebraic effect handler is a programming abstraction for manipulating 55 | control-flow in a first-class fashion. They generalise common abstractions such 56 | as exceptions, generators, asynchronous I/O, or concurrency, as well as other 57 | seemingly esoteric programming abstractions such as transactional memory and 58 | probabilistic computations. 59 | 60 | Operationally, effect handlers offer a form of first-class, restartable exception 61 | mechanism. In this tutorial, we shall introduce gently algebraic effect and 62 | handlers with gentle examples and then continue on to more involved examples. 63 | 64 | ### 1.1. Recovering from errors 65 | 66 | Lets start with an example. Consider a program which reads a list of numbers 67 | from standard input and prints the sum of the numbers: 68 | 69 | ```ocaml 70 | let rec sum_up acc = 71 | let l = input_line stdin in 72 | acc := !acc + int_of_string l; 73 | sum_up acc 74 | 75 | let _ = 76 | let r = ref 0 in 77 | try sum_up r with 78 | | End_of_file -> Printf.printf "Sum is %d\n" !r 79 | ``` 80 | 81 | The above program is available in `sources/input_line_exn.ml`. You can run this 82 | program as: 83 | 84 | ```sh-session 85 | $ cd sources 86 | $ ocaml input_line_exn.ml 87 | 10 88 | 20 89 | (* ctrl+d *) 90 | Sum is 30 91 | ``` 92 | 93 | The `input_line` function returns a string for the input line and raises 94 | `End_of_file` if it encounters end of file character. We use `int_of_string` to 95 | convert the input string to a number. This works as long as the input is a 96 | number. If not, `int_of_string` raises `Failure` and this program blows up: 97 | 98 | ```sh-session 99 | $ ocaml input_line_exn.ml 100 | 10 101 | 20 102 | MMXVII 103 | Fatal error: exception Failure("int_of_string") 104 | ``` 105 | 106 | We could print a better error message (`sources/input_line_exn2.ml`): 107 | 108 | ```ocaml 109 | exception Conversion_failure of string 110 | 111 | let int_of_string l = 112 | try int_of_string l with 113 | | Failure _ -> raise (Conversion_failure l) 114 | 115 | let rec sum_up acc = 116 | let l = input_line stdin in 117 | acc := !acc + int_of_string l; 118 | sum_up acc 119 | 120 | let _ = 121 | let r = ref 0 in 122 | try sum_up r with 123 | | End_of_file -> Printf.printf "Sum is %d\n" !r 124 | | Conversion_failure s -> 125 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s 126 | ``` 127 | 128 | The program now prints a friendlier error message: 129 | 130 | ```sh-session 131 | $ ocaml input_line_exn2.ml 132 | 10 133 | 20 134 | MMXVII 135 | Conversion failure "MMXVII" 136 | ``` 137 | 138 | and, unfortunately, the program *terminates*. We really wish the program kept 139 | going: 140 | 141 | ```ocaml 142 | let _ = 143 | let r = ref 0 in 144 | try sum_up r with 145 | | End_of_file -> Printf.printf "Sum is %d\n" !r 146 | | Conversion_failure s -> 147 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s 148 | (* Wish it kept going: continue with 0 *) 149 | ``` 150 | 151 | We could change the code, but if `sum_up` function was from a third-party 152 | library, changing code is generally not an acceptable option. The issue here is 153 | that the library determines whether the error is fatal or not. What we would 154 | like is for **the client of a library determining whether an error is fatal or 155 | not**. 156 | 157 | ### 1.2. Basics 158 | 159 | Algebraic effect handlers allow you to recover from errors. The following code 160 | is available in `sources/input_line_eff.ml` 161 | 162 | ```ocaml 163 | open Effect 164 | open Effect.Deep 165 | 166 | type _ Effect.t += Conversion_failure : string -> int Effect.t 167 | 168 | let int_of_string l = 169 | try int_of_string l with 170 | | Failure _ -> perform (Conversion_failure l) 171 | 172 | let rec sum_up acc = 173 | let l = input_line stdin in 174 | acc := !acc + int_of_string l; 175 | sum_up acc 176 | 177 | let _ = 178 | Printf.printf "Starting up. Please input:\n%!"; 179 | let r = ref 0 in 180 | match_with sum_up r 181 | { effc = (fun (type c) (eff: c Effect.t) -> 182 | match eff with 183 | | Conversion_failure s -> Some (fun (k: (c,_) continuation) -> 184 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s; 185 | continue k 0) 186 | | _ -> None 187 | ); 188 | exnc = (function 189 | | End_of_file -> Printf.printf "Sum is %d\n" !r 190 | | e -> raise e 191 | ); 192 | (* Shouldn't reach here, means sum_up returned a value *) 193 | retc = fun _ -> failwith "Impossible, sum_up shouldn't return" 194 | } 195 | ``` 196 | 197 | First, let’s run this program: 198 | 199 | ```sh-session 200 | $ ocaml input_line_eff.ml 201 | 10 202 | 20 203 | MMXVII 204 | Conversion failure "MMXVII" 205 | 30 206 | (* ctrl+d *) 207 | Sum is 60 208 | ``` 209 | 210 | We've recovered from the conversion error and kept going. Algebraic effects and 211 | handlers are similar to exceptions in that we can declare new effects: 212 | 213 | ```ocaml 214 | type _ Effect.t += Conversion_failure : string -> int Effect.t 215 | (* c.f. [exception Conversion_failure of string] *) 216 | ``` 217 | 218 | Effects are declared by adding constructors to an [extensible variant type](https://v2.ocaml.org/manual/extensiblevariants.html) 219 | defined in the `Effect` module. 220 | 221 | Unlike exceptions, performing an effect returns a value. The declaration here 222 | says that `Conversion_failure` is an algebraic effect that takes a string 223 | parameter, which when performed, returns an integer. 224 | 225 | Just like exceptions, effects are values. The type of `Conversion_failure 226 | "MMXVII"` is `int Effect.t`, where `int` is the result of performing the effect. 227 | We perform the effect with `perform : 'a Effect.t -> 'a` primitive (c.f. `raise : 228 | exn -> 'a (* bottom *)`). 229 | 230 | Effect handlers are defined in the modules `Effect.Deep` and `Effect.Shallow`. 231 | We'll discuss the differences between the two later. 232 | 233 | ```ocaml 234 | module Deep : sig 235 | (** Some contents omitted *) 236 | 237 | type ('a,'b) handler = 238 | { retc: 'a -> 'b; 239 | exnc: exn -> 'b; 240 | effc: 'c.'c t -> (('c,'b) continuation -> 'b) option } 241 | (** [('a,'b) handler] is a handler record with three fields -- [retc] 242 | is the value handler, [exnc] handles exceptions, and [effc] handles the 243 | effects performed by the computation enclosed by the handler. *) 244 | 245 | val match_with: ('c -> 'a) -> 'c -> ('a,'b) handler -> 'b 246 | (** [match_with f v h] runs the computation [f v] in the handler [h]. *) 247 | 248 | type 'a effect_handler = 249 | { effc: 'b. 'b t -> (('b, 'a) continuation -> 'a) option } 250 | (** ['a effect_handler] is a deep handler with an identity value handler 251 | [fun x -> x] and an exception handler that raises any exception 252 | [fun e -> raise e]. *) 253 | 254 | val try_with: ('b -> 'a) -> 'b -> 'a effect_handler -> 'a 255 | (** [try_with f v h] runs the computation [f v] under the handler [h]. *) 256 | end 257 | 258 | module Shallow : sig 259 | (** Some contents omitted *) 260 | 261 | type ('a,'b) handler = 262 | { retc: 'a -> 'b; 263 | exnc: exn -> 'b; 264 | effc: 'c.'c t -> (('c,'a) continuation -> 'b) option } 265 | (** [('a,'b) handler] is a handler record with three fields -- [retc] 266 | is the value handler, [exnc] handles exceptions, and [effc] handles the 267 | effects performed by the computation enclosed by the handler. *) 268 | 269 | val continue_with : ('c,'a) continuation -> 'c -> ('a,'b) handler -> 'b 270 | (** [continue_with k v h] resumes the continuation [k] with value [v] with 271 | the handler [h]. 272 | @raise Continuation_already_resumed if the continuation has already been 273 | resumed. 274 | *) 275 | end 276 | ``` 277 | 278 | The handlers are records with three fields and are called in the context of `match_with`, `try_with`, or `continue_with`: 279 | 280 | `retc` is the function that is called when the computation returns a value - 281 | i.e. no effects or exceptions were performed/raised in the computation. The 282 | function has one parameter: the value of the computation 283 | 284 | `exnc` is called when the computation throws an exception. It takes the exception as a parameter. 285 | 286 | `effc` is the function that handles the effects. It has type `'c. 'c Effect.t -> ('c, 'a) continuation -> 'b) option` 287 | 288 | Effects are strongly typed, but the handler function can handle multiple 289 | effects and has to be generic over every possible type (which is potentially 290 | all of them since the effects variant can always be extended further), hence 291 | the `'c` existential type. `effc` returns an `option` where a None value means 292 | ignore the effect (and crash the program if not handled somewhere else). A Some 293 | value holds a function that takes a parameter commonly called `k` 294 | 295 | ```ocaml 296 | { effc = (fun (type c) (eff: c Effect.t) -> 297 | match eff with 298 | | Conversion_failure s -> Some (fun (k: (c,_) continuation) -> 299 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s; 300 | continue k 0) 301 | | _ -> None 302 | ) 303 | } 304 | ``` 305 | 306 | We need to declare a [locally abstract type](https://v2.ocaml.org/manual/locallyabstract.html) `c` in order to 307 | tell the compiler that `eff` and `k` are constrained on the same type. 308 | 309 | The parameter `k`, is the *delimited continuation* 310 | between the point of performing the effect and the effect handler. The delimited 311 | continuation is like a dynamically defined function, that can be called and 312 | returns a value. The type of `k` in this case is `(int, int) continuation`, 313 | which says that the continuation expects an integer to continue (the first type 314 | parameter), and returns with an integer (the second type parameter). 315 | 316 | The delimited continuation is resumed with `Effect.Deep`'s `continue : ('a,'b) continuation -> 317 | 'a -> 'b`. In this example, `continue k 0` resumes the continuation 318 | with `0`, and the corresponding `perform (Conversion_failure l)` returns with 319 | `0`. 320 | 321 | If we do want to consider the error to be fatal (`sources/input_line_eff2.ml`), 322 | then we can `discontinue : ('a,'b) continuation -> exn -> 'b` the continuation 323 | so that it raises an exception at the perform point. 324 | 325 | ```ocaml 326 | match_with sum_up r 327 | { effc = (fun (type a) (e: a t) -> 328 | match e with 329 | | Conversion_failure s -> Some (fun (k: (a,_) continuation) -> 330 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s; 331 | discontinue k (Failure "int_of_string")) 332 | | _ -> None 333 | ); 334 | exnc = (function 335 | | End_of_file -> Printf.printf "Sum is %d\n" !r 336 | | e -> raise e 337 | ); 338 | (* Shouldn't reach here, means sum_up returned a value *) 339 | retc = fun v -> v 340 | } 341 | ``` 342 | 343 | Now, 344 | 345 | ```sh-session 346 | $ ocaml input_line_eff2.ml 347 | 10 348 | 20 349 | MMXVII 350 | Conversion failure "MMXVII" 351 | Fatal error: exception Failure("int_of_string") 352 | ``` 353 | 354 | #### 1.2.1. Effects are unchecked 355 | 356 | Unlike [Eff](http://www.eff-lang.org/), 357 | [Koka](https://github.com/koka-lang/koka), 358 | [Links](https://github.com/links-lang/links), and other languages that 359 | support effect handlers, effects in Multicore OCaml are unchecked 360 | currently. A program that does not handle a performed effect fails 361 | with a runtime error. 362 | 363 | Let's fire up the OCaml top-level: 364 | 365 | ```ocaml 366 | $ ocaml 367 | OCaml version 5.0.0~beta1 368 | 369 | # open Effect;; 370 | # type _ Effect.t += E : unit Effect.t;; 371 | type _ Stdlib.Effect.t += E : unit Effect.t 372 | # let f () = perform E;; 373 | val f : unit -> unit = 374 | # f ();; 375 | Exception: Stdlib.Effect.Unhandled(E) 376 | # open Effect.Deep;; 377 | # try_with f () {effc = (fun (type c) (eff: c Effect.t) -> 378 | match eff with 379 | | E -> Some (fun (k: (c,_) continuation) -> continue k ()) 380 | | _ -> None 381 | )};; 382 | - : unit = () 383 | ``` 384 | 385 | ### Exercise 1: Implement exceptions from effects ★☆☆☆☆ 386 | 387 | As mentioned before, effects generalise exceptions. Exceptions handlers are 388 | effect handlers that ignore the continuation. Your task is to implement 389 | exceptions in terms of effects. The source file is `sources/exceptions.ml`. 390 | 391 | ## 2. Shallow vs Deep Handlers 392 | 393 | The OCaml standard library provides two different modules for handling effects: `Effect.Deep` and `Effect.Shallow`. When a deep handler returns a continuation, the continuation also includes the handler. This means that, when the continuation is resumed, the effect handler is automatically re-installed, and will handle the effect(s) that the computation may perform in the future. 394 | 395 | Shallow handlers on the other hand, allow us to change the handlers every time an effect is performed. Let's use them to implement state without refs. The implementation is available in `sources/state1.ml`. 396 | 397 | ```ocaml 398 | open Printf 399 | open Effect 400 | open Effect.Shallow 401 | 402 | module type STATE = sig 403 | type t 404 | val get : unit -> t 405 | val run : (unit -> unit) -> init:t -> unit 406 | end 407 | 408 | module State (S : sig type t end) : STATE with type t = S.t = struct 409 | 410 | type t = S.t 411 | 412 | type _ Effect.t += Get : t Effect.t 413 | 414 | let get () = perform Get 415 | 416 | let run f ~init = 417 | let rec loop : type a r. t -> (a, r) continuation -> a -> r = 418 | fun state k x -> 419 | continue_with k x 420 | { retc = (fun result -> result); 421 | exnc = (fun e -> raise e); 422 | effc = (fun (type b) (eff: b Effect.t) -> 423 | match eff with 424 | | Get -> Some (fun (k: (b,r) continuation) -> 425 | loop state k state) 426 | | _ -> None) 427 | } 428 | in 429 | loop init (fiber f) () 430 | end 431 | ``` 432 | 433 | We use `Effect.Shallow` by wrapping calculations with `continue_with : ('c,'a) continuation -> 'c -> ('a,'b) handler -> 'b` and getting an initial continuation with `val fiber : ('a -> 'b) -> ('a, 'b) continuation` 434 | 435 | In this example, we define an effect `Get` that returns a 436 | value of type `t` when performed. 437 | 438 | ```ocaml 439 | module IS = State (struct type t = int end) 440 | module SS = State (struct type t = string end) 441 | 442 | let foo () : unit = 443 | printf "%d\n" (IS.get ()); 444 | printf "%d\n" (IS.get ()); 445 | printf "%d\n" (IS.get ()); 446 | printf "%s\n" (SS.get ()); 447 | printf "%s\n" (SS.get ()) 448 | 449 | let _ = IS.run (fun () -> SS.run foo "forty two") 42 450 | ``` 451 | 452 | We instantiate two state instances, one with an integer type and 453 | another with string type. Running the program returns: 454 | 455 | ```sh-session 456 | $ ocaml state1.ml 457 | 42 458 | 42 459 | 42 460 | forty two 461 | forty two 462 | ``` 463 | 464 | ### Exercise 2: Implement state put and history ★★☆☆☆ 465 | 466 | Your task it to implement `put : t -> unit` that updates the state and `history 467 | : unit -> t list` that returns the list of values put. Do not use references. 468 | The source file is `sources/state2.ml`. 469 | 470 | ## 3. Delimited Continuations: A deep dive 471 | 472 | **EDITOR'S NOTE: The implementation has changed since this section was written. Results in gdb will differ, but the concepts of the implementation remain mostly the same.** 473 | 474 | Algebraic effect handlers in Multicore OCaml are very efficient due to several 475 | choices we make in their implementation. Understanding the implementation of 476 | delimited continuations also helps to develop a mental model for reasoning about 477 | programs that use effect handlers. 478 | 479 | Delimited continuations that appear in the effect handler are implemented on top 480 | of **fibers** -- small, heap allocated stack chunks, that grow and shrink on 481 | demand. The execution stack is really a stack of fibers. 482 | 483 | ``` 484 | Execution stack 485 | --------------- 486 | 487 | +----+ +----+ 488 | | | | | 489 | | f1 |<--| f2 | 490 | | | | |<- stack_pointer 491 | +----+ +----+ 492 | ``` 493 | 494 | An effect handler instantiates a new fiber for evaluating the expression. 495 | 496 | ``` 497 | try ex with 498 | | effect e k -> .... 499 | 500 | Execution stack 501 | --------------- 502 | 503 | +----+ +----+ +----+ 504 | | | | | | | 505 | | f1 |<--| f2 | <--| ex | 506 | | | | | | |<- stack_pointer 507 | +----+ +----+ +----+ 508 | ``` 509 | 510 | Performing an effect may pop one or more of the fibers based on which handler 511 | handles the effect. The popped sequence of fibers becomes the delimited 512 | continuation. 513 | 514 | ``` 515 | effect E : unit 516 | 517 | try perform E with 518 | | effect E k -> .... 519 | 520 | Execution stack 521 | --------------- 522 | 523 | +----+ +----+ +----+ 524 | | | | |---k (delimited continuation)--->| | 525 | | f1 |<--| f2 | | ex | 526 | | | | |<- stack_pointer | | 527 | +----+ +----+ +----+ 528 | ``` 529 | 530 | When you resume the delimited continuation (with `continue` or `discontinue`) 531 | the fiber sequence that represents the delimited continuation are push on top of 532 | the execution stack. Importantly, our continuations are **one-shot** -- they can 533 | only be resumed once. One shotness means that we never have to copy our 534 | continuations in the case that we may need it for a future invocation. For this 535 | reason, context switching between fibers is really fast and is completely in 536 | userland code and the kernel is not involved. 537 | 538 | ### 3.1 Examining effect handlers through GDB 539 | 540 | The file `sources/gdb.ml`: 541 | 542 | ```ocaml 543 | open Effect 544 | open Effect.Deep 545 | 546 | type _ Effect.t += Peek : int Effect.t 547 | | Poke : unit Effect.t 548 | 549 | let rec a i = perform Peek + Random.int i 550 | let rec b i = a i + Random.int i 551 | let rec c i = b i + Random.int i 552 | 553 | let rec d i = 554 | Random.int i + 555 | try_with c i 556 | { effc = fun (type a) (e: a t) -> 557 | match e with 558 | | Poke -> Some (fun (k: (a,_) continuation) -> continue k ()) 559 | | _ -> None 560 | } 561 | 562 | let rec e i = 563 | Random.int i + 564 | try_with d i 565 | { effc = fun (type a) (e: a t) -> 566 | match e with 567 | | Peek -> Some (fun (k: (a,_) continuation) -> 568 | Printexc.(print_raw_backtrace stdout (Effect.Deep.get_callstack k 100)); 569 | flush stdout; 570 | continue k 42 571 | ) 572 | | _ -> None 573 | } 574 | 575 | let _ = Printf.printf "%d\n" (e 100) 576 | ``` 577 | 578 | illustrates the effect handler stack. Let us compile and examine the file under 579 | GDB: 580 | 581 | ```sh-session 582 | $ make gdb.native 583 | $ gdb ./gdb.native 584 | ``` 585 | 586 | `caml_resume` is the native stub function through which a fiber is attached to 587 | the top of the execution stack and control switches to it. This happens when a 588 | new handler is installed, a continuation is resumed with `continue` or 589 | `discontinue`. Similarly `caml_perform` is the native function which implements 590 | `perform` primitive. We set breakpoints on these two functions to observe the 591 | program as it executes. 592 | 593 | ``` 594 | (gdb) break caml_perform 595 | Breakpoint 1 at 0xaeca8 596 | (gdb) break caml_resume 597 | Breakpoint 2 at 0xaed38 598 | (gdb) r 599 | Starting program: /home/sudha/ocaml/temp/ocaml-effects-tutorial/sources/gdb.native 600 | [Thread debugging using libthread_db enabled] 601 | Using host libthread_db library "/lib/x86_64-linux-gnu/libthread_db.so.1". 602 | 603 | Breakpoint 1, 0x0000555555602ca8 in caml_perform () 604 | (gdb) bt 605 | #0 0x0000555555602ca8 in caml_perform () 606 | #1 0x00005555555a3c08 in camlGdb__b_311 () at gdb.ml:7 607 | #2 0x00005555555a3c69 in camlGdb__c_313 () at gdb.ml:9 608 | #3 609 | #4 0x00005555555a3cd8 in camlGdb__d_315 () at gdb.ml:13 610 | #5 611 | #6 0x00005555555a3db8 in camlGdb__e_329 () at gdb.ml:22 612 | #7 0x00005555555a4034 in camlGdb__entry () at gdb.ml:33 613 | #8 0x00005555555a13ab in caml_program () 614 | #9 615 | #10 0x000055555560252f in caml_startup_common (argv=0x7fffffffda68, pooling=) at runtime/startup_nat.c:129 616 | #11 0x000055555560257b in caml_startup_exn (argv=) at runtime/startup_nat.c:136 617 | #12 caml_startup (argv=) at runtime/startup_nat.c:141 618 | #13 0x00005555555a108c in main (argc=, argv=) at runtime/main.c:37 619 | ``` 620 | 621 | Enter effect handler in `e`. The `` frames correspond to 622 | the transition between C frames to OCaml frames, and between OCaml frames of two 623 | different fibers. These signal handler frames have nothing to do with signals, 624 | but are just a hack to let GDB know that the execution stack is a linked list of 625 | contiguous stack chunks. 626 | 627 | ``` 628 | (gdb) c 629 | Continuing. 630 | Raised by primitive operation at Gdb.a in file "gdb.ml" (inlined), line 7, characters 14-26 631 | Called from Gdb.b in file "gdb.ml", line 8, characters 14-17 632 | Called from Gdb.c in file "gdb.ml", line 9, characters 14-17 633 | Called from Gdb.d in file "gdb.ml", line 13, characters 2-159 634 | 635 | Breakpoint 2, 0x0000555555602d38 in caml_resume () 636 | (gdb) bt 637 | #0 0x0000555555602d38 in caml_resume () 638 | #1 0x00005555555a3db8 in camlGdb__e_329 () at gdb.ml:22 639 | #2 0x00005555555a4034 in camlGdb__entry () at gdb.ml:33 640 | #3 0x00005555555a13ab in caml_program () 641 | #4 642 | #5 0x000055555560252f in caml_startup_common (argv=0x7fffffffda68, pooling=) at runtime/startup_nat.c:129 643 | #6 0x000055555560257b in caml_startup_exn (argv=) at runtime/startup_nat.c:136 644 | #7 caml_startup (argv=) at runtime/startup_nat.c:141 645 | #8 0x00005555555a108c in main (argc=, argv=) at runtime/main.c:37 646 | ``` 647 | 648 | The control switches to the effect handler. In the effect handler for `Peek` in 649 | `e`, we get the backtrace of the continuation and print it. 650 | 651 | This break point corresponds to `continue k 42` in `e`. 652 | 653 | The program terminates normally. 654 | 655 | ``` 656 | Continuing. 657 | 329 658 | [Inferior 1 (process 8464) exited normally] 659 | ``` 660 | 661 | ## 4. Generators & streams. 662 | 663 | So far we've seen examples where the handler discards the continuation 664 | (exceptions) and immediately resumes the computation (state). Since the 665 | continuations are first-class values, we can also keep them around and resume 666 | them later, while executing some other code in the mean time. This functionality 667 | allows us to implement programming idioms such as generators, async/await, etc. 668 | 669 | ### 4.1. Message passing 670 | 671 | Let us being with a simple example that illustrates control switching between 672 | two tasks. The two tasks run **cooperatively**, sending messages 673 | between each other. The source code is available in `sources/msg_passing.ml`. 674 | 675 | We define an effect `Xchg : int -> int` for exchanging integer messages with the 676 | other task. During an exchange, the task sends as well as receives an integer. 677 | 678 | ```ocaml 679 | type _ Effect.t += Xchg : int -> int Effect.t 680 | ``` 681 | 682 | Since the task may suspend, we need a way to represent the status of the task: 683 | 684 | ```ocaml 685 | type status = 686 | Done 687 | | Paused of int * (int, status) continuation 688 | ``` 689 | 690 | The task may either have been `Done` or is `Paused` with the message to send as 691 | well as the continuation, which expects the message to receive. The continuation 692 | results in another status when resumed. We define a `step` function that runs 693 | the function `f` for one step with argument `v`. 694 | 695 | ```ocaml 696 | let step f v () = 697 | match_with f v 698 | { retc = (fun _ -> Done); 699 | exnc = (fun e -> raise e); 700 | effc = (fun (type b) (eff: b t) -> 701 | match eff with 702 | | Xchg m -> Some (fun (k: (b,_) continuation) -> 703 | Paused (m, k)) 704 | | _ -> None 705 | )} 706 | ``` 707 | 708 | The task may perform an `Xchg` in which case we return its `Paused` state. We 709 | now define a `run_both` function for running two tasks concurrently. 710 | 711 | ```ocaml 712 | let rec run_both a b = 713 | match a (), b () with 714 | | Done, Done -> () 715 | | Paused (v1, k1), Paused (v2, k2) -> 716 | run_both (fun () -> continue k1 v2) (fun () -> continue k2 v1) 717 | | _ -> failwith "improper synchronization" 718 | ``` 719 | 720 | Both of the tasks may run to completion, or both may offer to exchange a 721 | message. We consider the other cases to be incorrect programs. In the latter 722 | case, we resume both of the computations with the value from the other. 723 | 724 | ```ocaml 725 | let rec f name = function 726 | | 0 -> () 727 | | n -> 728 | Printf.printf "%s: sending %d\n%!" name n; 729 | let v = perform (Xchg n) in 730 | Printf.printf "%s: received %d\n%!" name v; 731 | f name (n-1) 732 | 733 | let _ = run_both (step (f "a") 3) (step (f "b") 3) 734 | ``` 735 | 736 | Finally, we test the program with a simple test. 737 | 738 | ```sh-session 739 | $ ocaml msg_passing.ml 740 | a: sending 3 741 | b: sending 3 742 | a: received 3 743 | a: sending 2 744 | b: received 3 745 | b: sending 2 746 | a: received 2 747 | a: sending 1 748 | b: received 2 749 | b: sending 1 750 | a: received 1 751 | b: received 1 752 | ``` 753 | 754 | ### 4.2. Generators from iterators 755 | 756 | Iterator is a mechanism to traverse a data structure that retains the control of 757 | the traversal on the library side. An example is `List.iter : ('a -> unit) -> 758 | 'a list -> unit` that applies the given function to every element in the list. 759 | We can provide the following general type for iterators: 760 | 761 | ```ocaml 762 | type ('elt,'container) iterator = ('elt -> unit) -> 'container-> unit 763 | ``` 764 | 765 | where `'elt` is the type of element and `'container` is the type of the container 766 | over which the function iterates. 767 | 768 | On the other hand, a generator is a function where the client of the library has 769 | control over the traversal. We can imagine a `List.generator : 'a list -> (unit 770 | -> 'a option)` that returns a function, which when called returns the next 771 | element in the list. The function returns `None` if there are no more elements. 772 | We can provide the following general type for generator: 773 | 774 | ```ocaml 775 | type 'elt generator = unit -> 'elt option 776 | ``` 777 | 778 | Several languages, including Python and JavaScript, provide generators as a 779 | primitive mechanism, usually through an `yield` primitive. Typically, the 780 | functions that can yield require special annotations (such as `function*`) in 781 | JavaScript, and only yield values to the immediate caller. 782 | 783 | As we've seen in the earlier example, algebraic effect handlers provide a 784 | mechanism to suspend **arbitrary** computation and capture it in the 785 | continuation. Hence, we can derive the generator for an arbitrary iterator 786 | function. 787 | 788 | ### Exercise 3: Derive generator for an arbitrary iterator ★★★★☆ 789 | 790 | Your task is to implement the function `generate : ('elt, 'container) iterator -> 791 | 'elt generator` which derives the generator for any iterator function. 792 | 793 | Hint: Since calling the generator function is an effectful operation, you might 794 | think about saving the state of the traversal in a reference. 795 | 796 | ### 4.3. Using the generator 797 | 798 | #### 4.3.1. Traversal 799 | 800 | You can use the `generator` to traverse a data structure on demand. 801 | 802 | ```ocaml 803 | $ ocaml 804 | # #use "generator.ml";; 805 | # let gl = generate List.iter [1;2;3];; 806 | val gl : int generator = 807 | # gl();; 808 | - : int option = Some 1 809 | # gl();; 810 | - : int option = Some 2 811 | # gl();; 812 | - : int option = Some 3 813 | # gl();; 814 | - : int option = None 815 | # let ga = generate Array.iter [| 1.0; 2.0; 3.0 |];; 816 | # ga();; 817 | - : float option = Some 1. 818 | # ga();; 819 | - : float option = Some 2. 820 | # ga();; 821 | - : float option = Some 3. 822 | # ga();; 823 | - : float option = None 824 | ``` 825 | 826 | #### Exercise 4: Same fringe problem ★☆☆☆☆ 827 | 828 | Two binary trees have the same fringe if they have exactly the same leaves 829 | reading from left to right. Given two binary trees decide whether they have the 830 | same fringe. The source file is `sources/fringe.ml`. 831 | 832 | ### 4.4. Streams 833 | 834 | The iterator need not necessarily be defined on finite data structure. Here is 835 | an iterator that iterates over infinite list of integers. 836 | 837 | ```ocaml 838 | let rec nats : int (* init *) -> (int, unit) iterator = 839 | fun v f () -> 840 | f v; nats (v+1) f () 841 | ``` 842 | 843 | Since the iteration is not over any particular container, the container type is 844 | `unit`. We can make a generator over this iterator, which yields an infinite 845 | sequence of integers. 846 | 847 | ```ocaml 848 | let gen_nats : int generator = generate (nats 0) () 849 | ``` 850 | 851 | We know that this generator does not terminate. Hence, the optional return type 852 | of generator is unnecessary. Hence, we define a type `'a stream` for infinite 853 | streams: 854 | 855 | ```ocaml 856 | type 'a stream = unit -> 'a 857 | ``` 858 | 859 | We can convert a generator to a stream easily: 860 | 861 | ```ocaml 862 | let inf : 'a generator -> 'a stream = 863 | fun g () -> 864 | match g () with 865 | | Some n -> n 866 | | _ -> assert false 867 | ``` 868 | 869 | Now, an infinite stream of integers starting from 0 is: 870 | 871 | ```ocaml 872 | let gen_nats : int stream = inf (generate (nats 0) ());; 873 | assert (0 = gen_nats ());; 874 | assert (1 = gen_nats ());; 875 | assert (2 = gen_nats ());; 876 | assert (3 = gen_nats ());; 877 | (* and so on *) 878 | ``` 879 | 880 | We can define operators over the stream such as `map` and `filter`: 881 | 882 | ```ocaml 883 | let rec filter : 'a stream -> ('a -> bool) -> 'a stream = 884 | fun g p () -> 885 | let v = g () in 886 | if p v then v 887 | else filter g p () 888 | 889 | let map : 'a stream -> ('a -> 'b) -> 'b stream = 890 | fun g f () -> f (g ()) 891 | ``` 892 | 893 | We can manipulate the streams using these operators. For example, 894 | 895 | ```ocaml 896 | (* Even stream *) 897 | let gen_even : int stream = 898 | let nat_stream = inf (generate (nats 0) ()) in 899 | filter nat_stream (fun n -> n mod 2 = 0) 900 | ;; 901 | 902 | assert (0 = gen_even ());; 903 | assert (2 = gen_even ());; 904 | assert (4 = gen_even ());; 905 | assert (6 = gen_even ());; 906 | 907 | (* Odd stream *) 908 | let gen_odd : int stream = 909 | let nat_stream = inf (generate (nats 1) ()) in 910 | filter nat_stream (fun n -> n mod 2 == 1) 911 | ;; 912 | 913 | 914 | assert (1 = gen_odd ());; 915 | assert (3 = gen_odd ());; 916 | assert (5 = gen_odd ());; 917 | assert (7 = gen_odd ());; 918 | 919 | (* Primes using sieve of Eratosthenes *) 920 | let gen_primes = 921 | let s = inf (generate (nats 2) ()) in 922 | let rs = ref s in 923 | fun () -> 924 | let s = !rs in 925 | let prime = s () in 926 | rs := filter s (fun n -> n mod prime != 0); 927 | prime 928 | 929 | assert ( 2 = gen_primes ());; 930 | assert ( 3 = gen_primes ());; 931 | assert ( 5 = gen_primes ());; 932 | assert ( 7 = gen_primes ());; 933 | assert (11 = gen_primes ());; 934 | assert (13 = gen_primes ());; 935 | assert (17 = gen_primes ());; 936 | assert (19 = gen_primes ());; 937 | assert (23 = gen_primes ());; 938 | assert (29 = gen_primes ());; 939 | assert (31 = gen_primes ());; 940 | ``` 941 | 942 | ## 5. Cooperative Concurrency 943 | 944 | OCaml has two popular libraries for cooperative concurrency: Lwt and Async. Both 945 | libraries achieve concurrency through a [concurrency 946 | monad](https://www.seas.upenn.edu/~cis552/11fa/lectures/concurrency.html). As a 947 | result, the programs that wish to use these libraries have to be written in 948 | monadic style. With effect handlers, the code could be written in direct style 949 | but also retain the benefit of asynchronous I/O. While the resultant system 950 | closely resembles [Goroutines in Go](https://tour.golang.org/concurrency/1), 951 | with effect handlers, all of this is implemented in OCaml as a library. 952 | 953 | ### 5.1. Coroutines 954 | 955 | Let us begin with a simple cooperative scheduler. The source code is available 956 | in `sources/cooperative.ml`. The interface we'll implement first is: 957 | 958 | ```ocaml 959 | module type Scheduler = sig 960 | val async : (unit -> 'a) -> unit 961 | (** [async f] runs [f] concurrently *) 962 | val yield : unit -> unit 963 | (** yields control to another task *) 964 | val run : (unit -> 'a) -> unit 965 | (** Runs the scheduler *) 966 | end 967 | ``` 968 | 969 | We declare effects for `async` and `yield`: 970 | 971 | ```ocaml 972 | type _ Effect.t += Async : (unit -> 'a) -> unit Effect.t 973 | | Yield : unit Effect.t 974 | 975 | let async f = perform (Async f) 976 | 977 | let yield () = perform Yield 978 | ``` 979 | 980 | We use a queue for the tasks that are ready to run: 981 | 982 | ```ocaml 983 | let q = Queue.create () 984 | let enqueue t = Queue.push t q 985 | let dequeue () = 986 | if Queue.is_empty q then () 987 | else Queue.pop q () 988 | ``` 989 | 990 | And finally, the main function is: 991 | 992 | ```ocaml 993 | let rec run : 'a. (unit -> 'a) -> unit = 994 | fun main -> 995 | match_with main () 996 | { retc = (fun _ -> dequeue ()); 997 | exnc = (fun e -> raise e); 998 | effc = (fun (type b) (eff: b Effect.t) -> 999 | match eff with 1000 | | Async f -> Some (fun (k: (b, _) continuation) -> 1001 | enqueue (continue k); 1002 | run f 1003 | ) 1004 | | Yield -> Some (fun k -> 1005 | enqueue (continue k); 1006 | dequeue () 1007 | ) 1008 | | _ -> None 1009 | )} 1010 | ``` 1011 | 1012 | If the task runs to completion (value case), then we dequeue and run the next 1013 | task from the scheduler. In the case of an `Async f` effect, the current task is 1014 | enqueued and the new task `f` is run. If the scheduler yields, then the current 1015 | task is enqueued and some other task is dequeued and run from the scheduler. We 1016 | can now write a cooperative concurrent program: 1017 | 1018 | ```ocaml 1019 | let main () = 1020 | let mk_task name () = 1021 | printf "starting %s\n%!" name; 1022 | yield (); 1023 | printf "ending %s\n%!" name 1024 | in 1025 | async (mk_task "a"); 1026 | async (mk_task "b") 1027 | 1028 | let _ = run main 1029 | ``` 1030 | 1031 | ```sh-session 1032 | $ ocaml cooperative.ml 1033 | starting a 1034 | starting b 1035 | ending a 1036 | ending b 1037 | ``` 1038 | 1039 | ### 5.2. Async/await 1040 | 1041 | We can extend the scheduler to implement async/await idiom. The interface we 1042 | will implement is: 1043 | 1044 | ```ocaml 1045 | module type Scheduler = sig 1046 | type 'a promise 1047 | (** Type of promises *) 1048 | val async : (unit -> 'a) -> 'a promise 1049 | (** [async f] runs [f] concurrently *) 1050 | val await : 'a promise -> 'a 1051 | (** [await p] returns the result of the promise. *) 1052 | val yield : unit -> unit 1053 | (** yields control to another task *) 1054 | val run : (unit -> 'a) -> unit 1055 | (** Runs the scheduler *) 1056 | end 1057 | ``` 1058 | 1059 | We model a promise as a mutable reference that either is the list of tasks 1060 | waiting on this promise to resolve (`Waiting`) or a resolved promise with the 1061 | value (`Done`). 1062 | 1063 | ```ocaml 1064 | type 'a _promise = 1065 | Waiting of ('a,unit) continuation list 1066 | | Done of 'a 1067 | 1068 | type 'a promise = 'a _promise ref 1069 | ``` 1070 | 1071 | ### Exercise 5: Implement async/await functionality ★★★☆☆ 1072 | 1073 | In this task, you will implement the core async/await functionality. Unlike the 1074 | previous scheduler, additional work has to be done at the `Async` handler case 1075 | to create the promise, and at task termination (value case) to update the 1076 | promise and resume the waiting threads. In addition, the `Await` case needs to 1077 | be implemented. The source file is `sources/async_await.ml`. 1078 | 1079 | ## 6. Asynchronous I/O 1080 | 1081 | Effect handlers let us write asynchronous I/O libraries in direct-style. 1082 | 1083 | ### 6.1. Blocking echo server 1084 | 1085 | As an example, `sources/echo.ml` is a implementation of an echo server that 1086 | accepts client messages and echoes them back. Observe that all of the code is 1087 | written in direct, function-calling, and apparently blocking style. We will see 1088 | that the same code can be used to implement a blocking as well as non-blocking 1089 | server. A non-blocking server can concurrently host multiple client sessions 1090 | unlike the blocking server which serialises client sessions. 1091 | 1092 | The echo server is functorized over the network interface: 1093 | 1094 | ```ocaml 1095 | module type Aio = sig 1096 | val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr 1097 | val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 1098 | val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 1099 | val fork : (unit -> unit) -> unit 1100 | val run : (unit -> unit) -> unit 1101 | val non_blocking_mode : bool 1102 | (* Are the sockets non-blocking *) 1103 | end 1104 | ``` 1105 | 1106 | We can satisfy this interface with functions from the `Unix` module: 1107 | 1108 | ```ocaml 1109 | struct 1110 | let accept = Unix.accept 1111 | let recv = Unix.recv 1112 | let send = Unix.send 1113 | let fork f = f () 1114 | let run f = f () 1115 | let non_blocking_mode = false 1116 | end 1117 | ``` 1118 | 1119 | You can test this echo server as follows: 1120 | 1121 | ```sh-session 1122 | $ make echo_unix.native 1123 | $ ./echo_unix.native 1124 | Echo server listening on 127.0.0.1:9301 1125 | ``` 1126 | 1127 | In another terminal, establish a client connection: 1128 | 1129 | ```sh-session 1130 | (* first client *) 1131 | $ telnet localhost 9301 1132 | Trying 127.0.0.1... 1133 | Connected to localhost. 1134 | Escape character is '^]'. 1135 | hello 1136 | server says: hello 1137 | world 1138 | server says: world 1139 | ``` 1140 | 1141 | The server echoes whatever message that is sent. In another terminal, establish 1142 | a second concurrent client connection: 1143 | 1144 | ```sh-session 1145 | (* second client *) 1146 | $ telnet localhost 9301 1147 | Trying 127.0.0.1... 1148 | Connected to localhost. 1149 | Escape character is '^]'. 1150 | hello 1151 | world 1152 | ``` 1153 | 1154 | The server does not echo the messages since it is blocked serving the first 1155 | client. Now, switch to the first client terminal, and terminate the connection: 1156 | 1157 | ```sh-session 1158 | (* first client *) 1159 | ^] 1160 | telnet> (* ctrl+d *) 1161 | $ 1162 | ``` 1163 | 1164 | At this point, you should see that all of the messages sent by the second client 1165 | has been echoed: 1166 | 1167 | ```sh-session 1168 | (* second client *) 1169 | server says: hello 1170 | server says: world 1171 | ``` 1172 | 1173 | and further messages from the second client are immediately echoed. 1174 | 1175 | ### 6.2. Asynchronous echo server 1176 | 1177 | We will extend our async/await implementation to support asynchronous I/O 1178 | operations. The source file is `sources/echo_async.ml`. As usual, we declare the 1179 | effects and functions to perform the effects: 1180 | 1181 | ```ocaml 1182 | type file_descr = Unix.file_descr 1183 | type sockaddr = Unix.sockaddr 1184 | type msg_flag = Unix.msg_flag 1185 | 1186 | type _ Effect.t += Accept : file_descr -> (file_descr * sockaddr) Effect.t 1187 | let accept fd = perform (Accept fd) 1188 | 1189 | type _ Effect.t += Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t 1190 | let recv fd buf pos len mode = perform (Recv (fd, buf, pos, len, mode)) 1191 | 1192 | type _ Effect.t += Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t 1193 | let send fd bus pos len mode = perform (Send (fd, bus, pos, len, mode)) 1194 | ``` 1195 | 1196 | We define functions to poll whether a file descriptor is ready to read or write: 1197 | 1198 | ```ocaml 1199 | let ready_to_read fd = 1200 | match Unix.select [fd] [] [] 0. with 1201 | | [], _, _ -> false 1202 | | _ -> true 1203 | 1204 | let ready_to_write fd = 1205 | match Unix.select [] [fd] [] 0. with 1206 | | _, [], _ -> false 1207 | | _ -> true 1208 | ``` 1209 | 1210 | We define a type for tasks blocked on I/O, and a pair of hash tables to hold the 1211 | continuations blocked on reads and writes: 1212 | 1213 | ```ocaml 1214 | type blocked = Blocked : 'a eff * ('a, unit) continuation -> blocked 1215 | 1216 | (* tasks blocked on reads *) 1217 | let br = Hashtbl.create 13 1218 | (* tasks blocked on writes *) 1219 | let bw = Hashtbl.create 13 1220 | ``` 1221 | 1222 | Now, the handler for `Recv` is: 1223 | 1224 | ```ocaml 1225 | | effect (Recv (fd,buf,pos,len,mode) as e) k -> 1226 | if ready_to_read fd then 1227 | continue k (Unix.recv fd buf pos len mode) 1228 | else begin 1229 | Hashtbl.add br fd (Blocked (e, k)); 1230 | schedule () 1231 | end 1232 | ``` 1233 | 1234 | If the file descriptor is ready to be read, then we perform the read immediately 1235 | with the blocking read form `Unix` module knowing that the read would not block. 1236 | If not, we add the task to the blocked-on-read hash table `br`, and schedule the 1237 | next task. The main schedule loop is: 1238 | 1239 | ```ocaml 1240 | let rec schedule () = 1241 | if not (Queue.is_empty q) then 1242 | (* runnable tasks available *) 1243 | Queue.pop q () 1244 | else if Hashtbl.length br = 0 && Hashtbl.length bw = 0 then 1245 | (* no runnable tasks, and no blocked tasks => we're done. *) 1246 | () 1247 | else begin (* no runnable tasks, but blocked tasks available *) 1248 | let rd_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) br [] in 1249 | let wr_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) bw [] in 1250 | let rdy_rd_fds, rdy_wr_fds, _ = Unix.select rd_fds wr_fds [] (-1.) in 1251 | let rec resume ht = function 1252 | | [] -> () 1253 | | x::xs -> 1254 | begin match Hashtbl.find ht x with 1255 | | Blocked (Recv (fd, buf, pos, len, mode), k) -> 1256 | enqueue (fun () -> continue k (Unix.recv fd buf pos len mode)) 1257 | | Blocked (Accept fd, k) -> failwith "not implemented" 1258 | | Blocked (Send (fd, buf, pos, len, mode), k) -> failwith "not implemented" 1259 | | Blocked _ -> failwith "impossible" 1260 | end; 1261 | Hashtbl.remove ht x 1262 | in 1263 | resume br rdy_rd_fds; 1264 | resume bw rdy_wr_fds; 1265 | schedule () 1266 | end 1267 | ``` 1268 | 1269 | The interesting case is when runnable tasks are not available and there are 1270 | blocked tasks. In this case, we run an iteration of the event loop. This 1271 | may unblock further tasks and we continue running them. 1272 | 1273 | 1274 | ### Exercise 6: Implement asynchronous accept and send ★☆☆☆☆ 1275 | 1276 | In the file, `sources/echo_async.ml`, some of the functionality for handling 1277 | `Accept` and `Send` event are not implemented. Your task is to implement these. 1278 | Once you implement these primitives, you can run `echo_async.native` to start 1279 | the asynchronous echo server. This server is able to respond to multiple 1280 | concurrent clients. 1281 | 1282 | ## 7. Conclusion 1283 | 1284 | Hopefully you've enjoyed the tutorial on algebraic effect handlers in Multicore 1285 | OCaml. You should be familiar with: 1286 | 1287 | * What algebraic effects and handlers are. 1288 | * Programming with algebraic effect handlers in Multicore OCaml. 1289 | * Implementation of algebraic effect handlers in Multicore OCaml. 1290 | * Developing control-flow abstractions such as restartable exceptions, 1291 | generators, streams, coroutines, and asynchronous I/O. 1292 | 1293 | 1294 | ### 7.1 Other resources 1295 | 1296 | * [OCaml manual on Effects and handlers](https://kcsrk.info/webman/manual/effects.html) 1297 | * [effect.mli](https://github.com/ocaml/ocaml/blob/trunk/stdlib/effect.mli) in OCaml standard library 1298 | -------------------------------------------------------------------------------- /sources/Makefile: -------------------------------------------------------------------------------- 1 | EXE := input_line_exn.native input_line_exn2.native input_line_eff.native input_line_eff2.native \ 2 | exceptions.native state1.native state2.native \ 3 | gdb.native msg_passing.native fringe.native \ 4 | generator.native \ 5 | cooperative.native async_await.native \ 6 | echo_unix.native echo_async.native 7 | 8 | all: $(EXE) 9 | 10 | echo_unix.native: echo_unix.ml echo.ml 11 | ocamlbuild -pkg unix echo_unix.native 12 | 13 | echo_async.native: echo.ml echo_async.ml 14 | ocamlbuild -pkg unix echo_async.native 15 | 16 | %.native: %.ml 17 | ocamlbuild -cflags -g -lflags -g -cflags -w -cflags -8 $@ 18 | 19 | .PHONY: clean 20 | clean: 21 | ocamlbuild -clean 22 | rm -f *~ 23 | -------------------------------------------------------------------------------- /sources/async_await.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module type Scheduler = sig 4 | type 'a promise 5 | (** Type of promises *) 6 | val async : (unit -> 'a) -> 'a promise 7 | (** [async f] runs [f] concurrently *) 8 | val await : 'a promise -> 'a 9 | (** [await p] returns the result of the promise. *) 10 | val yield : unit -> unit 11 | (** yields control to another task *) 12 | val run : (unit -> 'a) -> unit 13 | (** Runs the scheduler *) 14 | end 15 | 16 | module Scheduler : Scheduler = struct 17 | 18 | open Effect 19 | open Effect.Deep 20 | 21 | type 'a _promise = 22 | Waiting of ('a,unit) continuation list 23 | | Done of 'a 24 | 25 | type 'a promise = 'a _promise ref 26 | 27 | type _ Effect.t += Async : (unit -> 'a) -> 'a promise Effect.t 28 | | Yield : unit Effect.t 29 | | Await : 'a promise -> 'a Effect.t 30 | 31 | let async f = perform (Async f) 32 | 33 | let yield () = perform Yield 34 | 35 | let await p = perform (Await p) 36 | 37 | let q = Queue.create () 38 | let enqueue t = Queue.push t q 39 | let dequeue () = 40 | if Queue.is_empty q then () 41 | else Queue.pop q () 42 | 43 | let run main = 44 | let rec fork : 'a. 'a promise -> (unit -> 'a) -> unit = 45 | fun pr main -> 46 | match_with main () 47 | { retc = (fun v -> failwith "Value case not implemented"); 48 | exnc = raise; 49 | effc = (fun (type b) (eff: b Effect.t) -> 50 | match eff with 51 | | Async f -> (Some (fun (k: (b,_) continuation) -> 52 | failwith "Async not implemented" 53 | )) 54 | | Yield -> (Some (fun k -> 55 | enqueue (continue k); 56 | dequeue () 57 | )) 58 | | Await p -> (Some (fun (k: (b,_) continuation) -> 59 | begin match !p with 60 | | Done v -> continue k v 61 | | Waiting l -> failwith "Await.Waiting not implemented" 62 | end 63 | )) 64 | | _ -> None 65 | )} 66 | in 67 | fork (ref (Waiting [])) main 68 | end 69 | 70 | open Scheduler 71 | 72 | let main () = 73 | let task name () = 74 | Printf.printf "starting %s\n%!" name; 75 | let v = Random.int 100 in 76 | Printf.printf "yielding %s\n%!" name; 77 | yield (); 78 | Printf.printf "ending %s with %d\n%!" name v; 79 | v 80 | in 81 | let pa = async (task "a") in 82 | let pb = async (task "b") in 83 | let pc = async (fun () -> await pa + await pb) in 84 | Printf.printf "Sum is %d\n" (await pc); 85 | assert (await pa + await pb = await pc) 86 | 87 | let _ = run main 88 | -------------------------------------------------------------------------------- /sources/cooperative.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Deep 4 | 5 | module type Scheduler = sig 6 | val async : (unit -> 'a) -> unit 7 | (** [async f] runs [f] concurrently *) 8 | val yield : unit -> unit 9 | (** yields control to another task *) 10 | val run : (unit -> 'a) -> unit 11 | (** Runs the scheduler *) 12 | end 13 | 14 | module Scheduler : Scheduler = struct 15 | 16 | type _ Effect.t += Async : (unit -> 'a) -> unit Effect.t 17 | | Yield : unit Effect.t 18 | 19 | let async f = perform (Async f) 20 | 21 | let yield () = perform Yield 22 | 23 | let q = Queue.create () 24 | let enqueue t = Queue.push t q 25 | let dequeue () = 26 | if Queue.is_empty q then () 27 | else Queue.pop q () 28 | 29 | let rec run : 'a. (unit -> 'a) -> unit = 30 | fun main -> 31 | match_with main () 32 | { retc = (fun _ -> dequeue ()); 33 | exnc = (fun e -> raise e); 34 | effc = (fun (type b) (eff: b Effect.t) -> 35 | match eff with 36 | | Async f -> Some (fun (k: (b, _) continuation) -> 37 | enqueue (continue k); 38 | run f 39 | ) 40 | | Yield -> Some (fun k -> 41 | enqueue (continue k); 42 | dequeue () 43 | ) 44 | | _ -> None 45 | )} 46 | end 47 | 48 | open Scheduler 49 | 50 | let main () = 51 | let mk_task name () = 52 | printf "starting %s\n%!" name; 53 | yield (); 54 | printf "ending %s\n%!" name 55 | in 56 | async (mk_task "a"); 57 | async (mk_task "b") 58 | 59 | let _ = run main 60 | -------------------------------------------------------------------------------- /sources/echo.ml: -------------------------------------------------------------------------------- 1 | (* A simple echo server. 2 | * 3 | * The server listens on localhost port 9301. It accepts multiple clients and 4 | * echoes back to the client any data sent to the server. This server is a 5 | * direct-style reimplementation of the echo server found at [1], which 6 | * illustrates the same server written in CPS style. 7 | * 8 | * Compiling 9 | * --------- 10 | * 11 | * make 12 | * 13 | * Running 14 | * ------- 15 | * The echo server can be tested with a telnet client by starting the server and 16 | * on the same machine, running: 17 | * 18 | * telnet localhost 9301 19 | * 20 | * ----------------------- 21 | * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html 22 | * [2] https://github.com/ocamllabs/opam-repo-dev 23 | *) 24 | 25 | open Printexc 26 | open Printf 27 | 28 | module Make (Aio : sig 29 | val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr 30 | val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 31 | val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 32 | val fork : (unit -> unit) -> unit 33 | val run : (unit -> unit) -> unit 34 | val non_blocking_mode : bool 35 | (* Are the sockets non-blocking *) 36 | end) = struct 37 | let send sock str = 38 | let len = Bytes.length str in 39 | let total = ref 0 in 40 | (try 41 | while !total < len do 42 | let write_count = Aio.send sock str !total (len - !total) [] in 43 | total := write_count + !total 44 | done 45 | with _ -> () 46 | ); 47 | !total 48 | 49 | let recv sock maxlen = 50 | let str = Bytes.create maxlen in 51 | let recvlen = 52 | try Aio.recv sock str 0 maxlen [] 53 | with _ -> 0 54 | in 55 | Bytes.sub str 0 recvlen 56 | 57 | let close sock = 58 | try Unix.shutdown sock Unix.SHUTDOWN_ALL 59 | with _ -> () ; 60 | Unix.close sock 61 | 62 | let string_of_sockaddr = function 63 | | Unix.ADDR_UNIX s -> s 64 | | Unix.ADDR_INET (inet,port) -> 65 | (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port) 66 | 67 | (* Repeat what the client says until the client goes away. *) 68 | let rec echo_server sock addr = 69 | try 70 | let data = recv sock 1024 in 71 | if Bytes.length data > 0 then 72 | (ignore (send sock (Bytes.cat (Bytes.of_string ("server says: ")) data)); 73 | echo_server sock addr) 74 | else 75 | let cn = string_of_sockaddr addr in 76 | (printf "echo_server : client (%s) disconnected.\n%!" cn; 77 | close sock) 78 | with 79 | | _ -> close sock 80 | 81 | let server () = 82 | (* Server listens on localhost at 9301 *) 83 | let addr, port = Unix.inet_addr_loopback, 9301 in 84 | printf "Echo server listening on 127.0.0.1:%d\n%!" port; 85 | let saddr = Unix.ADDR_INET (addr, port) in 86 | let ssock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 87 | (* SO_REUSEADDR so we can restart the server quickly. *) 88 | Unix.setsockopt ssock Unix.SO_REUSEADDR true; 89 | Unix.bind ssock saddr; 90 | Unix.listen ssock 20; 91 | (* Socket is non-blocking *) 92 | if Aio.non_blocking_mode then Unix.set_nonblock ssock; 93 | try 94 | (* Wait for clients, and fork off echo servers. *) 95 | while true do 96 | let client_sock, client_addr = Aio.accept ssock in 97 | let cn = string_of_sockaddr client_addr in 98 | printf "server : client (%s) connected.\n%!" cn; 99 | if Aio.non_blocking_mode then Unix.set_nonblock client_sock; 100 | Aio.fork (fun () -> echo_server client_sock client_addr) 101 | done 102 | with 103 | | e -> 104 | print_endline @@ Printexc.to_string e; 105 | close ssock 106 | 107 | let start () = Aio.run server 108 | end 109 | -------------------------------------------------------------------------------- /sources/echo_async.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module type Aio = sig 4 | type 'a promise 5 | (** Type of promises *) 6 | val async : (unit -> 'a) -> 'a promise 7 | (** [async f] runs [f] concurrently *) 8 | val await : 'a promise -> 'a 9 | (** [await p] returns the result of the promise. *) 10 | val yield : unit -> unit 11 | (** yields control to another task *) 12 | 13 | val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr 14 | val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 15 | val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 16 | 17 | val run : (unit -> 'a) -> unit 18 | (** Runs the scheduler *) 19 | end 20 | 21 | module Aio : Aio = struct 22 | open Effect 23 | open Effect.Deep 24 | 25 | type 'a _promise = 26 | Waiting of ('a,unit) continuation list 27 | | Done of 'a 28 | 29 | type 'a promise = 'a _promise ref 30 | 31 | type _ Effect.t += Async : (unit -> 'a) -> 'a promise Effect.t 32 | let async f = perform (Async f) 33 | 34 | type _ Effect.t += Yield : unit Effect.t 35 | let yield () = perform Yield 36 | 37 | type _ Effect.t += Await : 'a promise -> 'a Effect.t 38 | let await p = perform (Await p) 39 | 40 | type file_descr = Unix.file_descr 41 | type sockaddr = Unix.sockaddr 42 | type msg_flag = Unix.msg_flag 43 | 44 | type _ Effect.t += Accept : file_descr -> (file_descr * sockaddr) Effect.t 45 | let accept fd = perform (Accept fd) 46 | 47 | type _ Effect.t += Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t 48 | let recv fd buf pos len mode = perform (Recv (fd, buf, pos, len, mode)) 49 | 50 | type _ Effect.t += Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t 51 | let send fd bus pos len mode = perform (Send (fd, bus, pos, len, mode)) 52 | 53 | (********************) 54 | 55 | let ready_to_read fd = 56 | match Unix.select [fd] [] [] 0. with 57 | | [], _, _ -> false 58 | | _ -> true 59 | 60 | let ready_to_write fd = 61 | match Unix.select [] [fd] [] 0. with 62 | | _, [], _ -> false 63 | | _ -> true 64 | 65 | let q = Queue.create () 66 | let enqueue t = Queue.push t q 67 | 68 | type blocked = Blocked : 'a Effect.t * ('a, unit) continuation -> blocked 69 | 70 | (* tasks blocked on reads *) 71 | let br = Hashtbl.create 13 72 | (* tasks blocked on writes *) 73 | let bw = Hashtbl.create 13 74 | 75 | let rec schedule () = 76 | if not (Queue.is_empty q) then 77 | (* runnable tasks available *) 78 | Queue.pop q () 79 | else if Hashtbl.length br = 0 && Hashtbl.length bw = 0 then 80 | (* no runnable tasks, and no blocked tasks => we're done. *) 81 | () 82 | else begin (* no runnable tasks, but blocked tasks available *) 83 | let rd_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) br [] in 84 | let wr_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) bw [] in 85 | let rdy_rd_fds, rdy_wr_fds, _ = Unix.select rd_fds wr_fds [] (-1.) in 86 | let rec resume ht = function 87 | | [] -> () 88 | | x::xs -> 89 | begin match Hashtbl.find ht x with 90 | | Blocked (Recv (fd, buf, pos, len, mode), k) -> 91 | enqueue (fun () -> continue k (Unix.recv fd buf pos len mode)) 92 | | Blocked (Accept fd, k) -> failwith "not implemented" 93 | | Blocked (Send (fd, buf, pos, len, mode), k) -> failwith "not implemented" 94 | | Blocked _ -> failwith "impossible" 95 | end; 96 | Hashtbl.remove ht x 97 | in 98 | resume br rdy_rd_fds; 99 | resume bw rdy_wr_fds; 100 | schedule () 101 | end 102 | 103 | let run main = 104 | let rec fork : 'a. 'a promise -> (unit -> 'a) -> unit = 105 | fun pr main -> 106 | match_with main () 107 | { retc = (fun v -> 108 | let l = match !pr with Waiting l -> l | _ -> failwith "impossible" in 109 | List.iter (fun k -> enqueue (fun () -> continue k v)) l; 110 | pr := Done v; 111 | schedule () 112 | ); 113 | exnc = raise; 114 | effc = (fun (type b) (eff: b Effect.t) -> 115 | match eff with 116 | | Async f -> Some (fun (k: (b,_) continuation) -> 117 | let pr = ref (Waiting []) in 118 | enqueue (fun () -> continue k pr); 119 | fork pr f 120 | ) 121 | | Yield -> Some (fun (k: (b,_) continuation) -> 122 | enqueue (continue k); 123 | schedule () 124 | ) 125 | | Await p -> Some (fun (k: (b,_) continuation) -> 126 | begin match !p with 127 | | Done v -> continue k v 128 | | Waiting l -> begin 129 | p := Waiting (k::l); 130 | schedule () 131 | end 132 | end 133 | ) 134 | | Accept fd -> Some (fun (k: (b,_) continuation) -> 135 | failwith "accept not implemented" 136 | ) 137 | | Send (fd,buf,pos,len,mode) -> Some (fun (k: (b,_) continuation) -> 138 | failwith "send not implemented" 139 | ) 140 | | (Recv (fd,buf,pos,len,mode) as e) -> Some (fun (k: (b,_) continuation) -> 141 | if ready_to_read fd then 142 | continue k (Unix.recv fd buf pos len mode) 143 | else begin 144 | Hashtbl.add br fd (Blocked (e, k)); 145 | schedule () 146 | end 147 | ) 148 | | _ -> None 149 | )} 150 | in 151 | fork (ref (Waiting [])) main 152 | end 153 | 154 | module M = Echo.Make(struct 155 | let accept = Aio.accept 156 | let recv = Aio.recv 157 | let send = Aio.send 158 | let fork f = ignore (Aio.async f) 159 | let run f = Aio.run f 160 | let non_blocking_mode = true 161 | end) 162 | 163 | let _ = M.start () 164 | -------------------------------------------------------------------------------- /sources/echo_unix.ml: -------------------------------------------------------------------------------- 1 | module M = Echo.Make(struct 2 | let accept fd = Unix.accept fd 3 | let recv = Unix.recv 4 | let send = Unix.send 5 | let fork f = f () 6 | let run f = f () 7 | let non_blocking_mode = false 8 | end) 9 | 10 | let _ = M.start () 11 | -------------------------------------------------------------------------------- /sources/exceptions.ml: -------------------------------------------------------------------------------- 1 | let raise (e : exn) : 'a = failwith "not implemented" 2 | (* Todo *) 3 | 4 | let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a = failwith "not implemented" 5 | (* Todo *) 6 | 7 | exception Invalid_argument 8 | 9 | (** [sqrt f] returns the square root of [f]. 10 | @raise Invalid_argument if f < 0. *) 11 | let sqrt f = 12 | if f < 0.0 then raise Invalid_argument 13 | else sqrt f 14 | 15 | let _ = 16 | try_with (fun () -> 17 | let r = sqrt 42.42 in 18 | Printf.printf "%f\n%!" r; 19 | let r = sqrt (-1.0) in 20 | Printf.printf "%f\n" r) 21 | (fun Invalid_argument -> Printf.printf "Invalid_argument to sqrt\n") 22 | 23 | (* Prints: 24 | 6.513064 25 | Invalid_argument to sqrt *) 26 | -------------------------------------------------------------------------------- /sources/fringe.ml: -------------------------------------------------------------------------------- 1 | (* Same Fringe Problem 2 | 3 | Definition: Two binary trees have the same fringe if they have exactly 4 | the same leaves reading from left to right. 5 | 6 | Problem: Given two binary trees decide whether they have the same fringe. 7 | *) 8 | 9 | type ('elt,'cont) iterator = ('elt -> unit) -> 'cont -> unit 10 | 11 | type 'elt generator = unit -> 'elt option 12 | 13 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 14 | let open Effect in 15 | let open Effect.Shallow in 16 | let module M = struct 17 | type _ Effect.t += 18 | Yield : elt -> unit Effect.t 19 | 20 | type ('a, 'b) status = 21 | NotStarted 22 | | InProgress of ('a,'b) continuation 23 | | Finished 24 | end 25 | in 26 | let open M in 27 | let yield v = perform (Yield v) in 28 | let curr_status = ref NotStarted in 29 | let rec helper () = 30 | match !curr_status with 31 | | Finished -> None 32 | | NotStarted -> 33 | curr_status := InProgress (fiber (fun () -> i yield c)); 34 | helper () 35 | | InProgress k -> 36 | continue_with k () 37 | { retc = (fun _ -> 38 | curr_status := Finished; 39 | helper ()); 40 | exnc = (fun e -> raise e); 41 | effc = (fun (type b) (eff: b Effect.t) -> 42 | match eff with 43 | | Yield x -> Some (fun (k: (b,_) continuation) -> 44 | curr_status := InProgress k; 45 | Some x 46 | ) 47 | | _ -> None)} 48 | in 49 | helper 50 | 51 | type 'a tree = 52 | | Leaf of 'a 53 | | Node of 'a tree * 'a tree 54 | 55 | let same_fringe t1 t2 = failwith "not implemented" 56 | 57 | let t1 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 58 | let t2 = Node (Node (Leaf 1, Leaf 2), Leaf 3) 59 | let t3 = Node (Node (Leaf 3, Leaf 2), Leaf 1) 60 | let t4 = Leaf 42 61 | let t5 = Leaf 41 62 | let t6 = Node (Leaf 1, Leaf 2) 63 | let t7 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 64 | ;; 65 | 66 | assert (same_fringe t1 t2);; 67 | assert (same_fringe t2 t1);; 68 | assert (not (same_fringe t1 t3));; 69 | assert (same_fringe t1 t7);; 70 | assert (same_fringe t2 t7);; 71 | -------------------------------------------------------------------------------- /sources/gdb.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ Effect.t += Peek : int Effect.t 5 | | Poke : unit Effect.t 6 | 7 | let rec a i = perform Peek + Random.int i 8 | let rec b i = a i + Random.int i 9 | let rec c i = b i + Random.int i 10 | 11 | let rec d i = 12 | Random.int i + 13 | try_with c i 14 | { effc = fun (type a) (e: a t) -> 15 | match e with 16 | | Poke -> Some (fun (k: (a,_) continuation) -> continue k ()) 17 | | _ -> None 18 | } 19 | 20 | let rec e i = 21 | Random.int i + 22 | try_with d i 23 | { effc = fun (type a) (e: a t) -> 24 | match e with 25 | | Peek -> Some (fun (k: (a,_) continuation) -> 26 | Printexc.(print_raw_backtrace stdout (Effect.Deep.get_callstack k 100)); 27 | flush stdout; 28 | continue k 42 29 | ) 30 | | _ -> None 31 | } 32 | 33 | let _ = Printf.printf "%d\n" (e 100) 34 | -------------------------------------------------------------------------------- /sources/generator.ml: -------------------------------------------------------------------------------- 1 | type ('elt,'container) iterator = ('elt -> unit) -> 'container -> unit 2 | 3 | type 'elt generator = unit -> 'elt option 4 | 5 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 6 | let open Effect in 7 | let module M = struct 8 | type _ Effect.t += 9 | Yield : elt -> unit Effect.t 10 | end 11 | in 12 | let open M in 13 | failwith "Not implemented" 14 | 15 | (***********************) 16 | (* Traversal generator *) 17 | (***********************) 18 | 19 | let gen_list : 'a list -> 'a generator = generate List.iter 20 | let gl : int generator = gen_list [1;2;3] 21 | ;; 22 | 23 | assert (Some 1 = gl ());; 24 | assert (Some 2 = gl ());; 25 | assert (Some 3 = gl ());; 26 | assert (None = gl ());; 27 | assert (None = gl ());; 28 | 29 | let gen_array : 'a array -> 'a generator = generate Array.iter 30 | let ga : float generator = gen_array [| 1.0; 2.0; 3.0 |] 31 | ;; 32 | 33 | 34 | assert (Some 1.0 = ga ());; 35 | assert (Some 2.0 = ga ());; 36 | assert (Some 3.0 = ga ());; 37 | assert (None = ga ());; 38 | assert (None = ga ());; 39 | 40 | (***********) 41 | (* Streams *) 42 | (***********) 43 | 44 | (* Iterator over nats. Dummy () container. *) 45 | let rec nats : int (* init *) -> (int, unit) iterator = 46 | fun v f () -> 47 | f v; nats (v+1) f () 48 | 49 | (* Infinite stream *) 50 | type 'a stream = unit -> 'a 51 | 52 | (* Convert generator to an infinite stream *) 53 | let inf : 'a generator -> 'a stream = 54 | fun g () -> 55 | match g () with 56 | | Some n -> n 57 | | _ -> assert false 58 | 59 | (* Nat stream *) 60 | let gen_nats : int stream = inf (generate (nats 0) ()) 61 | ;; 62 | 63 | assert (0 = gen_nats ());; 64 | assert (1 = gen_nats ());; 65 | assert (2 = gen_nats ());; 66 | assert (3 = gen_nats ());; 67 | 68 | (* filter stream *) 69 | let rec filter : 'a stream -> ('a -> bool) -> 'a stream = 70 | fun g p () -> 71 | let v = g () in 72 | if p v then v 73 | else filter g p () 74 | 75 | (* map stream *) 76 | let rec map : 'a stream -> ('a -> 'b) -> 'b stream = 77 | fun g f () -> f (g ()) 78 | 79 | (* Even stream *) 80 | let gen_even : int stream = 81 | let nat_stream = inf (generate (nats 0) ()) in 82 | filter nat_stream (fun n -> n mod 2 = 0) 83 | ;; 84 | 85 | assert (0 = gen_even ());; 86 | assert (2 = gen_even ());; 87 | assert (4 = gen_even ());; 88 | assert (6 = gen_even ());; 89 | 90 | (* Odd stream *) 91 | let gen_odd : int stream = 92 | let nat_stream = inf (generate (nats 1) ()) in 93 | filter nat_stream (fun n -> n mod 2 == 1) 94 | ;; 95 | 96 | 97 | assert (1 = gen_odd ());; 98 | assert (3 = gen_odd ());; 99 | assert (5 = gen_odd ());; 100 | assert (7 = gen_odd ());; 101 | 102 | (* Primes using sieve of Eratosthenes *) 103 | let gen_primes = 104 | let s = inf (generate (nats 2) ()) in 105 | let rs = ref s in 106 | fun () -> 107 | let s = !rs in 108 | let prime = s () in 109 | rs := filter s (fun n -> n mod prime != 0); 110 | prime 111 | ;; 112 | 113 | assert ( 2 = gen_primes ());; 114 | assert ( 3 = gen_primes ());; 115 | assert ( 5 = gen_primes ());; 116 | assert ( 7 = gen_primes ());; 117 | assert (11 = gen_primes ());; 118 | assert (13 = gen_primes ());; 119 | assert (17 = gen_primes ());; 120 | assert (19 = gen_primes ());; 121 | assert (23 = gen_primes ());; 122 | assert (29 = gen_primes ());; 123 | assert (31 = gen_primes ());; 124 | -------------------------------------------------------------------------------- /sources/input_line_eff.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ Effect.t += Conversion_failure : string -> int Effect.t 5 | 6 | let int_of_string l = 7 | try int_of_string l with 8 | | Failure _ -> perform (Conversion_failure l) 9 | 10 | let rec sum_up acc = 11 | let l = input_line stdin in 12 | acc := !acc + int_of_string l; 13 | sum_up acc 14 | 15 | let _ = 16 | Printf.printf "Starting up. Please input:\n%!"; 17 | let r = ref 0 in 18 | match_with sum_up r 19 | { effc = (fun (type a) (e: a Effect.t) -> 20 | match e with 21 | | Conversion_failure s -> Some (fun (k: (a,_) continuation) -> 22 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s; 23 | continue k 0) 24 | | _ -> None 25 | ); 26 | exnc = (function 27 | | End_of_file -> Printf.printf "Sum is %d\n" !r 28 | | e -> raise e 29 | ); 30 | (* Shouldn't reach here, means sum_up returned a value *) 31 | retc = fun _ -> failwith "Impossible?" 32 | } 33 | -------------------------------------------------------------------------------- /sources/input_line_eff2.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ Effect.t += 5 | Conversion_failure : string -> int Effect.t 6 | 7 | let int_of_string l = 8 | try int_of_string l with 9 | | Failure _ -> perform (Conversion_failure l) 10 | 11 | let rec sum_up acc = 12 | let l = input_line stdin in 13 | acc := !acc + int_of_string l; 14 | sum_up acc 15 | 16 | let _ = 17 | Printf.printf "Starting up. Please input:\n%!"; 18 | let r = ref 0 in 19 | match_with sum_up r 20 | { effc = (fun (type a) (e: a t) -> 21 | match e with 22 | | Conversion_failure s -> Some (fun (k: (a,_) continuation) -> 23 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s; 24 | discontinue k (Failure "int_of_string")) 25 | | _ -> None 26 | ); 27 | exnc = (function 28 | | End_of_file -> Printf.printf "Sum is %d\n" !r 29 | | e -> raise e 30 | ); 31 | (* Shouldn't reach here, means sum_up returned a value *) 32 | retc = fun v -> v 33 | } 34 | -------------------------------------------------------------------------------- /sources/input_line_exn.ml: -------------------------------------------------------------------------------- 1 | let rec sum_up acc = 2 | let l = input_line stdin in 3 | acc := !acc + int_of_string l; 4 | sum_up acc 5 | 6 | let _ = 7 | let r = ref 0 in 8 | try sum_up r with 9 | | End_of_file -> Printf.printf "Sum is %d\n" !r 10 | -------------------------------------------------------------------------------- /sources/input_line_exn2.ml: -------------------------------------------------------------------------------- 1 | exception Conversion_failure of string 2 | 3 | let int_of_string l = 4 | try int_of_string l with 5 | | Failure _ -> raise (Conversion_failure l) 6 | 7 | let rec sum_up acc = 8 | let l = input_line stdin in 9 | acc := !acc + int_of_string l; 10 | sum_up acc 11 | 12 | let _ = 13 | let r = ref 0 in 14 | try sum_up r with 15 | | End_of_file -> Printf.printf "Sum is %d\n" !r 16 | | Conversion_failure s -> 17 | Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s 18 | 19 | -------------------------------------------------------------------------------- /sources/msg_passing.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ Effect.t += Xchg : int -> int Effect.t 5 | 6 | (* status of a computation *) 7 | type status = 8 | Done 9 | | Paused of int * (int, status) continuation 10 | 11 | (* step through [f v] until either termination or pauses on Xchg *) 12 | let step f v () = 13 | match_with f v 14 | { retc = (fun _ -> Done); 15 | exnc = (fun e -> raise e); 16 | effc = (fun (type b) (eff: b t) -> 17 | match eff with 18 | | Xchg m -> Some (fun (k: (b,_) continuation) -> 19 | Paused (m, k)) 20 | | _ -> None 21 | )} 22 | 23 | (* Run both of the computations concurrenty *) 24 | let rec run_both a b = 25 | match a (), b () with 26 | | Done, Done -> () 27 | | Paused (v1, k1), Paused (v2, k2) -> 28 | run_both (fun () -> continue k1 v2) (fun () -> continue k2 v1) 29 | | _ -> failwith "improper synchronization" 30 | 31 | let rec f name = function 32 | | 0 -> () 33 | | n -> 34 | Printf.printf "%s: sending %d\n%!" name n; 35 | let v = perform (Xchg n) in 36 | Printf.printf "%s: received %d\n%!" name v; 37 | f name (n-1) 38 | 39 | let _ = run_both (step (f "a") 3) (step (f "b") 3) 40 | -------------------------------------------------------------------------------- /sources/solved/Makefile: -------------------------------------------------------------------------------- 1 | EXE := exceptions.native echo_async.native fringe.native async_await.native generator.native deep_generator.native state2.native 2 | 3 | all: $(EXE) 4 | 5 | echo_async.native: echo.ml echo_async.ml 6 | ocamlbuild -pkg unix -cflags -g echo_async.native 7 | 8 | %.native: %.ml 9 | ocamlbuild -cflags -g -cflags -w $@ 10 | 11 | .PHONY: clean 12 | clean: 13 | ocamlbuild -clean 14 | rm -f *~ 15 | -------------------------------------------------------------------------------- /sources/solved/async_await.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module type Scheduler = sig 4 | type 'a promise 5 | (** Type of promises *) 6 | val async : (unit -> 'a) -> 'a promise 7 | (** [async f] runs [f] concurrently *) 8 | val await : 'a promise -> 'a 9 | (** [await p] returns the result of the promise. *) 10 | val yield : unit -> unit 11 | (** yields control to another task *) 12 | val run : (unit -> 'a) -> unit 13 | (** Runs the scheduler *) 14 | end 15 | 16 | module Scheduler : Scheduler = struct 17 | 18 | open Effect 19 | open Effect.Deep 20 | 21 | type 'a _promise = 22 | Waiting of ('a,unit) continuation list 23 | | Done of 'a 24 | 25 | type 'a promise = 'a _promise ref 26 | 27 | type _ Effect.t += Async : (unit -> 'a) -> 'a promise Effect.t 28 | | Yield : unit Effect.t 29 | | Await : 'a promise -> 'a Effect.t 30 | 31 | let async f = perform (Async f) 32 | 33 | let yield () = perform Yield 34 | 35 | let await p = perform (Await p) 36 | 37 | let q = Queue.create () 38 | let enqueue t = Queue.push t q 39 | let dequeue () = 40 | if Queue.is_empty q then () 41 | else Queue.pop q () 42 | 43 | let run main = 44 | let rec fork : 'a. 'a promise -> (unit -> 'a) -> unit = 45 | fun pr main -> 46 | match_with main () 47 | { retc = (fun v -> 48 | (* Resolve the promise *) 49 | match !pr with 50 | | Done _ -> failwith "Trying to resolve already resolved promise" 51 | | Waiting l -> 52 | pr := Done v; 53 | (* Schedule all the waiting continuations *) 54 | let schedule w = 55 | enqueue (fun () -> continue w v) 56 | in 57 | List.iter schedule l; 58 | (* Alternate implementation: 59 | Inform all waiting continuations 60 | as soon as we have a value *) 61 | (* let inform k = *) 62 | (* continue k v *) 63 | (* in *) 64 | (* List.iter inform l; *) 65 | dequeue () 66 | ); 67 | exnc = raise; 68 | effc = (fun (type b) (eff: b Effect.t) -> 69 | match eff with 70 | | Async f -> (Some (fun (k: (b,_) continuation) -> 71 | let p = ref (Waiting []) in 72 | let calculate_f () = fork p f in 73 | let continue_k () = continue k p in 74 | (* Schedule calculation of f for later *) 75 | enqueue calculate_f; 76 | (* Return promise to continuation *) 77 | continue_k () 78 | (* Alternate implementation: 79 | * Start work on f immediately, 80 | * return promise to k later*) 81 | (* enqueue continue_k; *) 82 | (* calculate_f () *) 83 | )) 84 | | Yield -> (Some (fun k -> 85 | enqueue (continue k); 86 | dequeue () 87 | )) 88 | | Await p -> (Some (fun k -> 89 | begin match !p with 90 | | Done v -> continue k v 91 | | Waiting l -> 92 | p := Waiting (k::l); 93 | dequeue () 94 | end 95 | )) 96 | | _ -> None 97 | )} 98 | in 99 | fork (ref (Waiting [])) main 100 | end 101 | 102 | open Scheduler 103 | 104 | let main () = 105 | let task name () = 106 | Printf.printf "starting %s\n%!" name; 107 | let v = Random.int 100 in 108 | Printf.printf "yielding %s\n%!" name; 109 | yield (); 110 | Printf.printf "ending %s with %d\n%!" name v; 111 | v 112 | in 113 | let pa = async (task "a") in 114 | let pb = async (task "b") in 115 | let pc = async (fun () -> 116 | Printf.printf "Starting c\n%!"; 117 | let val_a = await pa in 118 | let val_b = await pb in 119 | let v = val_a + val_b in 120 | Printf.printf "ending %s with %d\n%!" "c" v; 121 | v 122 | 123 | ) in 124 | let pd = async (task "d") in 125 | let pe = async (task "e") in 126 | let pf = async (fun () -> 127 | Printf.printf "starting f\n%!"; 128 | let x = await pa in 129 | Printf.printf "yielding f\n%!"; 130 | yield (); 131 | let v = x + await pe + await pc - await pd in 132 | Printf.printf "ending %s with %d\n%!" "f" v; 133 | v 134 | ) 135 | in 136 | Printf.printf "Before waiting on anything\n%!"; 137 | Printf.printf "pf is %d\n" (await pf); 138 | Printf.printf "Sum is %d\n" (await pc); 139 | assert (await pa + await pb = await pc) 140 | 141 | let _ = run main 142 | -------------------------------------------------------------------------------- /sources/solved/deep_generator.ml: -------------------------------------------------------------------------------- 1 | type ('elt,'container) iterator = ('elt -> unit) -> 'container -> unit 2 | 3 | type 'elt generator = unit -> 'elt option 4 | 5 | (* An alternate solution using 6 | * Effect.Deep handlers instead of Effect.Shallow *) 7 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 8 | let open Effect in 9 | let open Effect.Deep in 10 | let module M = struct 11 | type _ Effect.t += 12 | Yield : elt -> unit Effect.t 13 | end 14 | in 15 | let open M in 16 | let yield v = perform (Yield v) in 17 | let rec curr_calc = ref (fun () -> 18 | i yield c; 19 | curr_calc := (fun () -> None); 20 | None 21 | ) in 22 | let rec helper () = 23 | try_with !curr_calc () 24 | { effc = (fun (type b) (eff: b Effect.t) -> 25 | match eff with 26 | | Yield x -> Some (fun (k: (b,_) continuation) -> 27 | curr_calc := continue k; 28 | Some x 29 | ) 30 | | _ -> None 31 | )} 32 | in 33 | helper 34 | 35 | 36 | (***********************) 37 | (* Traversal generator *) 38 | (***********************) 39 | 40 | let gen_list : 'a list -> 'a generator = generate List.iter 41 | let gl : int generator = gen_list [1;2;3] 42 | ;; 43 | 44 | assert (Some 1 = gl ());; 45 | assert (Some 2 = gl ());; 46 | assert (Some 3 = gl ());; 47 | assert (None = gl ());; 48 | assert (None = gl ());; 49 | 50 | let gen_array : 'a array -> 'a generator = generate Array.iter 51 | let ga : float generator = gen_array [| 1.0; 2.0; 3.0 |] 52 | ;; 53 | 54 | 55 | assert (Some 1.0 = ga ());; 56 | assert (Some 2.0 = ga ());; 57 | assert (Some 3.0 = ga ());; 58 | assert (None = ga ());; 59 | assert (None = ga ());; 60 | 61 | (***********) 62 | (* Streams *) 63 | (***********) 64 | 65 | (* Iterator over nats. Dummy () container. *) 66 | let rec nats : int (* init *) -> (int, unit) iterator = 67 | fun v f () -> 68 | f v; nats (v+1) f () 69 | 70 | (* Infinite stream *) 71 | type 'a stream = unit -> 'a 72 | 73 | (* Convert generator to an infinite stream *) 74 | let inf : 'a generator -> 'a stream = 75 | fun g () -> 76 | match g () with 77 | | Some n -> n 78 | | _ -> assert false 79 | 80 | (* Nat stream *) 81 | let gen_nats : int stream = inf (generate (nats 0) ()) 82 | ;; 83 | 84 | assert (0 = gen_nats ());; 85 | assert (1 = gen_nats ());; 86 | assert (2 = gen_nats ());; 87 | assert (3 = gen_nats ());; 88 | 89 | (* filter stream *) 90 | let rec filter : 'a stream -> ('a -> bool) -> 'a stream = 91 | fun g p () -> 92 | let v = g () in 93 | if p v then v 94 | else filter g p () 95 | 96 | (* map stream *) 97 | let rec map : 'a stream -> ('a -> 'b) -> 'b stream = 98 | fun g f () -> f (g ()) 99 | 100 | (* Even stream *) 101 | let gen_even : int stream = 102 | let nat_stream = inf (generate (nats 0) ()) in 103 | filter nat_stream (fun n -> n mod 2 = 0) 104 | ;; 105 | 106 | assert (0 = gen_even ());; 107 | assert (2 = gen_even ());; 108 | assert (4 = gen_even ());; 109 | assert (6 = gen_even ());; 110 | 111 | (* Odd stream *) 112 | let gen_odd : int stream = 113 | let nat_stream = inf (generate (nats 1) ()) in 114 | filter nat_stream (fun n -> n mod 2 == 1) 115 | ;; 116 | 117 | 118 | assert (1 = gen_odd ());; 119 | assert (3 = gen_odd ());; 120 | assert (5 = gen_odd ());; 121 | assert (7 = gen_odd ());; 122 | 123 | (* Primes using sieve of Eratosthenes *) 124 | let gen_primes = 125 | let s = inf (generate (nats 2) ()) in 126 | let rs = ref s in 127 | fun () -> 128 | let s = !rs in 129 | let prime = s () in 130 | rs := filter s (fun n -> n mod prime != 0); 131 | prime 132 | ;; 133 | 134 | assert ( 2 = gen_primes ());; 135 | assert ( 3 = gen_primes ());; 136 | assert ( 5 = gen_primes ());; 137 | assert ( 7 = gen_primes ());; 138 | assert (11 = gen_primes ());; 139 | assert (13 = gen_primes ());; 140 | assert (17 = gen_primes ());; 141 | assert (19 = gen_primes ());; 142 | assert (23 = gen_primes ());; 143 | assert (29 = gen_primes ());; 144 | assert (31 = gen_primes ());; 145 | -------------------------------------------------------------------------------- /sources/solved/echo.ml: -------------------------------------------------------------------------------- 1 | (* A simple echo server. 2 | * 3 | * The server listens on localhost port 9301. It accepts multiple clients and 4 | * echoes back to the client any data sent to the server. This server is a 5 | * direct-style reimplementation of the echo server found at [1], which 6 | * illustrates the same server written in CPS style. 7 | * 8 | * Compiling 9 | * --------- 10 | * 11 | * make 12 | * 13 | * Running 14 | * ------- 15 | * The echo server can be tested with a telnet client by starting the server and 16 | * on the same machine, running: 17 | * 18 | * telnet localhost 9301 19 | * 20 | * ----------------------- 21 | * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html 22 | * [2] https://github.com/ocamllabs/opam-repo-dev 23 | *) 24 | 25 | open Printexc 26 | open Printf 27 | 28 | module Make (Aio : sig 29 | val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr 30 | val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 31 | val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 32 | val fork : (unit -> unit) -> unit 33 | val run : (unit -> unit) -> unit 34 | val non_blocking_mode : bool 35 | (* Are the sockets non-blocking *) 36 | end) = struct 37 | let send sock str = 38 | let len = String.length str in 39 | let total = ref 0 in 40 | (try 41 | while !total < len do 42 | let write_count = Aio.send sock (Bytes.of_string str) !total (len - !total) [] in 43 | total := write_count + !total 44 | done 45 | with _ -> () 46 | ); 47 | !total 48 | 49 | let recv sock maxlen = 50 | let str = Bytes.create maxlen in 51 | let recvlen = 52 | try Aio.recv sock str 0 maxlen [] 53 | with _ -> 0 54 | in 55 | String.sub (String.of_bytes str) 0 recvlen 56 | 57 | let close sock = 58 | try Unix.shutdown sock Unix.SHUTDOWN_ALL 59 | with _ -> () ; 60 | Unix.close sock 61 | 62 | let string_of_sockaddr = function 63 | | Unix.ADDR_UNIX s -> s 64 | | Unix.ADDR_INET (inet,port) -> 65 | (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port) 66 | 67 | (* Repeat what the client says until the client goes away. *) 68 | let rec echo_server sock addr = 69 | try 70 | let data = recv sock 1024 in 71 | if String.length data > 0 then 72 | (ignore (send sock ("server says: " ^ data)); 73 | echo_server sock addr) 74 | else 75 | let cn = string_of_sockaddr addr in 76 | (printf "echo_server : client (%s) disconnected.\n%!" cn; 77 | close sock) 78 | with 79 | | _ -> close sock 80 | 81 | let server () = 82 | (* Server listens on localhost at 9301 *) 83 | let addr, port = Unix.inet_addr_loopback, 9301 in 84 | printf "Echo server listening on 127.0.0.1:%d\n%!" port; 85 | let saddr = Unix.ADDR_INET (addr, port) in 86 | let ssock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 87 | (* SO_REUSEADDR so we can restart the server quickly. *) 88 | Unix.setsockopt ssock Unix.SO_REUSEADDR true; 89 | Unix.bind ssock saddr; 90 | Unix.listen ssock 20; 91 | (* Socket is non-blocking *) 92 | if Aio.non_blocking_mode then Unix.set_nonblock ssock; 93 | try 94 | (* Wait for clients, and fork off echo servers. *) 95 | while true do 96 | let client_sock, client_addr = Aio.accept ssock in 97 | let cn = string_of_sockaddr client_addr in 98 | printf "server : client (%s) connected.\n%!" cn; 99 | if Aio.non_blocking_mode then Unix.set_nonblock client_sock; 100 | Aio.fork (fun () -> echo_server client_sock client_addr) 101 | done 102 | with 103 | | e -> 104 | print_endline @@ Printexc.to_string e; 105 | close ssock 106 | 107 | let start () = Aio.run server 108 | end 109 | -------------------------------------------------------------------------------- /sources/solved/echo_async.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module type Aio = sig 4 | type 'a promise 5 | (** Type of promises *) 6 | val async : (unit -> 'a) -> 'a promise 7 | (** [async f] runs [f] concurrently *) 8 | val await : 'a promise -> 'a 9 | (** [await p] returns the result of the promise. *) 10 | val yield : unit -> unit 11 | (** yields control to another task *) 12 | 13 | val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr 14 | val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 15 | val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int 16 | 17 | val run : (unit -> 'a) -> unit 18 | (** Runs the scheduler *) 19 | end 20 | 21 | module Aio : Aio = struct 22 | open Effect 23 | open Effect.Deep 24 | 25 | type 'a _promise = 26 | Waiting of ('a,unit) continuation list 27 | | Done of 'a 28 | 29 | type 'a promise = 'a _promise ref 30 | 31 | type _ Effect.t += Async : (unit -> 'a) -> 'a promise Effect.t 32 | let async f = perform (Async f) 33 | 34 | type _ Effect.t += Yield : unit Effect.t 35 | let yield () = perform Yield 36 | 37 | type _ Effect.t += Await : 'a promise -> 'a Effect.t 38 | let await p = perform (Await p) 39 | 40 | type file_descr = Unix.file_descr 41 | type sockaddr = Unix.sockaddr 42 | type msg_flag = Unix.msg_flag 43 | 44 | type _ Effect.t += Accept : file_descr -> (file_descr * sockaddr) Effect.t 45 | let accept fd = perform (Accept fd) 46 | 47 | type _ Effect.t += Recv : file_descr * bytes * int * int * msg_flag list -> int Effect.t 48 | let recv fd buf pos len mode = perform (Recv (fd, buf, pos, len, mode)) 49 | 50 | type _ Effect.t += Send : file_descr * bytes * int * int * msg_flag list -> int Effect.t 51 | let send fd bus pos len mode = perform (Send (fd, bus, pos, len, mode)) 52 | 53 | (********************) 54 | 55 | let ready_to_read fd = 56 | match Unix.select [fd] [] [] 0. with 57 | | [], _, _ -> false 58 | | _ -> true 59 | 60 | let ready_to_write fd = 61 | match Unix.select [] [fd] [] 0. with 62 | | _, [], _ -> false 63 | | _ -> true 64 | 65 | let q = Queue.create () 66 | let enqueue t = Queue.push t q 67 | 68 | type blocked = Blocked : 'a Effect.t * ('a, unit) continuation -> blocked 69 | 70 | (* tasks blocked on reads *) 71 | let br = Hashtbl.create 13 72 | (* tasks blocked on writes *) 73 | let bw = Hashtbl.create 13 74 | 75 | let rec schedule () = 76 | if not (Queue.is_empty q) then 77 | (* runnable tasks available *) 78 | Queue.pop q () 79 | else if Hashtbl.length br = 0 && Hashtbl.length bw = 0 then 80 | (* no runnable tasks, and no blocked tasks => we're done. *) 81 | () 82 | else begin (* no runnable tasks, but blocked tasks available *) 83 | let rd_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) br [] in 84 | let wr_fds = Hashtbl.fold (fun fd _ acc -> fd::acc) bw [] in 85 | let rdy_rd_fds, rdy_wr_fds, _ = Unix.select rd_fds wr_fds [] (-1.) in 86 | let rec resume ht = function 87 | | [] -> () 88 | | x::xs -> 89 | begin match Hashtbl.find ht x with 90 | | Blocked (Recv (fd, buf, pos, len, mode), k) -> 91 | enqueue (fun () -> continue k (Unix.recv fd buf pos len mode)) 92 | | Blocked (Accept fd, k) -> 93 | enqueue (fun () -> continue k (Unix.accept fd)) 94 | | Blocked (Send (fd, buf, pos, len, mode), k) -> 95 | enqueue (fun () -> continue k (Unix.send fd buf pos len mode)) 96 | | Blocked _ -> failwith "impossible" 97 | end; 98 | Hashtbl.remove ht x 99 | in 100 | resume br rdy_rd_fds; 101 | resume bw rdy_wr_fds; 102 | schedule () 103 | end 104 | 105 | let run main = 106 | let rec fork : 'a. 'a promise -> (unit -> 'a) -> unit = 107 | fun pr main -> 108 | match_with main () 109 | { retc = (fun v -> 110 | let l = match !pr with Waiting l -> l | _ -> failwith "impossible" in 111 | List.iter (fun k -> enqueue (fun () -> continue k v)) l; 112 | pr := Done v; 113 | schedule () 114 | ); 115 | exnc = raise; 116 | effc = (fun (type b) (eff: b Effect.t) -> 117 | match eff with 118 | | Async f -> Some (fun (k: (b,_) continuation) -> 119 | let pr = ref (Waiting []) in 120 | enqueue (fun () -> continue k pr); 121 | fork pr f 122 | ) 123 | | Yield -> Some (fun (k: (b,_) continuation) -> 124 | enqueue (continue k); 125 | schedule () 126 | ) 127 | | Await p -> Some (fun (k: (b,_) continuation) -> 128 | begin match !p with 129 | | Done v -> continue k v 130 | | Waiting l -> begin 131 | p := Waiting (k::l); 132 | schedule () 133 | end 134 | end 135 | ) 136 | | (Accept fd as e) -> Some (fun (k: (b,_) continuation) -> 137 | if ready_to_read fd then 138 | continue k (Unix.accept fd) 139 | else begin 140 | Hashtbl.add br fd (Blocked (e,k)); 141 | schedule () 142 | end 143 | ) 144 | | (Send (fd,buf,pos,len,mode) as e) -> Some (fun (k: (b,_) continuation) -> 145 | if ready_to_write fd then 146 | continue k (Unix.send fd buf pos len mode) 147 | else begin 148 | Hashtbl.add bw fd (Blocked (e,k)); 149 | schedule () 150 | end 151 | ) 152 | | (Recv (fd,buf,pos,len,mode) as e) -> Some (fun (k: (b,_) continuation) -> 153 | if ready_to_read fd then 154 | continue k (Unix.recv fd buf pos len mode) 155 | else begin 156 | Hashtbl.add br fd (Blocked (e, k)); 157 | schedule () 158 | end 159 | ) 160 | | _ -> None 161 | )} 162 | in 163 | fork (ref (Waiting [])) main 164 | end 165 | 166 | module M = Echo.Make(struct 167 | let accept = Aio.accept 168 | let recv = Aio.recv 169 | let send = Aio.send 170 | let fork f = ignore (Aio.async f) 171 | let run f = Aio.run f 172 | let non_blocking_mode = true 173 | end) 174 | 175 | let _ = M.start () 176 | -------------------------------------------------------------------------------- /sources/solved/exceptions.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | 3 | type _ Effect.t += Exn : exn -> 'a Effect.t 4 | let raise (e : exn) : 'a = perform (Exn e) 5 | 6 | let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a = let open Effect.Deep in 7 | try_with f () 8 | { effc = (fun (type b) (eff: b Effect.t) -> 9 | match eff with 10 | | Exn e -> Some (fun (k: (b,_) continuation) -> h e) 11 | | _ -> None 12 | )} 13 | 14 | 15 | exception Invalid_argument 16 | 17 | (** [sqrt f] returns the square root of [f]. 18 | @raise Invalid_argument if f < 0. *) 19 | let sqrt f = 20 | if f < 0.0 then raise Invalid_argument 21 | else sqrt f 22 | 23 | let _ = 24 | try_with (fun () -> 25 | let r = sqrt 42.42 in 26 | Printf.printf "%f\n%!" r; 27 | let r = sqrt (-1.0) in 28 | Printf.printf "%f\n" r) 29 | (function 30 | | Invalid_argument -> Printf.printf "Invalid_argument to sqrt\n" 31 | | _ -> ()) 32 | 33 | (* Prints: 34 | 6.513064 35 | Invalid_argument to sqrt *) 36 | -------------------------------------------------------------------------------- /sources/solved/fringe.ml: -------------------------------------------------------------------------------- 1 | (* Same Fringe Problem 2 | 3 | Definition: Two binary trees have the same fringe if they have exactly 4 | the same leaves reading from left to right. 5 | 6 | Problem: Given two binary trees decide whether they have the same fringe. 7 | *) 8 | 9 | type ('elt,'cont) iterator = ('elt -> unit) -> 'cont -> unit 10 | 11 | type 'elt generator = unit -> 'elt option 12 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 13 | let open Effect in 14 | let open Effect.Shallow in 15 | let module M = struct 16 | type _ Effect.t += 17 | Yield : elt -> unit Effect.t 18 | 19 | type ('a, 'b) status = 20 | NotStarted 21 | | InProgress of ('a,'b) continuation 22 | | Finished 23 | end 24 | in 25 | let open M in 26 | let yield v = perform (Yield v) in 27 | let curr_status = ref NotStarted in 28 | let rec helper () = 29 | match !curr_status with 30 | | Finished -> None 31 | | NotStarted -> 32 | curr_status := InProgress (fiber (fun () -> i yield c)); 33 | helper () 34 | | InProgress k -> 35 | continue_with k () 36 | { retc = (fun _ -> 37 | curr_status := Finished; 38 | helper ()); 39 | exnc = (fun e -> raise e); 40 | effc = (fun (type b) (eff: b Effect.t) -> 41 | match eff with 42 | | Yield x -> Some (fun (k: (b,_) continuation) -> 43 | curr_status := InProgress k; 44 | Some x 45 | ) 46 | | _ -> None)} 47 | in 48 | helper 49 | 50 | type 'a tree = 51 | | Leaf of 'a 52 | | Node of 'a tree * 'a tree 53 | 54 | let rec iter f = function 55 | | Leaf v -> f v 56 | | Node (l,r) -> iter f l; iter f r 57 | 58 | let same_fringe t1 t2 = 59 | let gen_tree = generate iter in 60 | let g1 = gen_tree t1 in 61 | let g2 = gen_tree t2 in 62 | let rec loop () = 63 | match g1 (), g2 () with 64 | | None, None -> true 65 | | Some v1, Some v2 when v1 = v2 -> loop () 66 | | _ -> false 67 | in 68 | loop () 69 | 70 | let t1 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 71 | let t2 = Node (Node (Leaf 1, Leaf 2), Leaf 3) 72 | let t3 = Node (Node (Leaf 3, Leaf 2), Leaf 1) 73 | let t4 = Leaf 42 74 | let t5 = Leaf 41 75 | let t6 = Node (Leaf 1, Leaf 2) 76 | let t7 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 77 | ;; 78 | 79 | assert (same_fringe t1 t2);; 80 | assert (same_fringe t2 t1);; 81 | assert (not (same_fringe t1 t3));; 82 | assert (same_fringe t1 t7);; 83 | assert (same_fringe t2 t7);; 84 | -------------------------------------------------------------------------------- /sources/solved/generator.ml: -------------------------------------------------------------------------------- 1 | type ('elt,'container) iterator = ('elt -> unit) -> 'container -> unit 2 | 3 | type 'elt generator = unit -> 'elt option 4 | 5 | (* Original solution *) 6 | (* let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = *) 7 | (* let module M = struct effect Yield : elt -> unit end in *) 8 | (* let open M in *) 9 | (* let rec step = ref (fun () -> *) 10 | (* i (fun v -> perform (Yield v)) c; *) 11 | (* step := (fun () -> None); *) 12 | (* None) *) 13 | (* in *) 14 | (* let loop () = *) 15 | (* try !step () with *) 16 | (* | effect (Yield v) k -> (step := continue k; Some v) *) 17 | (* in *) 18 | (* loop *) 19 | 20 | (* My solution *) 21 | (* Might be able to do something with a deep handler instead *) 22 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 23 | let open Effect in 24 | let open Effect.Shallow in 25 | let module M = struct 26 | type _ Effect.t += 27 | Yield : elt -> unit Effect.t 28 | 29 | type ('a, 'b) status = 30 | NotStarted 31 | | InProgress of ('a,'b) continuation 32 | | Finished 33 | end 34 | in 35 | let open M in 36 | let yield v = perform (Yield v) in 37 | let curr_status = ref NotStarted in 38 | let rec helper () = 39 | match !curr_status with 40 | | Finished -> None 41 | | NotStarted -> 42 | curr_status := InProgress (fiber (fun () -> i yield c)); 43 | helper () 44 | | InProgress k -> 45 | continue_with k () 46 | { retc = (fun _ -> 47 | curr_status := Finished; 48 | helper ()); 49 | exnc = (fun e -> raise e); 50 | effc = (fun (type b) (eff: b Effect.t) -> 51 | match eff with 52 | | Yield x -> Some (fun (k: (b,_) continuation) -> 53 | curr_status := InProgress k; 54 | Some x 55 | ) 56 | | _ -> None)} 57 | in 58 | helper 59 | 60 | (* 61 | * helper : unit -> elt option 62 | * i : (elt -> unit) -> container -> unit 63 | * continue_with k () 64 | * { 65 | 66 | * 67 | * *) 68 | 69 | (***********************) 70 | (* Traversal generator *) 71 | (***********************) 72 | 73 | let gen_list : 'a list -> 'a generator = generate List.iter 74 | let gl : int generator = gen_list [1;2;3] 75 | ;; 76 | 77 | assert (Some 1 = gl ());; 78 | assert (Some 2 = gl ());; 79 | assert (Some 3 = gl ());; 80 | assert (None = gl ());; 81 | assert (None = gl ());; 82 | 83 | let gen_array : 'a array -> 'a generator = generate Array.iter 84 | let ga : float generator = gen_array [| 1.0; 2.0; 3.0 |] 85 | ;; 86 | 87 | 88 | assert (Some 1.0 = ga ());; 89 | assert (Some 2.0 = ga ());; 90 | assert (Some 3.0 = ga ());; 91 | assert (None = ga ());; 92 | assert (None = ga ());; 93 | 94 | (***********) 95 | (* Streams *) 96 | (***********) 97 | 98 | (* Iterator over nats. Dummy () container. *) 99 | let rec nats : int (* init *) -> (int, unit) iterator = 100 | fun v f () -> 101 | f v; nats (v+1) f () 102 | 103 | (* Infinite stream *) 104 | type 'a stream = unit -> 'a 105 | 106 | (* Convert generator to an infinite stream *) 107 | let inf : 'a generator -> 'a stream = 108 | fun g () -> 109 | match g () with 110 | | Some n -> n 111 | | _ -> assert false 112 | 113 | (* Nat stream *) 114 | let gen_nats : int stream = inf (generate (nats 0) ()) 115 | ;; 116 | 117 | assert (0 = gen_nats ());; 118 | assert (1 = gen_nats ());; 119 | assert (2 = gen_nats ());; 120 | assert (3 = gen_nats ());; 121 | 122 | (* filter stream *) 123 | let rec filter : 'a stream -> ('a -> bool) -> 'a stream = 124 | fun g p () -> 125 | let v = g () in 126 | if p v then v 127 | else filter g p () 128 | 129 | (* map stream *) 130 | let rec map : 'a stream -> ('a -> 'b) -> 'b stream = 131 | fun g f () -> f (g ()) 132 | 133 | (* Even stream *) 134 | let gen_even : int stream = 135 | let nat_stream = inf (generate (nats 0) ()) in 136 | filter nat_stream (fun n -> n mod 2 = 0) 137 | ;; 138 | 139 | assert (0 = gen_even ());; 140 | assert (2 = gen_even ());; 141 | assert (4 = gen_even ());; 142 | assert (6 = gen_even ());; 143 | 144 | (* Odd stream *) 145 | let gen_odd : int stream = 146 | let nat_stream = inf (generate (nats 1) ()) in 147 | filter nat_stream (fun n -> n mod 2 == 1) 148 | ;; 149 | 150 | 151 | assert (1 = gen_odd ());; 152 | assert (3 = gen_odd ());; 153 | assert (5 = gen_odd ());; 154 | assert (7 = gen_odd ());; 155 | 156 | (* Primes using sieve of Eratosthenes *) 157 | let gen_primes = 158 | let s = inf (generate (nats 2) ()) in 159 | let rs = ref s in 160 | fun () -> 161 | let s = !rs in 162 | let prime = s () in 163 | rs := filter s (fun n -> n mod prime != 0); 164 | prime 165 | ;; 166 | 167 | assert ( 2 = gen_primes ());; 168 | assert ( 3 = gen_primes ());; 169 | assert ( 5 = gen_primes ());; 170 | assert ( 7 = gen_primes ());; 171 | assert (11 = gen_primes ());; 172 | assert (13 = gen_primes ());; 173 | assert (17 = gen_primes ());; 174 | assert (19 = gen_primes ());; 175 | assert (23 = gen_primes ());; 176 | assert (29 = gen_primes ());; 177 | assert (31 = gen_primes ());; 178 | -------------------------------------------------------------------------------- /sources/solved/myfringe.ml: -------------------------------------------------------------------------------- 1 | (* Same Fringe Problem 2 | 3 | Definition: Two binary trees have the same fringe if they have exactly 4 | the same leaves reading from left to right. 5 | 6 | Problem: Given two binary trees decide whether they have the same fringe. 7 | *) 8 | 9 | type ('elt,'cont) iterator = ('elt -> unit) -> 'cont -> unit 10 | 11 | type 'elt generator = unit -> 'elt option 12 | 13 | let generate (type elt) (i : (elt, 'container) iterator) (c : 'container) : elt generator = 14 | let open Effect in 15 | let open Effect.Shallow in 16 | let module M = struct 17 | type _ Effect.t += 18 | Yield : elt -> unit Effect.t 19 | 20 | type ('a, 'b) status = 21 | NotStarted 22 | | InProgress of ('a,'b) continuation 23 | | Finished 24 | end 25 | in 26 | let open M in 27 | let yield v = perform (Yield v) in 28 | let curr_status = ref NotStarted in 29 | let rec helper () = 30 | match !curr_status with 31 | | Finished -> None 32 | | NotStarted -> 33 | curr_status := InProgress (fiber (fun () -> i yield c)); 34 | helper () 35 | | InProgress k -> 36 | continue_with k () 37 | { retc = (fun _ -> 38 | curr_status := Finished; 39 | helper ()); 40 | exnc = (fun e -> raise e); 41 | effc = (fun (type b) (eff: b Effect.t) -> 42 | match eff with 43 | | Yield x -> Some (fun (k: (b,_) continuation) -> 44 | curr_status := InProgress k; 45 | Some x 46 | ) 47 | | _ -> None)} 48 | in 49 | helper 50 | 51 | type 'a tree = 52 | | Leaf of 'a 53 | | Node of 'a tree * 'a tree 54 | 55 | let rec tree_iter f x = 56 | match x with 57 | | Leaf v -> f v 58 | | Node (left, right) -> tree_iter f left; tree_iter f right 59 | 60 | let same_fringe t1 t2 = 61 | let t1g = generate tree_iter t1 in 62 | let t2g = generate tree_iter t2 in 63 | let rec check () = 64 | let x = t1g () in 65 | let y = t2g () in 66 | match (x,y) with 67 | | (Some a, Some b) -> a == b && check () 68 | | (None,None) -> true 69 | | _ -> false 70 | in 71 | check () 72 | 73 | let t1 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 74 | let t2 = Node (Node (Leaf 1, Leaf 2), Leaf 3) 75 | let t3 = Node (Node (Leaf 3, Leaf 2), Leaf 1) 76 | let t4 = Leaf 42 77 | let t5 = Leaf 41 78 | let t6 = Node (Leaf 1, Leaf 2) 79 | let t7 = Node (Leaf 1, Node (Leaf 2, Leaf 3)) 80 | ;; 81 | 82 | assert (same_fringe t1 t2);; 83 | assert (same_fringe t2 t1);; 84 | assert (not (same_fringe t1 t3));; 85 | assert (same_fringe t1 t7);; 86 | assert (same_fringe t2 t7);; 87 | -------------------------------------------------------------------------------- /sources/solved/state2.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Shallow 4 | 5 | module type STATE = sig 6 | type t 7 | val put : t -> unit 8 | val get : unit -> t 9 | val history : unit -> t list 10 | val run : (unit -> unit) -> init:t -> unit 11 | end 12 | 13 | module State (S : sig type t end) : STATE with type t = S.t = struct 14 | 15 | type t = S.t 16 | 17 | type _ Effect.t += Get : t Effect.t 18 | | Put : t -> unit Effect.t 19 | | History : t list Effect.t 20 | 21 | let get () = perform Get 22 | 23 | let put v = perform (Put v) 24 | 25 | let history () = perform History 26 | 27 | let run f ~init = 28 | let rec loop : type a r. t -> t list -> (a, r) continuation -> a -> r = 29 | fun init state k x -> 30 | continue_with k x 31 | { retc = (fun result -> result); 32 | exnc = (fun e -> raise e); 33 | effc = (fun (type b) (eff: b Effect.t) -> 34 | match eff with 35 | | Get -> Some (fun (k: (b,r) continuation) -> 36 | 37 | loop init state k (match state with 38 | | [] -> init 39 | | _ -> List.hd state 40 | )) 41 | | Put v -> Some (fun (k: (b,r) continuation) -> 42 | let new_state = v::state in 43 | loop init new_state k ()) 44 | | History -> Some (fun (k: (b,r) continuation) -> 45 | (* Most recent value is stored at head 46 | * of list, so reverse it to get history in proper order *) 47 | let result = List.rev state in 48 | loop init state k result) 49 | | _ -> None) 50 | } 51 | in 52 | loop init [] (fiber f) () 53 | end 54 | 55 | module IS = State (struct type t = int end) 56 | module SS = State (struct type t = string end) 57 | 58 | let foo () : unit = 59 | assert (0 = IS.get ()); 60 | IS.put 42; 61 | assert (42 = IS.get ()); 62 | IS.put 21; 63 | assert (21 = IS.get ()); 64 | SS.put "hello"; 65 | assert ("hello" = SS.get ()); 66 | SS.put "world"; 67 | assert ("world" = SS.get ()); 68 | assert ([42; 21] = IS.history ()); 69 | IS.put 86; 70 | assert (86 = IS.get ()); 71 | assert ([42;21;86] = IS.history ()) 72 | 73 | let _ = IS.run (fun () -> SS.run foo ~init:"") ~init:0 74 | -------------------------------------------------------------------------------- /sources/state1.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Shallow 4 | 5 | module type STATE = sig 6 | type t 7 | val get : unit -> t 8 | val run : (unit -> unit) -> init:t -> unit 9 | end 10 | 11 | module State (S : sig type t end) : STATE with type t = S.t = struct 12 | 13 | type t = S.t 14 | 15 | type _ Effect.t += Get : t Effect.t 16 | 17 | let get () = perform Get 18 | 19 | let run f ~init = 20 | let rec loop : type a r. t -> (a, r) continuation -> a -> r = 21 | fun state k x -> 22 | continue_with k x 23 | { retc = (fun result -> result); 24 | exnc = (fun e -> raise e); 25 | effc = (fun (type b) (eff: b Effect.t) -> 26 | match eff with 27 | | Get -> Some (fun (k: (b,r) continuation) -> 28 | loop state k state) 29 | | _ -> None) 30 | } 31 | in 32 | loop init (fiber f) () 33 | end 34 | 35 | module IS = State (struct type t = int end) 36 | module SS = State (struct type t = string end) 37 | 38 | let foo () : unit = 39 | printf "%d\n" (IS.get ()); 40 | printf "%d\n" (IS.get ()); 41 | printf "%d\n" (IS.get ()); 42 | printf "%s\n" (SS.get ()); 43 | printf "%s\n" (SS.get ()) 44 | 45 | let _ = IS.run (fun () -> SS.run foo ~init:"forty two") ~init:42 46 | -------------------------------------------------------------------------------- /sources/state2.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Effect 3 | open Effect.Shallow 4 | 5 | module type STATE = sig 6 | type t 7 | val put : t -> unit 8 | val get : unit -> t 9 | val history : unit -> t list 10 | val run : (unit -> unit) -> init:t -> unit 11 | end 12 | 13 | module State (S : sig type t end) : STATE with type t = S.t = struct 14 | 15 | type t = S.t 16 | 17 | type _ Effect.t += Get : t Effect.t 18 | 19 | let get () = perform Get 20 | 21 | let put v = failwith "not implemented" 22 | 23 | let history () = failwith "not implemented" 24 | 25 | let run f ~init = 26 | 27 | let rec loop : type a r. t -> (a, r) continuation -> a -> r = 28 | fun state k x -> 29 | continue_with k x 30 | { retc = (fun result -> result); 31 | exnc = (fun e -> raise e); 32 | effc = (fun (type b) (eff: b Effect.t) -> 33 | match eff with 34 | | Get -> Some (fun (k: (b,r) continuation) -> 35 | failwith "not implemented") 36 | | _ -> None) 37 | } 38 | in 39 | loop init (fiber f) () 40 | end 41 | 42 | module IS = State (struct type t = int end) 43 | module SS = State (struct type t = string end) 44 | 45 | let foo () : unit = 46 | assert (0 = IS.get ()); 47 | IS.put 42; 48 | assert (42 = IS.get ()); 49 | IS.put 21; 50 | assert (21 = IS.get ()); 51 | SS.put "hello"; 52 | assert ("hello" = SS.get ()); 53 | SS.put "world"; 54 | assert ("world" = SS.get ()); 55 | assert ([42; 21] = IS.history ()) 56 | 57 | let _ = IS.run (fun () -> SS.run foo ~init:"") ~init:0 58 | --------------------------------------------------------------------------------