├── .github └── workflows │ └── test.yml ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── dune-project ├── lib ├── dune ├── parallel.ml └── parallel.mli ├── lib_test ├── dune └── run_tests.ml └── lwt-parallel.opam /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-latest 14 | - ubuntu-latest 15 | ocaml-version: 16 | - 4.14.0 17 | - 4.08.1 18 | 19 | runs-on: ${{ matrix.os }} 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v2 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-version }} 26 | uses: ocaml/setup-ocaml@v2 27 | with: 28 | ocaml-compiler: ${{ matrix.ocaml-version }} 29 | 30 | - run: opam pin add lwt-parallel . --no-action 31 | - run: opam install lwt-parallel --deps-only 32 | - run: opam exec -- dune build 33 | - run: opam exec -- dune runtest 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | _build 11 | .merlin 12 | *.install 13 | 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 6 | script: bash -ex ./.travis-docker.sh 7 | env: 8 | global: 9 | - PINS="lwt-parallel:." 10 | matrix: 11 | - PACKAGE="lwt-parallel" DISTRO="ubuntu-16.04" OCAML_VERSION="4.07.1" 12 | - PACKAGE="lwt-parallel" DISTRO="ubuntu-16.04" OCAML_VERSION="4.06.0" 13 | - PACKAGE="lwt-parallel" DISTRO="ubuntu-16.04" OCAML_VERSION="4.04.2" 14 | - PACKAGE="lwt-parallel" DISTRO="ubuntu-16.04" OCAML_VERSION="4.03.0" 15 | - PACKAGE="lwt-parallel" DISTRO="debian-unstable" OCAML_VERSION="4.07.1" 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2013-2022 Ivan Gotovchits 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Lwt-enabled Parallel Processing Library 2 | ======================================= 3 | 4 | This library allows running lwt computations in different OS processes. E.g., 5 | 6 | ```ocaml 7 | (* do it once in the beginning *) 8 | let () = Parallel.init () 9 | 10 | (* ... *) 11 | let puts = Parallel.run Lwt_io.printl in 12 | 13 | (* will be printed in a different process *) 14 | puts "hello" >>= fun () -> 15 | ``` 16 | 17 | Implementation Details 18 | ---------------------- 19 | 20 | In general, Unix fork(2) and Lwt do not mix well. There are a few issues. First, Lwt uses regular threads (like pthreads) to handle some system calls, and threads do not play with forks. Next, Lwt promises essentially form a DAG of reference cells that will be cloned into the child process on a fork so that the promises made in parent will be triggered in the child, which is not what you usually want. Last but not least, every fork will clone the whole heap of the current process, which will be result in a time consuming data copying the next time the marks and sweep cycle of the GC is run (which will trigger copy-on-write as it will mark every block). 21 | 22 | The solution is to create a snapshot of the process before it starts any lwt-related computations and use this snapshot to fork the new processes. I.e., every time we need to fork a process, instead of running fork(2) in the current process we send a request to the snapshot process which forks a new child and returns the AF_UNIX socket address for communicating with this child. The function to be executed along with the protocol specifications are marshaled via pipe to the snapshot process, where they are copied to the new process space during the fork. 23 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | (name lwt-parallel) 3 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parallel) 3 | (public_name lwt-parallel) 4 | (libraries lwt.unix logs.lwt) 5 | (flags (:standard -w -9-27-32-34-38-39))) 6 | -------------------------------------------------------------------------------- /lib/parallel.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | exception Exited 4 | exception Error 5 | 6 | type 'a t = 'a Lwt_stream.t 7 | type ('a,'b) pipe = ('a Lwt_stream.t * ('b option -> unit)) 8 | 9 | let snapshots = ref 0 10 | 11 | let make_name ?(suffix="") pid = 12 | let open Filename in 13 | let base = basename Sys.executable_name in 14 | let base = 15 | try chop_extension base with Invalid_argument _ -> base in 16 | let name = 17 | Format.asprintf "%s-%d-%d%s" base pid !snapshots suffix in 18 | let tmp = Filename.get_temp_dir_name () in 19 | concat tmp name 20 | 21 | let socket_name pid = Unix.ADDR_UNIX (make_name pid) 22 | 23 | let bind_socket = Lwt_unix.Versioned.bind_2 [@warning "-3"] 24 | 25 | 26 | module Mutex : sig 27 | type t 28 | val create: int -> t 29 | val with_lock: t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 30 | val remove : t -> unit 31 | end = struct 32 | type t = { 33 | p_guard : Lwt_unix.file_descr; 34 | t_guard : Lwt_mutex.t; 35 | path : string; 36 | } 37 | 38 | 39 | let create pid = 40 | let name = make_name ~suffix:".lock" pid in 41 | let fd = Unix.(openfile name [O_WRONLY; O_CREAT] 0o200) in 42 | { 43 | p_guard = Lwt_unix.of_unix_file_descr fd; 44 | t_guard = Lwt_mutex.create (); 45 | path = name; 46 | } 47 | 48 | let lock_p fd = Lwt_unix.(lockf fd F_LOCK 1) 49 | let unlock_p fd = Lwt_unix.(lockf fd F_ULOCK 1) 50 | 51 | let with_p_lock fd f = 52 | lock_p fd >>= fun () -> 53 | try_bind f 54 | (fun r -> unlock_p fd >>= fun () -> return r) 55 | (fun exn -> unlock_p fd >>= fun () -> fail exn) 56 | 57 | let with_lock m f = 58 | Lwt_mutex.with_lock m.t_guard (fun () -> with_p_lock m.p_guard f) 59 | 60 | let remove {path} = 61 | if Sys.file_exists path then Unix.unlink path 62 | end 63 | 64 | type snapshot = { 65 | cld: int; 66 | ofd: Unix.file_descr; 67 | tfd: Unix.file_descr; 68 | lck: Mutex.t; 69 | } 70 | 71 | let master = ref None 72 | 73 | let error ~exn msg = 74 | Logs_lwt.err (fun m -> m "%s: %s" msg (Printexc.to_string exn)) 75 | 76 | let ign_error ~exn msg = 77 | error ~exn msg |> ignore 78 | 79 | let rec reap n = 80 | try 81 | match Unix.waitpid [Unix.WNOHANG] (-1) with 82 | | 0,_ -> () 83 | | _ -> reap n 84 | with Unix.Unix_error (Unix.ECHILD,_,_) -> () 85 | | exn -> Logs.err (fun m -> m "reap failed") 86 | 87 | let cleanup {ofd; tfd; cld; lck} = 88 | Unix.close ofd; 89 | Unix.close tfd; 90 | Unix.kill cld Sys.sigterm; 91 | Mutex.remove lck 92 | 93 | 94 | let create_snapshot ofd tfd pid = 95 | incr snapshots; 96 | {ofd; tfd; lck=Mutex.create pid; cld=pid} 97 | 98 | let buffered_io m = 99 | let of_unix_fd mode fd = 100 | let fd = Lwt_unix.of_unix_file_descr ~blocking:true fd in 101 | Lwt_io.of_fd ~mode fd in 102 | of_unix_fd Lwt_io.input m.ofd, 103 | of_unix_fd Lwt_io.output m.tfd 104 | 105 | let run_transaction m f = 106 | let transaction () = 107 | let ofd,tfd = buffered_io m in 108 | try_bind (fun () -> f ofd tfd) 109 | return 110 | (fun exn -> 111 | error ~exn "master i/o" >>= fun () -> fail exn) in 112 | Mutex.with_lock m.lck transaction 113 | 114 | let shutdown fd cmd = 115 | try 116 | Lwt_unix.shutdown fd cmd 117 | with Unix.Unix_error (Unix.ENOTCONN,_,_) -> () 118 | | exn -> ign_error ~exn "shutdown failed" 119 | 120 | let make_connection fd = 121 | let close () = return_unit in 122 | object(self) 123 | method ro = Lwt_io.of_fd ~close ~mode:Lwt_io.input fd 124 | method wo = Lwt_io.of_fd ~close ~mode:Lwt_io.output fd 125 | method write_finished = 126 | shutdown fd Unix.SHUTDOWN_SEND; 127 | return_unit 128 | method read_finished = 129 | shutdown fd Unix.SHUTDOWN_RECEIVE; 130 | return_unit 131 | method close = 132 | Lwt_io.close self#wo >>= fun () -> 133 | Lwt_io.close self#ro >>= fun () -> 134 | Lwt_unix.close fd 135 | end 136 | 137 | type 'a io = { 138 | put : Lwt_io.output_channel -> 'a -> unit Lwt.t; 139 | get : Lwt_io.input_channel -> 'a Lwt.t 140 | } 141 | 142 | let marshaling : 'a io = { 143 | put = Lwt_io.write_value 144 | ~flags:[Marshal.Closures]; 145 | get = Lwt_io.read_value; 146 | } 147 | 148 | module Io = struct 149 | let define ~put ~get = {put; get} 150 | let put io = io.put 151 | let get io = io.get 152 | let marshaling = marshaling 153 | end 154 | 155 | let write io fd v = 156 | try_bind 157 | (fun () -> io.put fd v) 158 | (fun () -> Lwt_io.flush fd) 159 | (fun exn -> error ~exn "write failed") 160 | 161 | let worker_thread inc out exec = 162 | let recv of_fd push = 163 | let rec loop () = 164 | out.get of_fd >>= fun a -> 165 | push (Some a); 166 | loop () in 167 | catch loop 168 | (function 169 | | End_of_file -> return_unit 170 | | exn -> error ~exn "Process exited with") >>= fun () -> 171 | return (push None) in 172 | let send to_fd of_stream = 173 | catch 174 | (fun () -> Lwt_stream.iter_s (write inc to_fd) of_stream) 175 | (fun exn -> error ~exn "parallel write failed") in 176 | let work fd = 177 | let conn = make_connection fd in 178 | let astream,apush = Lwt_stream.create () in 179 | let bstream,bpush = Lwt_stream.create () in 180 | let recv_t = recv conn#ro apush >>= fun () -> conn#read_finished in 181 | let send_t = send conn#wo bstream >>= fun () -> conn#write_finished in 182 | let exec_t = exec (astream,bpush) in 183 | async (fun () -> (recv_t <&> send_t) >>= fun () -> conn#close); 184 | exec_t in 185 | let sock = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in 186 | Lwt.catch (fun () -> 187 | bind_socket sock (socket_name (Unix.getpid ()))) 188 | (fun exn -> error ~exn "bind failed") >>= fun () -> 189 | Lwt_unix.listen sock 0; 190 | Lwt_unix.accept sock >>= fun (fd,addr) -> 191 | work fd 192 | 193 | let create_worker inc out exec = 194 | flush_all (); 195 | match Lwt_unix.fork () with 196 | | 0 -> exit (Lwt_main.run ( 197 | catch (fun () -> worker_thread inc out exec) 198 | (fun exn -> error ~exn "Subprocess failed" >>= fun () -> return 1))) 199 | 200 | | pid -> socket_name pid 201 | 202 | let snapshot () = 203 | let of_master,to_main = Unix.pipe () in 204 | let of_main,to_master = Unix.pipe () in 205 | flush_all (); 206 | match Unix.fork () with 207 | | 0 -> 208 | Sys.set_signal Sys.sigchld (Sys.Signal_handle reap); 209 | let of_main = Unix.in_channel_of_descr of_main in 210 | let to_main = Unix.out_channel_of_descr to_main in 211 | let rec loop () = 212 | let () = try 213 | let proc = Marshal.from_channel of_main in 214 | let inc = Marshal.from_channel of_main in 215 | let out = Marshal.from_channel of_main in 216 | let addr = create_worker inc out proc in 217 | Marshal.to_channel to_main addr []; 218 | flush to_main; 219 | with End_of_file -> exit 0 220 | | exn -> exit 1 in 221 | loop () in 222 | loop () 223 | | pid -> 224 | let snapshot = create_snapshot of_master to_master pid in 225 | at_exit (fun () -> cleanup snapshot); 226 | Unix.(List.iter close [of_main; to_main]); 227 | snapshot 228 | 229 | 230 | let init () = 231 | master := Some (snapshot ()) 232 | 233 | let unlink_addr addr = match addr with 234 | | Unix.ADDR_UNIX filename -> 235 | catch (fun () -> Lwt_unix.unlink filename) 236 | (fun exn -> error ~exn "unlink failed") 237 | | Unix.ADDR_INET _ -> return_unit 238 | 239 | let open_connection addr = 240 | let open Unix in 241 | let rec loop () = 242 | let fd = 243 | Lwt_unix.socket (domain_of_sockaddr addr) SOCK_STREAM 0 in 244 | catch 245 | (fun () -> Lwt_unix.connect fd addr >>= fun () -> return fd) 246 | (function 247 | | Unix_error (ENOENT,_,_) 248 | | Unix_error (ECONNREFUSED,_,_) -> 249 | Lwt_unix.close fd >>= fun () -> loop () 250 | | exn -> error ~exn "cannot open connection" >>= fun () -> fail exn) in 251 | let getfd = loop () >|= (fun fd -> `Socket fd) in 252 | let timer = Lwt_unix.sleep 5. >>= fun () -> return `Timeout in 253 | 254 | let fd = (getfd timer) >>= function 255 | | `Socket fd -> return fd 256 | | `Timeout -> 257 | fail (Unix_error (ETIMEDOUT, "open_connection","timeout")) in 258 | fd >>= fun fd -> unlink_addr addr >>= fun () -> 259 | return (make_connection fd) 260 | 261 | let create_client inc out f master = 262 | let astream,apush = Lwt_stream.create () in 263 | let bstream,bpush = Lwt_stream.create () in 264 | let io_thread () = 265 | let puller ro_chan = 266 | let rec loop () = 267 | inc.get ro_chan >>= fun b -> 268 | bpush (Some b); 269 | loop () in 270 | catch loop (function 271 | | End_of_file -> return (bpush None) 272 | | exn -> bpush None; error ~exn "Client died unexpectedly") in 273 | let pusher wo_chan = 274 | catch 275 | (fun () -> Lwt_stream.iter_s (write out wo_chan) astream) 276 | (fun exn -> error ~exn "parallel task failed") in 277 | let connect_to_client () = 278 | run_transaction master (fun of_master to_master -> 279 | write marshaling to_master f >>= fun () -> 280 | write marshaling to_master inc >>= fun () -> 281 | write marshaling to_master out >>= fun () -> 282 | Lwt_io.read_value of_master >>= fun addr -> 283 | open_connection addr) in 284 | connect_to_client () >>= fun chan -> 285 | let pull_t = puller chan#ro >>= fun () -> chan#read_finished in 286 | let push_t = pusher chan#wo >>= fun () -> chan#write_finished in 287 | (pull_t <&> push_t) >>= fun () -> chan#close in 288 | async io_thread; 289 | bstream,apush 290 | 291 | let process ?snapshot ?(inc=marshaling) ?(out=marshaling) f = 292 | match snapshot, !master with 293 | | Some t,_ | _, Some t -> create_client inc out f t 294 | | None,None -> failwith "Parallel: either specify a snapshot or run init" 295 | 296 | let run ?snapshot ?inc ?out exec = 297 | let rec child_f (astream,bpush) = 298 | let bs = Lwt_stream.map_s exec astream in 299 | Lwt_stream.iter (fun b -> bpush (Some b)) bs in 300 | let stream,push = process ?snapshot ?inc ?out child_f in 301 | let master_f a = 302 | push (Some a); 303 | Lwt_stream.next stream in 304 | master_f 305 | -------------------------------------------------------------------------------- /lib/parallel.mli: -------------------------------------------------------------------------------- 1 | (** Lwt-enabled parallel processing library. 2 | 3 | This library allows running lwt computations in different OS 4 | processes. E.g., 5 | 6 | {[ 7 | let () = Parallel.init () (* do it once in the beginning *) 8 | 9 | (* ... *) 10 | let puts = Parallel.run Lwt_io.printl in 11 | (* ... *) 12 | (* will be printed in a different process *) 13 | puts "hello" >>= fun () -> 14 | 15 | ]} 16 | 17 | 18 | {2 Implementation Details} 19 | 20 | In general, Unix fork(2) and Lwt do not mix well. There are a few 21 | issues. First, Lwt uses regular threads (like pthreads) to handle 22 | some system calls, and threads do not play with forks. Next, Lwt 23 | promises essentially form a DAG of reference cells that will be 24 | cloned into the child process on a fork, which is not what you 25 | usually want. Last but not least, every fork will clone the whole 26 | heap of the current process, which will be result in a time 27 | consuming data copying the next time the marks and sweep cycle of 28 | the GC is run (which will trigger copy-on-write as it will mark 29 | every block). 30 | 31 | The solution is to create a snapshot of the process before it 32 | starts any lwt-related computations and use this snapshot to fork 33 | the new processes. I.e., every time we need to fork a process, 34 | instead of running fork(2) in the current process we send a request 35 | to the snapshot process which forks a new child and returns the 36 | AF_UNIX socket address for communicating with this child. The 37 | function to be executed along with the protocol specifications are 38 | marshaled via pipe to the snapshot process, where they are copied 39 | to the new process space during the fork. 40 | *) 41 | 42 | 43 | (** a process snapshot handler *) 44 | type snapshot 45 | 46 | (** [x io] defines serialization protocol for the type [x] *) 47 | type 'a io 48 | 49 | 50 | 51 | (** [snapshot ()] creates a new process snapshot. 52 | 53 | Forks a new process from the current state so that it could be 54 | used later to create new forks. *) 55 | val snapshot : unit -> snapshot 56 | 57 | (** [init ()] creates the default snapshot. 58 | 59 | If no snapshot is provided to [run] or [create] then the snapshot 60 | created by [init] will be used. *) 61 | val init : unit -> unit 62 | 63 | (** {4 Simple interface} *) 64 | 65 | (** [run f] runs [f] in different process. 66 | 67 | @param snapshot uses the snapshot as the fork point, if no 68 | specified, uses the one created with [init ()], fails if 69 | [init ()] wasn't run. 70 | 71 | @param inc defines the serialization protocols for the incoming 72 | (from the subprocess) messages, i.e., for the function result 73 | type, defaults to the use of marshaling. 74 | 75 | @param out defines the serialization protocols for the outcoming 76 | (to the subprocess) messages, i.e., for the function argument 77 | type, defaults to the use of marshaling. *) 78 | val run : 79 | ?snapshot: snapshot -> 80 | ?inc: 'inc io -> 81 | ?out: 'out io -> 82 | ('out -> 'inc Lwt.t) -> ('out -> 'inc Lwt.t) 83 | 84 | (** {4 Expert interface} *) 85 | 86 | (** Type safe pipe, with ['a] read end and ['b] write end*) 87 | type ('a,'b) pipe = 'a Lwt_stream.t * ('b option -> unit) 88 | 89 | (** [create process] executes function [process] in other process. 90 | 91 | @param snapshot uses the snapshot as the fork point, if no 92 | specified, uses the one created with [init ()], fails if 93 | [init ()] wasn't run. 94 | 95 | @param inc defines the serialization protocols for the incoming 96 | (from the subprocess) messages, defaults to the use of marshaling. 97 | 98 | @param out defines the serialization protocols for the outcoming 99 | (to the subprocess) messages, defaults to the use of marshaling. *) 100 | val process : 101 | ?snapshot: snapshot -> 102 | ?inc: 'inc io -> 103 | ?out:'out io -> 104 | (('out,'inc) pipe -> unit Lwt.t) -> ('inc,'out) pipe 105 | 106 | 107 | 108 | (** Serialization Protocols. *) 109 | module Io : sig 110 | 111 | (** [define ~put ~get] defines a new serialization protocol. 112 | 113 | The [put] function is responsible for writing the messages to 114 | the channel. 115 | The [get] function is responsible for reading the messages from 116 | the channel. *) 117 | val define : 118 | put:(Lwt_io.output_channel -> 'a -> unit Lwt.t) -> 119 | get:(Lwt_io.input_channel -> 'a Lwt.t) -> 'a io 120 | 121 | (** [put io chan x] uses protocol [io] to write [x] to [chan]. *) 122 | val put : 'a io -> Lwt_io.output_channel -> 'a -> unit Lwt.t 123 | 124 | (** [get io chan] uses protocol [io] to read a message from [chan]. *) 125 | val get : 'a io -> Lwt_io.input_channel -> 'a Lwt.t 126 | 127 | (** [marshalling io] uses the [Marshal] module to serialize messages. *) 128 | val marshaling : 'a io 129 | end 130 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name run_tests) 3 | (libraries lwt lwt-parallel logs.fmt)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps run_tests.exe) 8 | (action (run %{deps}))) 9 | -------------------------------------------------------------------------------- /lib_test/run_tests.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Lwt.Syntax 3 | 4 | 5 | type to_sub = [ `Start of int * int array | `Stop ] 6 | type of_sub = float 7 | 8 | let to_sub : to_sub Parallel.io = 9 | Parallel.Io.define 10 | ~put:(fun chan -> function 11 | | `Stop -> 12 | Lwt_io.write_line chan "stop" 13 | | `Start (name,seed) -> 14 | Lwt_io.write_line chan "start" >>= fun () -> 15 | Lwt_io.write_int chan name >>= fun () -> 16 | Lwt_io.write_int chan (Array.length seed) >>= fun () -> 17 | Array.to_list seed |> 18 | Lwt_list.iter_s (Lwt_io.write_int chan)) 19 | ~get:(fun chan -> 20 | Lwt_io.read_line chan >>= function 21 | | "stop" -> Lwt.return `Stop 22 | | "start" -> 23 | let* name = Lwt_io.read_int chan in 24 | let* seed_size = Lwt_io.read_int chan in 25 | let seed = Array.make seed_size 0 in 26 | List.init seed_size (fun x -> x)|> 27 | Lwt_list.iter_s (fun i -> 28 | let+ x = Lwt_io.read_int chan in 29 | seed.(i) <- x) >|= fun () -> 30 | `Start (name, seed) 31 | | _ -> failwith "unknown command") 32 | 33 | let of_sub = Parallel.Io.define 34 | ~put:Lwt_io.write_float64 35 | ~get:Lwt_io.read_float64 36 | 37 | let setup_log level = 38 | Logs.set_level level; 39 | Logs.set_reporter (Logs_fmt.reporter ()); 40 | () 41 | 42 | let seed = [| 7; 8; 42; 56 |] 43 | let tasks = 64 44 | let task_size = min (4096 * 1024) (Sys.max_array_length / 2) 45 | let delay = 4. *. atan 1. 46 | 47 | let task (data,push) = 48 | Lwt_stream.next data >>= function 49 | | `Start (name,seed) -> 50 | let state = Random.State.make seed in 51 | Logs_lwt.debug (fun m -> m ": started" name) >>= fun () -> 52 | Lwt_unix.sleep (Random.float delay) >>= fun () -> 53 | let array = Array.init task_size (fun _ -> Random.State.float state 1.0) in 54 | let res = Float.abs @@ Array.fold_left 55 | (fun acc v -> if Random.State.bool state 56 | then sin (acc *. v) else cos (acc /. v)) 57 | 1.0 array *. 1e5 in 58 | Logs_lwt.debug (fun m -> m ": computed %g" name res) >>= fun () -> 59 | return (push (Some res)) 60 | | `Stop -> return (push None) 61 | 62 | let spawn_task snapshot (name,time) = 63 | Lwt_unix.sleep time >>= fun () -> 64 | let result,command = 65 | Parallel.process ~snapshot ~out:to_sub ~inc:of_sub task in 66 | command (Some (`Start (name,seed))); 67 | command (Some `Stop); 68 | Lwt_stream.get result 69 | 70 | let main_dispatcher snapshot = 71 | let delays = Array.to_list (Array.init tasks (fun i -> 72 | i,Random.float delay)) in 73 | Lwt_list.map_p (spawn_task snapshot) delays >>= function 74 | | Some r :: rs as total -> 75 | return (List.length total = tasks && List.for_all (fun r' -> Some r = r') rs) 76 | | _ -> return_false 77 | 78 | 79 | 80 | let () = 81 | setup_log (Some Debug); 82 | let () = Parallel.init () in 83 | let point1 = Parallel.snapshot () in 84 | (* let point2 = Parallel.snapshot () in *) 85 | let test p = 86 | main_dispatcher p >|= fun r -> assert r in 87 | Lwt_main.run (test point1); 88 | print_endline "TESTS DONE" 89 | -------------------------------------------------------------------------------- /lwt-parallel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "lwt-parallel" 3 | version: "master" 4 | maintainer: "Ivan Gotovchits " 5 | authors: "Ivan Gotovchits " 6 | homepage: "https://github.com/ivg/parallel" 7 | bug-reports: "https://github.com/ivg/parallel/issues" 8 | dev-repo: "git+https://github.com/ivg/parallel.git" 9 | license: "MIT" 10 | synopsis: "Lwt-enabled parallel computing library" 11 | 12 | build: [ 13 | ["dune" "build" "@install" "-p" name "-j" jobs] 14 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 15 | ["dune" "runtest" "-p" name] {with-test} 16 | ] 17 | 18 | depends: [ 19 | "base-unix" 20 | "dune" {>= "1.6"} 21 | "fmt" 22 | "logs" 23 | "lwt" {>= "2.7.0"} 24 | "ocaml" {>= "4.08.0"} 25 | "odoc" {with-doc} 26 | ] 27 | --------------------------------------------------------------------------------