Skip to content

Commit 78cf6f6

Browse files
avsmavsm
committed
bring back the effect syntax
Also fix the dynamic_state example which was disabled previously and hook it back into the Makefile
1 parent b7f805b commit 78cf6f6

20 files changed

Lines changed: 171 additions & 240 deletions

‎Makefile‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
EXE := concurrent.exe ref.exe transaction.exe echo.exe \
22
dyn_wind.exe generator.exe promises.exe reify_reflect.exe \
33
MVar_test.exe chameneos.exe eratosthenes.exe pipes.exe loop.exe \
4-
fringe.exe algorithmic_differentiation.exe
4+
fringe.exe algorithmic_differentiation.exe dynamic_state.exe
55

66
all: $(EXE)
77

‎algorithmic_differentiation.ml‎

Lines changed: 16 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -16,29 +16,24 @@ end = struct
1616

1717
let mk v = {v; d = 0.0}
1818

19-
type _ Effect.t += Add : t * t -> t Effect.t
20-
type _ Effect.t += Mult : t * t -> t Effect.t
19+
effect Add : t * t -> t
20+
effect Mult : t * t -> t
2121

2222
let run f =
23-
ignore (match_with f () {
24-
retc = (fun r -> r.d <- 1.0; r);
25-
exnc = raise;
26-
effc = fun (type a) (e : a Effect.t) ->
27-
match e with
28-
| Add (a, b) -> Some (fun (k : (a, _) continuation) ->
29-
let x = {v = a.v +. b.v; d = 0.0} in
30-
ignore (continue k x);
31-
a.d <- a.d +. x.d;
32-
b.d <- b.d +. x.d;
33-
x)
34-
| Mult(a,b) -> Some (fun k ->
35-
let x = {v = a.v *. b.v; d = 0.0} in
36-
ignore (continue k x);
37-
a.d <- a.d +. (b.v *. x.d);
38-
b.d <- b.d +. (a.v *. x.d);
39-
x)
40-
| _ -> None
41-
})
23+
ignore (match f () with
24+
| r -> r.d <- 1.0; r;
25+
| effect (Add(a,b)) k ->
26+
let x = {v = a.v +. b.v; d = 0.0} in
27+
ignore (continue k x);
28+
a.d <- a.d +. x.d;
29+
b.d <- b.d +. x.d;
30+
x
31+
| effect (Mult(a,b)) k ->
32+
let x = {v = a.v *. b.v; d = 0.0} in
33+
ignore (continue k x);
34+
a.d <- a.d +. (b.v *. x.d);
35+
b.d <- b.d +. (a.v *. x.d);
36+
x)
4237

4338
let grad f x =
4439
let x = mk x in

‎dune‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,10 @@
1818
(names dyn_wind)
1919
(modules dyn_wind))
2020

21+
(executables
22+
(names dynamic_state)
23+
(modules dynamic_state))
24+
2125
(executables
2226
(names generator)
2327
(modules generator))

‎dyn_wind.ml‎

