diff --git a/multishot/dune b/multishot/dune index b4becc8..2842d67 100644 --- a/multishot/dune +++ b/multishot/dune @@ -27,3 +27,8 @@ (names delimcc) (modules delimcc) (libraries multicont)) + +(executables + (names dynamic_state) + (modules dynamic_state) + (libraries multicont)) diff --git a/dynamic_state.ml b/multishot/dynamic_state.ml similarity index 52% rename from dynamic_state.ml rename to multishot/dynamic_state.ml index d438601..3293406 100644 --- a/dynamic_state.ml +++ b/multishot/dynamic_state.ml @@ -4,21 +4,24 @@ types, without needing some kind of universal type or dynamic type checking. *) +open Effect +open Effect.Deep + module type Type = sig type t end module Int = struct type t = int let compare = compare end module LocalState (R : sig type t end) = struct type reff = R.t - effect New : int -> R.t - effect Get : R.t -> int - effect Put : R.t * int -> unit + type _ Effect.t += New : int -> R.t Effect.t + type _ Effect.t += Get : R.t -> int Effect.t + type _ Effect.t += Put : R.t * int -> unit Effect.t end module type StateOps = sig - type rEffect.t - effect New : int -> rEffect.t - effect Get : reff -> int - effect Put : reff * int -> unit + type reff + type _ Effect.t += New : int -> reff Effect.t + type _ Effect.t += Get : reff -> int Effect.t + type _ Effect.t += Put : reff * int -> unit Effect.t end (**********************************************************************) @@ -27,18 +30,25 @@ end the 'New', 'Get' and 'Put' effects. *) let run main = - let module S = LocalState (Int) in + let module S = LocalState (Int) in let module IM = Map.Make (Int) in let comp = - match main (module Int : Type) with - | effect (S.New i) k -> - fun s -> let r = fst (IM.max_binding s) + 1 - in continue k r (IM.add r i s) - | effect (S.Get r) k -> - fun s -> continue k (IM.find r s) s - | effect (S.Put (r, i)) k -> - fun s -> continue k () (IM.add r i s) - | x -> fun s -> x + match_with main (module Int : Type) + { + retc = (fun s _ -> s); + exnc = (fun e -> raise e); + effc = (fun (type a) (e: a Effect.t) -> + match e with + | S.Put (r, i) -> Some (fun (k : (a,_) continuation) -> (fun s -> + continue k () (IM.add r i s))) + | S.Get r -> Some (fun (k: (a,_) continuation) -> (fun s -> continue k (IM.find r s) s)) + | S.New i -> Some (fun (k: (a, _) continuation) -> (fun s -> + let r = fst (IM.max_binding s) + 1 + in continue k r (IM.add r i s) + )) + | _ -> None + ) + } in comp IM.empty @@ -51,21 +61,26 @@ let main (module T : Type) = (**********************************************************************) (* version 2 : working creation of freshly generated state cells, but only an int type. *) - let run2 main = let module S = LocalState (Int) in let module IM = Map.Make (Int) in let comp = - match main (module S : StateOps) with - | effect (S.New i) k -> - fun s -> - let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1 - in continue k r (IM.add r i s) - | effect (S.Get r) k -> - fun s -> continue k (IM.find r s) s - | effect (S.Put (r, i)) k -> - fun s -> continue k () (IM.add r i s) - | x -> fun s -> x + match_with main (module S : StateOps) + { + retc = (fun s _ -> s); + exnc = (fun e -> raise e); + effc = (fun (type a) (e: a Effect.t) -> + match e with + | S.Put (r, i) -> Some (fun (k : (a,_) continuation) -> (fun s -> + continue k () (IM.add r i s))) + | S.Get r -> Some (fun (k: (a,_) continuation) -> (fun s -> continue k (IM.find r s) s)) + | S.New i -> Some (fun (k: (a,_) continuation) -> (fun s -> + let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1 + in continue k r (IM.add r i s) + )) + | _ -> None + ) + } in comp IM.empty @@ -80,38 +95,42 @@ let main2 (module S : StateOps) = handlers. Similar to the example in "state.ml". *) module type GetPutOps = sig type t - effect Get : t - effect Put : t -> unit + type _ Effect.t += Get : t Effect.t + type _ Effect.t += Put : t -> unit Effect.t end module MakeGetPut (T : sig type t end) () = struct type t = T.t - effect Get : t - effect Put : t -> unit + type _ Effect.t += Get : t Effect.t + type _ Effect.t += Put : t -> unit Effect.t end let run3 (type a) (module S : GetPutOps with type t = a) (s : a) main = let module IM = Map.Make (Int) in let comp = - match main () with - | effect S.Get k -> - fun (s : S.t) -> continue k s s - | effect (S.Put i) k -> - fun s -> continue k () i - | x -> fun s -> x + match_with main () + { + retc = (fun s _ -> s); + exnc = (fun e -> raise e); + effc = (fun (type a) (e: a Effect.t) -> + match e with + | S.Get -> Some (fun (k : (a,_) continuation) -> (fun (s : S.t) -> continue k s s)) + | S.Put i -> Some (fun (k : (a,_) continuation) -> (fun s -> continue k () i)) + | _ -> None + ) + } in comp s module S1 = MakeGetPut (struct type t = int end) () module S2 = MakeGetPut (struct type t = string end) () -let test3 () = +let test3 () : string = perform (S1.Put 5); let x = perform (S1.Get) in perform (S2.Put (string_of_int x ^ "xx")); perform S2.Get - (**********************************************************************) (* version 4. Uses dynamic creation of new effect names to simulate the creation of new reference cells. Initially, there is only one @@ -136,27 +155,41 @@ let test3 () = continuations. *) type 'a reff = < get : 'a; put : 'a -> unit; internals : (module GetPutOps with type t = 'a) > -effect New : 'a -> 'a rEffect.t -effect Choice : bool +type _ Effect.t += New : 'a -> 'a reff t +type _ Effect.t += Choice : bool t let run4 main = let donew : type a b. (a reff, b) continuation -> a -> b = fun k -> - let module Ops = MakeGetPut (struct type t = a end) () in - let cell = object - method get = perform Ops.Get - method put x = perform (Ops.Put x) - method internals = (module Ops : GetPutOps with type t = a) - end - in - match continue k cell with - | effect Ops.Get k -> fun s -> continue k s s - | effect (Ops.Put v) k -> fun s -> continue k () v - | x -> fun s -> x + let module Ops = MakeGetPut (struct type t = a end) () in + let cell = object + method get = perform Ops.Get + method put x = perform (Ops.Put x) + method internals = (module Ops : GetPutOps with type t = a) + end + in + match_with (continue k) cell + { + retc = (fun s _ -> s); + exnc = (fun e -> raise e); + effc = (fun (type c) (e: c t) -> + match e with + | Ops.Put v -> Some (fun (k : (c,_) continuation) -> (fun _ -> continue k () v)) + | Ops.Get -> Some (fun (k : (c,_) continuation) -> (fun (s : a) -> continue k s s)) + | _ -> None + ) + } in - match main () with - | effect (New v) k -> donew k v - | effect (Choice) k -> let k' = Obj.clone_continuation k in continue k true; continue k' false - | x -> x + try_with main () { + effc = (fun (type a) (e: a t) -> + match e with + | New v -> Some (fun (k : (a,_) continuation) -> donew k v) + | Choice -> Some (fun (k : (a,_) continuation) -> + let k' = Multicont.Deep.clone_continuation k in + continue k true; + continue k' false) + | _ -> None + ) + } let newref i = perform (New i)