From aefaa158e36cd65afa98d6b7c3f0a3d0717e13a4 Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Sun, 25 May 2014 22:38:39 +0200 Subject: Simplify protocols & stuff --- src/kahn_seq.ml | 19 ++++++++----------- src/kahn_stdio.ml | 50 ++++++++++++++++---------------------------------- src/manager.ml | 10 +++++----- src/primes.ml | 2 +- src/proto.ml | 3 ++- 5 files changed, 32 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/kahn_seq.ml b/src/kahn_seq.ml index 177d6dd..8aff905 100644 --- a/src/kahn_seq.ml +++ b/src/kahn_seq.ml @@ -1,7 +1,7 @@ open Kahn module Seq: S = struct - type 'a process = (('a -> unit) option) -> unit + type 'a process = ('a -> unit) -> unit type 'a channel = 'a Queue.t type 'a in_port = 'a channel @@ -11,10 +11,8 @@ module Seq: S = struct let tasks = Queue.create () - let push_cont (cont : ('a -> unit) option) (v : 'a) = - match cont with - | None -> () - | Some cont_f -> Queue.push (fun () -> cont_f v) tasks + let push_cont (cont : 'a -> unit) (v : 'a) = + Queue.push (fun () -> cont v) tasks let new_channel () = let q = Queue.create () in @@ -55,20 +53,19 @@ module Seq: S = struct let doco l = fun cont -> - List.iter (fun proc -> Queue.push (fun () -> proc None) tasks) l; - push_cont cont () + List.iter (fun proc -> Queue.push (fun () -> proc (fun () -> ())) tasks) l; + cont () let return v = - fun cont -> - push_cont cont v + fun cont -> cont v let bind (e : 'a process) (f : 'a -> 'b process) : 'b process = fun cont -> - e (Some (fun (r : 'a) -> f r cont)) + e (fun (r : 'a) -> f r cont) let run e = let ret = ref None in - e (Some (fun v -> ret := Some v)); + e (fun v -> ret := Some v); while not (Queue.is_empty tasks) do let task = Queue.pop tasks in task () diff --git a/src/kahn_stdio.ml b/src/kahn_stdio.ml index 1bed0a1..4c8c976 100644 --- a/src/kahn_stdio.ml +++ b/src/kahn_stdio.ml @@ -7,7 +7,7 @@ open Proto module ProtoKahn: S = struct - type 'a process = (('a -> unit) option) -> unit + type 'a process = ('a -> unit) -> unit type 'a channel = id type 'a in_port = 'a channel @@ -18,37 +18,25 @@ module ProtoKahn: S = struct let task_desc t = Marshal.to_string t [Marshal.Closures] - let send_task t is_io = - send (GiveTask(task_desc t, is_io)) + let send_task t = + send (GiveTask(task_desc t)) let new_channel () = let x = new_id() in x, x - let push_cont cont arg is_io = - match cont with - | None -> () - | Some cont -> - send_task (fun () -> cont arg) is_io - let put v prt = fun cont -> send (Put(prt, Marshal.to_string v [])); - push_cont cont () false + cont () let get prt = fun cont -> - send (Get(prt, - task_desc - (fun s -> match cont with - | None -> () - | Some cont -> cont (Marshal.from_string s 0)) - ) - ) + send (Get(prt, task_desc (fun s -> cont (Marshal.from_string s 0)))) let output s = send (Output s) - let select pl = fun cont -> assert false - let select_default = fun cont -> assert false + let select pl = assert false (* Not Implemented *) + let select_default pl = assert false (* Not Implemented *) let doco plist = fun cont -> @@ -56,26 +44,20 @@ module ProtoKahn: S = struct List.iter (fun p -> send_task - (fun () -> p - (Some (fun () -> send (Put(f_ch_id, "")))) - ) - false - ) plist; + (fun () -> p (fun () -> send (Put(f_ch_id, ""))))) + plist; let rec push_x = function - | 0 -> push_cont cont () false + | 0 -> cont () | n -> send (Get(f_ch_id, task_desc (fun s -> push_x (n-1)))) in push_x (List.length plist) let return v = - fun cont -> - match cont with - | None -> () - | Some cont -> cont v + fun cont -> cont v let bind a f = fun cont -> - a (Some (fun va -> - let b = (f va) in - b cont)) + a (fun va -> f va cont) + + (* Main function *) let origin = ref false let dbg_out = ref false @@ -106,7 +88,7 @@ module ProtoKahn: S = struct send Hello; if read () <> Hello then raise (ProtocolError "Server did not say Hello correctly."); (* Start task if necessary *) - if !origin then proc (Some (fun r -> send (FinalResult (Marshal.to_string r [])))); + if !origin then proc (fun r -> send (FinalResult (Marshal.to_string r []))); (* While there are things to do... *) let result = ref None in while !result = None do @@ -114,7 +96,7 @@ module ProtoKahn: S = struct send RequestTask; dbg "Reading..."; match read() with - | GiveTask(td, _) -> + | GiveTask(td) -> dbg "Got task!"; let t : task = Marshal.from_string td 0 in Format.eprintf "%s[%s@?" cseq ncseq; diff --git a/src/manager.ml b/src/manager.ml index 1e6a0df..9498d8c 100644 --- a/src/manager.ml +++ b/src/manager.ml @@ -21,7 +21,7 @@ let pool_count = ref 0 (* Server data structures *) type task_el = - | Task of task_descr * bool + | Task of task_descr | MsgTask of string * msg_task_descr type client_status = @@ -82,7 +82,7 @@ let push_task server task = c.send (match task with | MsgTask(a, b) -> GiveMsgTask(a, b) - | Task(a, b) -> GiveTask(a, b)) + | Task(a) -> GiveTask(a)) let get_task server = Queue.pop server.tasks @@ -172,7 +172,7 @@ let rec server_run server = cli.status <- Waiting else cli.send (match Queue.pop server.tasks with | MsgTask(a, b) -> GiveMsgTask(a, b) - | Task(a, b) -> GiveTask(a,b)) + | Task(a) -> GiveTask(a)) | Some r -> cli.send(FinalResult r); client_disconnect server cli @@ -197,9 +197,9 @@ let rec server_run server = c.send(FinalResult x); client_disconnect server c) !p - | GiveTask(a, b) -> + | GiveTask(a) -> dbg "got Task"; - push_task server (Task(a, b)) + push_task server (Task(a)) | GiveMsgTask(a, b) -> dbg "got MsgTask"; push_task server (MsgTask(a, b)) diff --git a/src/primes.ml b/src/primes.ml index a91b11c..6975b9e 100644 --- a/src/primes.ml +++ b/src/primes.ml @@ -41,7 +41,7 @@ module Primes (K : Kahn.S) = struct end -module Eng = Kahn_stdio.ProtoKahn +module Eng = Kahn_seq.Seq module P = Primes(Eng) let () = diff --git a/src/proto.ml b/src/proto.ml index 1f6d8e6..df41944 100644 --- a/src/proto.ml +++ b/src/proto.ml @@ -4,6 +4,7 @@ open Util type task = unit -> unit type msg_task = string -> unit + type task_descr = string type msg_task_descr = string @@ -15,7 +16,7 @@ type message = | Get of id * msg_task_descr | Put of id * string | RequestTask - | GiveTask of task_descr * bool + | GiveTask of task_descr | GiveMsgTask of string * msg_task_descr | FinalResult of string -- cgit v1.2.3