Lines changed: 13 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -6,32 +6,27 @@ open Effect.Deep
66
let dynamic_wind before_thunk thunk after_thunk =
77
before_thunk ();
88
let res =
9-
match_with thunk () {
10-
retc = Fun.id;
11-
exnc = (fun e -> after_thunk (); raise e);
12-
effc = fun (type a) (e : a Effect.t) ->
13-
Some (fun (k : (a, _) continuation) ->
14-
after_thunk ();
15-
let res' = perform e in
16-
before_thunk ();
17-
continue k res')
18-
}
9+
match thunk () with
10+
| v -> v
11+
| exception e -> after_thunk (); raise e
12+
| effect e k ->
13+
after_thunk ();
14+
let res' = perform e in
15+
before_thunk ();
16+
continue k res'
1917
in
2018
after_thunk ();
2119
res
2220

23-
type _ Effect.t += E : unit Effect.t
21+
effect E : unit
2422

2523
let () =
2624
let bt () = Printf.printf "IN\n" in
2725
let at () = Printf.printf "OUT\n" in
2826
let foo () =
29-
Printf.printf "peform E\n"; perform E;
30-
Printf.printf "peform E\n"; perform E;
27+
Printf.printf "perform E\n"; perform E;
28+
Printf.printf "perform E\n"; perform E;
3129
Printf.printf "done\n"
3230
in
33-
try_with (dynamic_wind bt foo) at
34-
{ effc = fun (type a) (e : a Effect.t) ->
35-
match e with
36-
| E -> Some (fun (k : (a, _) continuation) -> Printf.printf "handled E\n"; continue k ())
37-
| _ -> None }
31+
try dynamic_wind bt foo at with
32+
| effect E k -> Printf.printf "handled E\n"; continue k ()

‎dynamic_state.ml‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,6 @@
1+
open Effect
2+
open Effect.Deep
3+
14
(* This file contains a collection of attempts at replicating ML-style
25
references using algebraic effects and handlers. The difficult thing
36
to do is the dynamic creation of new reference cells at arbitrary
@@ -15,8 +18,8 @@ module LocalState (R : sig type t end) = struct
1518
end
1619

1720
module type StateOps = sig
18-
type rEffect.t
19-
effect New : int -> rEffect.t
21+
type reff
22+
effect New : int -> reff
2023
effect Get : reff -> int
2124
effect Put : reff * int -> unit
2225
end
@@ -111,6 +114,7 @@ let test3 () =
111114
perform (S2.Put (string_of_int x ^ "xx"));
112115
perform S2.Get
113116

117+
(* XXX avsm: disabled pending port to multicont (uses clone_continuation)
114118
115119
(**********************************************************************)
116120
(* version 4. Uses dynamic creation of new effect names to simulate
@@ -174,3 +178,4 @@ let test4 () =
174178
end
175179
else
176180
print_endline !b
181+
*)

‎eratosthenes.ml‎

Lines changed: 18 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -12,19 +12,19 @@ let string_of_msg = function
1212
(** Process primitives **)
1313
type pid = int
1414

15-
type _ Effect.t += Spawn : (pid -> unit) -> pid Effect.t
15+
effect Spawn : (pid -> unit) -> pid
1616
let spawn p = perform (Spawn p)
1717

18-
type _ Effect.t += Yield : unit Effect.t
18+
effect Yield : unit
1919
let yield () = perform Yield
2020

2121
(** Communication primitives **)
22-
type _ Effect.t += Send : pid * message -> unit Effect.t
22+
effect Send : pid * message -> unit
2323
let send pid data =
2424
perform (Send (pid, data));
2525
yield ()
2626

27-
type _ Effect.t += Recv : pid -> message option Effect.t
27+
effect Recv : pid -> message option
2828
let rec recv pid =
2929
match perform (Recv pid) with
3030
| Some m -> m
@@ -74,17 +74,14 @@ let mailbox f =
7474
let (msg, mb) = Mailbox.pop pid !mailbox in
7575
mailbox := mb; msg
7676
in
77-
try_with f () {
78-
effc = fun (type a) (e : a Effect.t) ->
79-
match e with
80-
| (Send (pid, msg)) -> Some (fun (k : (a, _) continuation) ->
81-
mailbox := Mailbox.push pid msg !mailbox;
82-
continue k ())
83-
| (Recv who) -> Some (fun k ->
84-
let msg = lookup who in
85-
continue k msg)
86-
| _ -> None
87-
}
77+
match f () with
78+
| v -> v
79+
| effect (Send (pid, msg)) k ->
80+
mailbox := Mailbox.push pid msg !mailbox;
81+
continue k ()
82+
| effect (Recv who) k ->
83+
let msg = lookup who in
84+
continue k msg
8885

8986
(** Process handler
9087
Slightly modified version of sched.ml **)
@@ -98,17 +95,12 @@ let run main () =
9895
let pid = ref (-1) in
9996
let rec spawn f =
10097
pid := 1 + !pid;
101-
match_with f !pid {
102-
retc = (fun () -> dequeue ());
103-
exnc = (fun e -> raise e);
104-
effc = fun (type a) (e : a Effect.t) ->
105-
match e with
106-
| Yield -> Some (fun (k : (a, _) continuation) ->
107-
enqueue (fun () -> continue k ()); dequeue ())
108-
| Spawn p -> Some (fun k ->
109-
enqueue (fun () -> continue k !pid); spawn p)
110-
| _ -> None
111-
}
98+
match f !pid with
99+
| () -> dequeue ()
100+
| effect Yield k ->
101+
enqueue (fun () -> continue k ()); dequeue ()
102+
| effect (Spawn p) k ->
103+
enqueue (fun () -> continue k !pid); spawn p
112104
in
113105
spawn main
114106

‎fringe.ml‎

Lines changed: 4 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,7 @@ module SameFringe(E : EQUATABLE) = struct
2525
type nonrec tree = E.t tree
2626

2727
(* Yielding control *)
28-
type _ Effect.t += Yield : E.t -> unit Effect.t
28+
effect Yield : E.t -> unit
2929
let yield e = perform (Yield e)
3030

3131
(* The walk routine *)
@@ -41,14 +41,9 @@ module SameFringe(E : EQUATABLE) = struct
4141

4242
(* Reifies `Yield' effects *)
4343
let step f =
44-
match_with f () {
45-
retc = (fun _ -> Done);
46-
exnc = (fun e -> raise e);
47-
effc = fun (type a) (e : a Effect.t) ->
48-
match e with
49-
| Yield e -> Some (fun (k : (a, _) continuation) -> Yielded (e, k))
50-
| _ -> None
51-
}
44+
match f () with
45+
| _ -> Done
46+
| effect (Yield e) k -> Yielded (e, k)
5247

5348
(* The comparator "step walks" two given trees simultaneously *)
5449
let comparator ltree rtree =

‎generator.ml‎

Lines changed: 7 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -53,21 +53,15 @@ module Tree : TREE = struct
5353

5454
(* val to_gen : 'a t -> (unit -> 'a option) *)
5555
let to_gen (type a) (t : a t) =
56-
let module M = struct
57-
type _ Effect.t += Next : a -> unit Effect.t
58-
end in
56+
let module M = struct effect Next : a -> unit end in
5957
let open M in
6058
let rec step = ref (fun () ->
61-
try_with
62-
(fun t -> iter (fun x -> perform (Next x)) t; None)
63-
t
64-
{ effc = fun (type a) (e : a Effect.t) ->
65-
match e with
66-
| Next v ->
67-
Some (fun (k : (a, _) continuation) ->
68-
step := (fun () -> continue k ());
69-
Some v)
70-
| _ -> None })
59+
try
60+
iter (fun x -> perform (Next x)) t;
61+
None
62+
with effect (Next v) k ->
63+
step := (fun () -> continue k ());
64+
Some v)
7165
in
7266
fun () -> !step ()
7367

‎loop.ml‎

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,12 @@
11
open Effect
22
open Effect.Deep
33

4-
type _ Effect.t += Foo : (unit -> 'a) Effect.t
4+
effect Foo : (unit -> 'a)
55

66
let f () = perform Foo ()
77

88
let res : type a. a =
9-
try_with f () {
10-
effc = fun (type a) (e : a Effect.t) ->
11-
match e with
12-
| Foo -> Some (fun (k : (a, _) continuation) -> continue k (fun () -> perform Foo ()))
13-
| _ -> None
14-
}
9+
match f () with
10+
| x -> x
11+
| effect Foo k ->
12+
continue k (fun () -> perform Foo ())

‎mvar/MVar.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,8 @@ end
88

99
module type SCHED = sig
1010
type 'a cont
11-
type _ Effect.t += Suspend : ('a cont -> unit) -> 'a Effect.t
12-
type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t
11+
effect Suspend : ('a cont -> unit) -> 'a
12+
effect Resume : 'a cont * 'a -> unit
1313
end
1414

1515
module Make (S : SCHED) : S = struct

0 commit comments

Comments
 (0)