1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
open Printf
open Effect
open Effect.Deep
module type TREE = sig
type 'a t
(** The type of tree. *)
val deep : int -> int t
(** [deep n] constructs a tree of depth n, in linear time, where every node at
level [l] has value [l]. *)
val to_iter : 'a t -> ('a -> unit) -> unit
(** Iterator function. *)
val to_gen : 'a t -> unit -> 'a option
(** Generator function. [to_gen t] returns a generator function [g] for the
tree that traverses the tree in depth-first fashion, returning [Some x]
for each node when [g] is invoked. [g] returns [None] once the traversal
is complete. *)
val to_gen_cps : 'a t -> unit -> 'a option
(** CPS version of the generator function. *)
end
module Tree : TREE = struct
type 'a t =
| Leaf
| Node of 'a t * 'a * 'a t
let rec deep = function
| 0 -> Leaf
| n ->
let t = deep (n - 1) in
Node (t, n, t)
let rec iter f = function
| Leaf -> ()
| Node (l, x, r) ->
iter f l;
f x;
iter f r
(* val to_iter : 'a t -> ('a -> unit) -> unit *)
let to_iter t f = iter f t
(* val to_gen : 'a t -> (unit -> 'a option) *)
let to_gen (type a) (t : a t) =
let module M = struct
type _ Effect.t += Next : a -> unit Effect.t
end in
let open M in
let rec step =
ref (fun () ->
try_with
(fun t ->
iter (fun x -> perform (Next x)) t;
None)
t
{ effc =
(fun (type a) (e : a Effect.t) ->
match e with
| Next v ->
Some
(fun (k : (a, _) continuation) ->
(step := fun () -> continue k ());
Some v)
| _ -> None)
})
in
fun () -> !step ()
let to_gen_cps t =
let next = ref t in
let cont = ref Leaf in
let rec iter t k =
match t with
| Leaf -> run k
| Node (left, x, right) -> iter left (Node (k, x, right))
and run = function
| Leaf -> None
| Node (k, x, right) ->
next := right;
cont := k;
Some x
in
fun () -> iter !next !cont
end
let get_mean_sd l =
let get_mean l =
List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l)
in
let mean = get_mean l in
let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in
mean, sd
let benchmark f n =
let rec run acc = function
| 0 -> acc
| n ->
let t1 = Sys.time () in
let () = f () in
let d = Sys.time () -. t1 in
run (d :: acc) (n - 1)
in
let r = run [] n in
get_mean_sd r
(* Main follows *)
type _ Effect.t += Dummy : unit t [@@warning "-38"]
let () =
try_with
(fun () ->
let n = try int_of_string Sys.argv.(1) with _ -> 21 in
let t = Tree.deep n in
let iter_fun () = Tree.to_iter t (fun _ -> ()) in
let rec consume_all f =
match f () with
| None -> ()
| Some _ -> consume_all f
in
(* The code below should be called in direct style despite the installed
effect handler *)
Jsoo_runtime.Effect.assume_no_perform (fun () ->
let m, sd = benchmark iter_fun 5 in
let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in
let gen_cps_fun () =
let f = Tree.to_gen_cps t in
consume_all f
in
let m, sd = benchmark gen_cps_fun 5 in
printf "Gen_cps: mean = %f, sd = %f\n%!" m sd);
let gen_fun () =
let f = Tree.to_gen t in
consume_all f
in
let m, sd = benchmark gen_fun 5 in
printf "Gen_eff: mean = %f, sd = %f\n%!" m sd)
()
{ effc =
(fun (type a) (e : a Effect.t) ->
match e with
| Dummy -> Some (fun (k : (a, _) continuation) -> continue k ())
| _ -> None)
}
|
