Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Experiments in using multicore OCaml effects to simulate dynamically created local effects.
(** * General support for creation of dynamic effects *)
(** We show how to use the multicore Ocaml effects to dynamically generate local
effects. Such effects are akin to the Eff resources, and they can be used to
implement ML references.
The code is based on "Eff directly in OCaml" by Oleg Kiselyov and KC
Sivaramakrishnan (http://kcsrk.info/papers/caml-eff17.pdf). It was written by
Andrej Bauer, Oleg Kiselyov, and Stephen Dolan at the Dagstuhl seminar
"Algebraic Effect Handlers go Mainstream". *)
(** A _resource_ is an instance of an effect that is handled at the top level in
a specific fashion. It looks a lot like an effect with a "default" handler,
although it is not (for reasons explained in some talk). Resources can be
dynamically created at will, with no bound on their number (so they are _not_
the lift/inject thing).
We show here how to simulate resources in multicore OCaml, using the
generative features of first-class modules. *)
(** A resource handler takes a computation [unit -> 'a] and handles it, without
changing its type. *)
type resource_handler = { hand : 'a . ((unit -> 'a) -> 'a) }
(** An effect for installing a new resource handler. *)
effect Install : resource_handler -> unit
(** The handler for [Install]. Multicore OCaml does not have first-class
handlers (why?), so we simulate it as a function which accepts a thunked
computation and handles it. The handler is a lot like the delimited-control
reset handler. *)
let handle_new computation =
try
computation ()
with
| effect (Install {hand}) k -> hand (fun x -> continue k x)
(** This completes the generalities. Below we will install the [handle_new] just
once, on the outside of the main program. (That is, we need _not_ install any
new handlers when we introduce new local effects.)
We demonstrate two examples: ML-style references and clocks.
Both of these are state-like effects that behave like Eff resources. Thus
they are well-behaved. It's possible to also implement other kinds of local
effects (because unlike Eff resources we have access to the continuation
here), for instance backtracking. That sounds pretty scary.
*)
(** ** Example: local state *)
(** Our first example is ML-style references. In order to avoid naming conflicts
with OCaml, we call them "cells". *)
(** The signature which describes what it means to have state. The handler is
parametrized by the initial value of the state. *)
module type STATE = sig
type t
effect Get : t
effect Put : t -> unit
val handler : t -> resource_handler
end
(** We implement state in the standard way. *)
module State (T : sig type t end) : STATE with type t = T.t =
struct
type t = T.t
effect Get : t
effect Put : t -> unit
let handler x =
{ hand = (fun computation ->
(match computation () with
| v -> (fun _ -> v)
| effect Get k -> (fun (s : t) -> (continue k s) s)
| effect (Put s) k -> (fun _ -> (continue k ()) s)
) x)
}
end
(** Now we *localize* the state effect. First we define _instances_ of the local
state effect, which we call _cells_ to avoid naming conflicts with OCaml. *)
(** An instance of an effect is just the module for that effect *)
type 'a cell = (module STATE with type t = 'a)
(** Convenience access functions *)
let get (type a) ((module C) : a cell) = (perform C.Get)
let put (type a) ((module C) : a cell) x = (perform (C.Put x))
(** The function [new_cell x] creates a new instance of state initialized to
[x], and installs a handler for it. Notice that it is polymorphic in the type
of the state. *)
let new_cell (type a) (x : a) : a cell =
let module Local = State (struct type t = a end) in
perform (Install (Local.handler x)) ;
(module Local)
(** ** Example: clock *)
(** The second example is just a simple clock which starts at [0]. The clock
keeps [Time] and progresses with every [Tick]. *)
module type CLOCK =
sig
effect Tick : unit
effect Time : int
val handler : resource_handler
end
(** A functor which creates a clock effect *)
module WatchMaker () : CLOCK =
struct
effect Tick : unit
effect Time : int
let handler =
{ hand = (fun computation ->
(match computation () with
| v -> (fun _ -> v)
| effect Tick k -> (fun c -> (continue k ()) (c + 1))
| effect Time k -> (fun c -> (continue k c) c)
) 0)
}
end
(** Again, instance of an effect is just the module for that effect *)
type clock = (module CLOCK)
(** Convenience access functions *)
let tick (type a) ((module C) : clock) = (perform C.Tick)
let time (type a) ((module C) : clock) = (perform C.Time)
(** The function [new_clock] creates a new instance of a clock. It is essentially
the same as the one for cells, except that it is not polymorphic. *)
let new_clock () : clock =
let module Local = WatchMaker () in
perform (Install Local.handler) ;
(module Local)
(** ** Demo *)
(** The main demonstrates demonstrates the use of cells and clock. *)
let main =
(** We only ever need one handle_new at the top level. It takes care of all
resources of all types. If somehow an instance escapes this handler, it
will go unhandled. *)
handle_new begin fun () ->
(** Testing cells: *)
begin
let x = new_cell 10 in
put x (4 + get x) ;
let y = new_cell 3 in
put y (get x * get y) ;
Format.printf "y = %d@." (get y)
end ;
(** We can create any number of cells: *)
begin
let rec many_cells = function
| 0 -> []
| n -> (new_cell n) :: many_cells (n - 1)
in
(** A list of 100 cells *)
let xs = many_cells 100 in
(** Double every cell *)
List.iter (fun r -> put r (2 * get r)) xs ;
(** Sum them up *)
let s = List.fold_left (fun a r -> a + get r) 0 xs in
Format.printf "s = %d@." s
end ;
(** The cells are and higher-order: *)
begin
let x = new_cell 42 in
let y = new_cell "foo" in
let z = new_cell (fun x -> let r = new_cell [x] in get r @ get r) in
let w = new_cell [] in (* of type '_a list cell *)
let _ = (get x, get y, get z [2], get w) in
Format.printf "something happened@."
end ;
(** Do we get a polymorphic function in the following case? *)
begin
let f x = get (new_cell x) in
let a = f 42 in
let b = f "foo" in
Format.printf "a = %d, b = %s@." a b
end ;
(** By performing a little dance around the OCaml module system,
we can handle resources. They can be intercepted! *)
begin
(** A handler which intercepts [Get]. *)
let always_42 (module S : STATE with type t = int) computation =
try
computation ()
with
| effect S.Get k -> continue k 42
in
let x = new_cell 10 in
Format.printf "1. non-intercepted x = %d@." (get x) ;
(** Now we handle the instance [x] with the [always_42] handler *)
always_42 x (fun () ->
Format.printf "1. intercepted x = %d@." (get x) ;
put x 17 ; (** Did it _really_ change? *)
Format.printf "2. intercepted x = %d@." (get x)
) ;
(** Puzzle: what is the value of [x]? *)
Format.printf "2. non-intercepted x = %d@." (get x)
end ;
(** And finally, here are some clocks. To make life interesting we count how
many recursive calls are performed when we compute a Fibonacci number the
wrong way. *)
begin
let leonardo = new_clock () in
let rec fibonacci n =
tick leonardo ;
match n with
| 0 -> 0
| 1 -> 1
| n -> fibonacci (n - 1) + fibonacci (n - 2)
in
let x = fibonacci 8 in
let t = time leonardo in
Format.printf "fibonacci 8 = %d (with %d recursive calls so far)@." x t ;
(** the clock is cummulative *)
let x = fibonacci 8 in
let t = time leonardo in
Format.printf "fibonacci 8 = %d (with %d recursive calls so far)@." x t
end
end (* main *)
(** * Resource management with guaranteed finalization *)
(**
Multicore OCaml requires that an effect continuation be used exactly once.
A second activation of a continuation is a run-time error.
If a handler wants to dicard a continuation, it must do so explicitly
with the [discontinue k exn] construction which reactivates [k] by
triggering the exception [exn] in it. This way the continuation [k]
gets a chance to clean up its resources.
Using this discipline, we can create a generic [with] handler that
guarantees finalization of all resources.
*)
(** We consider handlers that do not change the type of the computation. *)
type with_handler = { wither : 'a . (unit -> 'a) -> 'a }
(** A finalizing effect is one that has a [Finalize] operation. *)
module type FINALIZING =
sig
effect Finalize : unit
val handler : with_handler
end
(** A handler for handling a finalizing resource that makes sure that
the resource will be finalized. *)
let with_resource (module R : FINALIZING) computation =
R.handler.wither
(fun () ->
try
computation ()
with
| exn -> perform R.Finalize ; raise exn)
(** As an example we show how to implement buffered output channels. *)
module type CHANNEL =
sig
include FINALIZING
effect Write : string -> unit
effect Flush : unit
end
(** A channel value is just a channel module *)
type channel = (module CHANNEL)
(** Convenience functions for channels *)
let write (module C : CHANNEL) msg = perform (C.Write msg)
let flush (module C : CHANNEL) = perform C.Flush
let close (module C : CHANNEL) = perform C.Finalize
(** A buffered string printer *)
module BufferedPrinter () : CHANNEL =
struct
effect Write : string -> unit
effect Flush : unit
effect Finalize : unit
type buffer =
| Closed
| Buffered of string list
let rec flush = function
| [] -> ()
| msg :: msgs -> flush msgs ; Format.printf "%s@." msg
let handler =
{ wither = fun computation ->
(match
computation ()
with
| v ->
(function
| Closed -> v
| Buffered msgs -> flush msgs ; v)
| effect (Write msg) k ->
(function
| Closed -> discontinue k (Failure "cannot write on a closed channel") Closed
| Buffered msgs -> continue k () (Buffered (msg :: msgs)))
| effect Flush k ->
(function
| Closed -> discontinue k (Failure "cannot flush a closed channel") Closed
| Buffered msgs -> flush msgs ; continue k () (Buffered []))
| effect Finalize k ->
(function
| Closed -> discontinue k (Failure "cannot close a closed channel") Closed
| Buffered msgs -> flush msgs ; continue k () Closed)
) (Buffered [])
}
end
let new_printer () : channel =
let module Local = BufferedPrinter () in
(module Local : CHANNEL)
let main =
(** Here we have a minor OCaml ugliness, it would be better if we could
use only the value [p] throughout. The [with_resource] will make sure
that everything up to the exception is printed out, even though it
has not been explicitly flushed. *)
let ((module P) as p) = new_printer () in
with_resource (module P)
begin fun () ->
write p "1 Od nékdej lepé so Ljubljanke slovele," ;
write p "2 al lepši od Urške bilo ni nobene," ;
flush p ; (** flush lines 1 and 2 *)
write p "3 nobene očem bilo bolj zaželene" ;
write p "4 ob času nje cvetja dekleta ne žene. -" ;
write p "5 Ko nárbolj iz zvezd je danica svetla," ;
raise Not_found ; (** lines 3, 4, 5 are not flushed, but will be finalized *)
write p "6 narlepši iz deklic je Urška bila." (** we never get here, not printed *)
end
@bracevac

This comment has been minimized.

Copy link

commented May 2, 2018

Hi, how about putting these examples into the rosetta stone?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.