├── INSTALL ├── LICENSE ├── META.in ├── Makefile ├── OMakefile ├── OMakeroot ├── README.md ├── VERSION ├── nproc.ml ├── nproc.mli └── test_nproc.ml /INSTALL: -------------------------------------------------------------------------------- 1 | Building Nproc requires the following tools: 2 | 3 | - Make (command: make) 4 | - OCaml (command: ocamlc, ocamlopt) 5 | - Findlib (command: ocamlfind) 6 | - Lwt (check: ocamlfind list | grep lwt) 7 | 8 | Installation: 9 | 10 | $ make 11 | $ make install 12 | 13 | Uninstallation: 14 | 15 | $ make uninstall 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011 MyLife 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /META.in: -------------------------------------------------------------------------------- 1 | description = "Process pool" 2 | requires = "lwt.unix" 3 | archive(byte) = "nproc.cma" 4 | archive(native) = "nproc.cmxa" 5 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # This Makefile provides only what is needed to build and install nproc. 2 | # Development is done with omake using the OMakefile. 3 | 4 | .PHONY: default all opt install uninstall 5 | 6 | default: all opt 7 | 8 | META: META.in VERSION 9 | echo "version = \"$$(cat VERSION)\"" > META 10 | cat META.in >> META 11 | 12 | all: META 13 | ocamlfind ocamlc -c nproc.mli -package lwt.unix 14 | ocamlfind ocamlc -a -g nproc.ml -o nproc.cma -package lwt.unix 15 | opt: META 16 | ocamlfind ocamlc -c nproc.mli -package lwt.unix 17 | ocamlfind ocamlopt -a -g nproc.ml -o nproc.cmxa -package lwt.unix 18 | install: 19 | ocamlfind install nproc META \ 20 | `find nproc.mli nproc.cmi \ 21 | nproc.cmo nproc.cma \ 22 | nproc.cmx nproc.o nproc.cmxa nproc.a` 23 | uninstall: 24 | ocamlfind remove nproc 25 | 26 | .PHONY: clean 27 | clean: 28 | omake clean 29 | rm -f *.omc 30 | -------------------------------------------------------------------------------- /OMakefile: -------------------------------------------------------------------------------- 1 | USE_OCAMLFIND = true 2 | BYTE_ENABLED = true 3 | OCAMLDEP_MODULES_ENABLED = false 4 | 5 | OCAMLPACKS = lwt.unix 6 | OCAMLFLAGS = -annot -g 7 | 8 | FILES = nproc 9 | 10 | MLI = $(addsuffix .mli, $(FILES)) 11 | 12 | OCamlLibrary(nproc, $(FILES)) 13 | OCamlProgram(test_nproc, $(FILES) test_nproc) 14 | 15 | .DEFAULT: META nproc.cma nproc.cmxa test_nproc.opt 16 | 17 | META: META.in VERSION 18 | echo "version = \"$$(cat VERSION)\"" > META 19 | cat META.in >> META 20 | 21 | .PHONY: test 22 | test: test_nproc.opt 23 | ./test_nproc.opt 24 | 25 | .PHONY: install uninstall 26 | install: 27 | ocamlfind install nproc META nproc.mli nproc.cmi \ 28 | nproc.cmo nproc.cma \ 29 | nproc.cmx nproc.o nproc.cmxa nproc.a 30 | uninstall: 31 | ocamlfind remove nproc 32 | 33 | 34 | .PHONY: doc 35 | doc: doc/index.html 36 | doc/index.html: $(MLI) 37 | mkdir -p doc 38 | ocamlfind ocamldoc -d doc -html $(MLI) -package $(OCAMLPACKS) 39 | 40 | .PHONY: install-doc 41 | install-doc: doc 42 | cd ../mylifelabs.github.com && mkdir -p nproc 43 | cp doc/* ../mylifelabs.github.com/nproc 44 | 45 | .PHONY: clean 46 | clean: 47 | rm -f *.o *.a *.cm* *~ *.annot *.run *.opt test_nproc META doc/* 48 | -------------------------------------------------------------------------------- /OMakeroot: -------------------------------------------------------------------------------- 1 | # include the standard installed configuration file. 2 | include $(STDROOT) 3 | 4 | # include the OMakefile in this directory. 5 | .SUBDIRS: . 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Nproc: Process pool implementation for OCaml 2 | ============================================ 3 | 4 | A master process creates a pool of N processes. Tasks can be submitted 5 | asynchronously as a function `f` and its argument `x`. As soon as one of 6 | the processes is available, it computes `f x` and returns the result. 7 | 8 | This library allows to take advantage of multicore architectures 9 | by message-passing and without blocking. Its implementation relies 10 | on fork, pipes, Marshal and [Lwt](http://ocsigen.org/lwt/manual/). 11 | 12 | Implementation status: 13 | ---------------------- 14 | - interface may still be subject to slight changes; 15 | - passed a few units tests; 16 | - used stream interface successfully at full scale. 17 | 18 | Performance status: 19 | ------------------- 20 | - observed 5x speedup on 8 cores when converting a stream of lines 21 | from one file to another. 22 | A task consisted in parsing a line, converting the record, 23 | doing one in-RAM database lookup per record, and printing the new record. 24 | Throughput was 50K records per second, using a granularity of 100 25 | records per task. 26 | 27 | Do not hesitate to submit experience reports, either good or bad, 28 | and [interface](http://mylifelabs.github.com/nproc/Nproc.html) 29 | suggestions before it is too late. 30 | 31 | [Documentation](http://mylifelabs.github.com/nproc/Nproc.html) 32 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | 0.5.1 2 | -------------------------------------------------------------------------------- /nproc.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | type worker_info = { 4 | worker_id : int; 5 | worker_loop : 'a. unit -> 'a; 6 | } 7 | 8 | exception Start_worker of worker_info 9 | 10 | let log_error = ref (fun s -> eprintf "[err] %s\n%!" s) 11 | let log_info = ref (fun s -> eprintf "[info] %s\n%!" s) 12 | let string_of_exn = ref Printexc.to_string 13 | 14 | let report_error msg = 15 | try !log_error msg 16 | with e -> 17 | eprintf "%s\n" msg; 18 | eprintf "*** Critical error *** Error logger raised an exception:\n%s\n%!" 19 | (Printexc.to_string e) 20 | 21 | let report_info msg = 22 | try !log_info msg 23 | with e -> 24 | eprintf "%s\n" msg; 25 | eprintf "*** Critical error *** Info logger raised an exception:\n%s\n%!" 26 | (Printexc.to_string e) 27 | 28 | (* Get the n first elements of the stream as a reversed list. *) 29 | let rec npop acc n strm = 30 | if n > 0 then 31 | match Stream.peek strm with 32 | None -> acc 33 | | Some x -> 34 | Stream.junk strm; 35 | npop (x :: acc) (n-1) strm 36 | else 37 | acc 38 | 39 | (* Chunkify stream; each chunk is in reverse order. *) 40 | let chunkify n strm = 41 | Stream.from ( 42 | fun _ -> 43 | match npop [] n strm with 44 | [] -> None 45 | | l -> Some l 46 | ) 47 | 48 | module Full = 49 | struct 50 | type worker = { 51 | worker_pid : int; 52 | worker_in : Lwt_unix.file_descr; 53 | worker_out : Lwt_unix.file_descr; 54 | } 55 | 56 | type ('b, 'c) from_worker = 57 | Worker_res of 'b 58 | | Central_req of 'c 59 | | Worker_error of string 60 | 61 | type ('a, 'b, 'c, 'd, 'e) to_worker = 62 | Worker_req of (('c -> 'd) -> 'e -> 'a -> 'b) * 'a 63 | | Central_res of 'd 64 | 65 | (* --worker-- *) 66 | (* executed in worker processes right after the fork or in 67 | the master when closing the process pool. 68 | It closes the master side of the pipes. *) 69 | let close_worker x = 70 | Unix.close (Lwt_unix.unix_file_descr x.worker_in); 71 | Unix.close (Lwt_unix.unix_file_descr x.worker_out) 72 | 73 | (* --worker-- *) 74 | let cleanup_proc_pool a = 75 | for i = 0 to Array.length a - 1 do 76 | match a.(i) with 77 | None -> () 78 | | Some x -> 79 | close_worker x; 80 | a.(i) <- None 81 | done 82 | 83 | (* Exception raised by f *) 84 | let user_error1 e = 85 | sprintf "Exception raised by Nproc task: %s" (!string_of_exn e) 86 | 87 | (* Exception raised by g *) 88 | let user_error2 e = 89 | sprintf "Error while handling result of Nproc task: exception %s" 90 | (!string_of_exn e) 91 | 92 | (* --worker-- *) 93 | let start_worker_loop worker_data fd_in fd_out = 94 | let ic = Unix.in_channel_of_descr fd_in in 95 | let oc = Unix.out_channel_of_descr fd_out in 96 | let central_service x = 97 | Marshal.to_channel oc (Central_req x) [Marshal.Closures]; 98 | flush oc; 99 | match Marshal.from_channel ic with 100 | Central_res y -> y 101 | | Worker_req _ -> assert false 102 | in 103 | while true do 104 | let result = 105 | try 106 | match Marshal.from_channel ic with 107 | Worker_req (f, x) -> 108 | (try Worker_res (f central_service worker_data x) 109 | with e -> Worker_error (user_error1 e) 110 | ) 111 | | Central_res _ -> assert false 112 | with 113 | End_of_file -> exit 0 114 | | e -> 115 | let msg = 116 | sprintf "Internal error in Nproc worker: %s" (!string_of_exn e) 117 | in 118 | Worker_error msg 119 | in 120 | try 121 | Marshal.to_channel oc result [Marshal.Closures]; 122 | flush oc 123 | with Sys_error "Broken pipe" -> 124 | exit 0 125 | done; 126 | assert false 127 | 128 | let write_value oc x = 129 | Lwt.bind 130 | (Lwt_io.write_value oc ~flags:[Marshal.Closures] x) 131 | (fun () -> Lwt_io.flush oc) 132 | 133 | type in_t = Obj.t 134 | type out_t = Obj.t 135 | 136 | type ('a, 'b, 'c) t = { 137 | stream : 138 | ((('a -> 'b) -> 'c -> in_t -> out_t) 139 | * in_t 140 | * (out_t option -> unit)) 141 | Lwt_stream.t; 142 | push : 143 | (((('a -> 'b) -> 'c -> in_t -> out_t) 144 | * in_t 145 | * (out_t option -> unit)) 146 | option -> unit); 147 | kill_workers : unit -> unit; 148 | close : unit -> unit Lwt.t; 149 | closed : bool ref; 150 | } 151 | 152 | let rec waitpid pid = 153 | try Unix.waitpid [] pid 154 | with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid pid 155 | 156 | (* --master-- *) 157 | let pull_task kill_workers in_stream in_stream_mutex central_service worker = 158 | (* Note: input and output file descriptors are automatically closed 159 | when the end of the lwt channel is reached. *) 160 | let ic = Lwt_io.of_fd ~mode:Lwt_io.input worker.worker_in in 161 | let oc = Lwt_io.of_fd ~mode:Lwt_io.output worker.worker_out in 162 | let rec pull () = 163 | Lwt.bind (Lwt_mutex.with_lock in_stream_mutex (fun () -> Lwt_stream.get in_stream)) ( 164 | function 165 | | None -> Lwt.return () 166 | | Some (f, x, g) -> 167 | let req = Worker_req (f, x) in 168 | Lwt.bind 169 | (write_value oc req) 170 | (read_from_worker g) 171 | ) 172 | and read_from_worker g () = 173 | Lwt.try_bind 174 | (fun () -> Lwt_io.read_value ic) 175 | (handle_input g) 176 | (fun e -> 177 | let msg = 178 | sprintf "Cannot read from Nproc worker: exception %s" 179 | (!string_of_exn e) 180 | in 181 | report_error msg; 182 | kill_workers (); 183 | exit 1 184 | ) 185 | 186 | and handle_input g = function 187 | Worker_res result -> 188 | (try 189 | g (Some result) 190 | with e -> 191 | report_error (user_error2 e) 192 | ); 193 | pull () 194 | 195 | | Central_req x -> 196 | Lwt.bind (central_service x) ( 197 | fun y -> 198 | let res = Central_res y in 199 | Lwt.bind 200 | (write_value oc res) 201 | (read_from_worker g) 202 | ) 203 | 204 | | Worker_error msg -> 205 | report_error msg; 206 | (try 207 | g None 208 | with e -> 209 | report_error (user_error2 e) 210 | ); 211 | pull () 212 | 213 | in 214 | pull () 215 | 216 | (* --master-- *) 217 | let create_gen init ((in_stream, push), in_stream_mutex) nproc central_service worker_data = 218 | let proc_pool = Array.make nproc None in 219 | Array.iteri ( 220 | fun i _ -> 221 | let (in_read, in_write) = Lwt_unix.pipe_in () in 222 | let (out_read, out_write) = Lwt_unix.pipe_out () in 223 | match Unix.fork () with 224 | 0 -> 225 | (try 226 | Unix.close (Lwt_unix.unix_file_descr in_read); 227 | Unix.close (Lwt_unix.unix_file_descr out_write); 228 | cleanup_proc_pool proc_pool; 229 | let start () = 230 | start_worker_loop worker_data out_read in_write 231 | in 232 | init { worker_id = i; worker_loop = start }; 233 | start () 234 | 235 | with e -> 236 | match e with 237 | Start_worker start -> raise e 238 | | _ -> 239 | !log_error 240 | (sprintf "Uncaught exception in worker (pid %i): %s" 241 | (Unix.getpid ()) (!string_of_exn e)); 242 | exit 1 243 | ) 244 | | child_pid -> 245 | Unix.close in_write; 246 | Unix.close out_read; 247 | proc_pool.(i) <- 248 | Some { 249 | worker_pid = child_pid; 250 | worker_in = in_read; 251 | worker_out = out_write; 252 | } 253 | ) proc_pool; 254 | 255 | (* 256 | Create nproc lightweight threads. 257 | Each lightweight thread pull tasks from the stream and feeds its worker 258 | until the stream is empty. 259 | *) 260 | let worker_info = 261 | Array.to_list 262 | (Array.map (function Some x -> x | None -> assert false) proc_pool) 263 | in 264 | 265 | let kill_workers () = 266 | Array.iter ( 267 | function 268 | None -> () 269 | | Some x -> 270 | (try close_worker x with _ -> ()); 271 | (try 272 | Unix.kill x.worker_pid Sys.sigkill; 273 | ignore (waitpid x.worker_pid) 274 | with e -> 275 | !log_error 276 | (sprintf "kill worker %i: %s" 277 | x.worker_pid (!string_of_exn e))) 278 | ) proc_pool 279 | in 280 | 281 | let jobs = 282 | Lwt.join 283 | (List.map 284 | (pull_task kill_workers in_stream in_stream_mutex central_service) 285 | worker_info) 286 | in 287 | 288 | let closed = ref false in 289 | 290 | let close_stream () = 291 | if not !closed then ( 292 | push None; 293 | closed := true; 294 | Lwt.bind jobs (fun () -> Lwt.return (kill_workers ())) 295 | ) 296 | else 297 | Lwt.return () 298 | in 299 | 300 | let p = { 301 | stream = in_stream; 302 | push = push; 303 | kill_workers = kill_workers; 304 | close = close_stream; 305 | closed = closed; 306 | } 307 | in 308 | p, jobs 309 | 310 | let default_init worker_info = () 311 | 312 | let create ?(init = default_init) nproc central_service worker_data = 313 | create_gen init (Lwt_stream.create (), Lwt_mutex.create ()) nproc central_service worker_data 314 | 315 | let close p = 316 | p.close () 317 | 318 | let terminate p = 319 | p.closed := true; 320 | p.kill_workers () 321 | 322 | let submit p ~f x = 323 | if !(p.closed) then 324 | Lwt.fail (Failure 325 | ("Cannot submit task to process pool because it is closed")) 326 | else 327 | let waiter, wakener = Lwt.task () in 328 | let handle_result y = Lwt.wakeup wakener y in 329 | p.push 330 | (Some (Obj.magic f, Obj.magic x, Obj.magic handle_result)); 331 | waiter 332 | 333 | let stream_pop x = 334 | let o = Stream.peek x in 335 | (match o with 336 | None -> () 337 | | Some _ -> Stream.junk x 338 | ); 339 | o 340 | 341 | let lwt_of_stream f g strm = 342 | Lwt_stream.from ( 343 | fun () -> 344 | let elt = 345 | match stream_pop strm with 346 | None -> None 347 | | Some x -> Some (Obj.magic f, Obj.magic x, Obj.magic g) 348 | in 349 | Lwt.return elt 350 | ) 351 | 352 | type 'a result_or_error = Result of 'a | Error of string 353 | 354 | let iter_stream 355 | ?(granularity = 1) 356 | ?(init = default_init) 357 | ~nproc ~serv ~env ~f ~g in_stream = 358 | 359 | if granularity <= 0 then 360 | invalid_arg (sprintf "Nproc.iter_stream: granularity=%i" granularity) 361 | else 362 | let task_stream = 363 | if granularity = 1 then 364 | lwt_of_stream f g in_stream 365 | else 366 | let in_stream' = chunkify granularity in_stream in 367 | let f' central_service worker_data l = 368 | List.rev_map ( 369 | fun x -> 370 | try Result (f central_service worker_data x) 371 | with e -> Error (user_error1 e) 372 | ) l 373 | in 374 | let g' = function 375 | None -> 376 | report_error "Nproc error: missing result due to an internal \ 377 | error in Nproc or due to a killed worker process" 378 | | Some l -> 379 | List.iter ( 380 | function 381 | Result y -> 382 | (try 383 | g (Some y) 384 | with e -> 385 | report_error (user_error2 e) 386 | ) 387 | | Error s -> 388 | report_error s; 389 | (try 390 | g None 391 | with e -> 392 | report_error (user_error2 e) 393 | ) 394 | ) l 395 | in 396 | lwt_of_stream f' g' in_stream' 397 | in 398 | let p, t = 399 | create_gen init 400 | ((task_stream, 401 | (fun _ -> assert false) (* push *)), 402 | Lwt_mutex.create ()) 403 | nproc serv env 404 | in 405 | try 406 | Lwt_main.run t; 407 | p.kill_workers (); 408 | with e -> 409 | p.kill_workers (); 410 | raise e 411 | end 412 | 413 | 414 | type t = (unit, unit, unit) Full.t 415 | 416 | let create ?init n = 417 | Full.create ?init n (fun () -> Lwt.return ()) () 418 | 419 | let close = Full.close 420 | 421 | let terminate = Full.terminate 422 | 423 | let submit p ~f x = 424 | Full.submit p ~f: (fun _ _ x -> f x) x 425 | 426 | let iter_stream ?granularity ?init ~nproc ~f ~g strm = 427 | Full.iter_stream 428 | ?granularity 429 | ?init 430 | ~nproc 431 | ~env: () 432 | ~serv: (fun () -> Lwt.return ()) 433 | ~f: (fun serv env x -> f x) 434 | ~g 435 | strm 436 | -------------------------------------------------------------------------------- /nproc.mli: -------------------------------------------------------------------------------- 1 | (** Process pools *) 2 | 3 | (** 4 | A process pool is a fixed set of processes that perform 5 | arbitrary computations for a master process, in parallel 6 | and without blocking the master. 7 | 8 | Master and workers communicate by message-passing. The implementation 9 | relies on fork, pipes, Marshal and {{:http://ocsigen.org/lwt/manual/}Lwt}. 10 | 11 | Error handling: 12 | - Functions passed by the user to Nproc should not raise exceptions. 13 | - Exceptions raised accidentally by user-given functions 14 | either in the master or in the workers are logged but not propagated 15 | as exceptions. The result of the call uses the [option] type 16 | and [None] indicates that an exception was caught. 17 | - Exceptions due to bugs in Nproc hopefully won't occur often 18 | but if they do they will be handled just like user exceptions. 19 | - Fatal errors occurring in workers result in the 20 | termination of the master and all the workers. Such errors include 21 | segmentation faults, sigkills sent by other processes, 22 | explicit calls to the exit function, etc. 23 | 24 | Logging: 25 | - Nproc logs error messages as well as informative messages 26 | that it judges useful and affordable in terms of performance. 27 | - The printing functions [log_error] and [log_info] 28 | can be redefined to take advantage of a particular logging system. 29 | - No logging takes place in the worker processes. 30 | - Only the function that converts exceptions into strings [string_of_exn] 31 | may be called in both master and workers. 32 | *) 33 | 34 | type t 35 | (** Type of a process pool *) 36 | 37 | type worker_info = private { 38 | worker_id : int; 39 | (** Worker identifier ranging between 0 and (number of workers - 1). *) 40 | 41 | worker_loop : 'a. unit -> 'a; 42 | (** Function that starts the worker's infinite loop. *) 43 | } 44 | 45 | exception Start_worker of worker_info 46 | (** This is the only exception that may be raised by the user from within 47 | the [init] function passed as an option to {!Nproc.create}. 48 | In this case it is the user's responsibility to catch the exception 49 | and to start the worker loop. 50 | 51 | The purpose of this exception is to allow the user to clear 52 | the call stack in the child processes, allowing 53 | the garbage collector to free up heap-allocated memory that 54 | would otherwise be wasted. 55 | *) 56 | 57 | val create : 58 | ?init: (worker_info -> unit) -> 59 | int -> t * unit Lwt.t 60 | (** Create a process pool. 61 | 62 | [create nproc] returns [(ppool, lwt)] where 63 | [ppool] is a pool of [nproc] processes and [lwt] is a lightweight thread 64 | that finishes when the pool is closed. 65 | 66 | @param init initialization function called at the beginning of 67 | of each worker process. By default it does nothing. 68 | Specifying a custom [init] function allows to perform 69 | some initial cleanup of resources 70 | inherited from the parent (master), 71 | such as closing files or connections. It may also 72 | raise the {!Nproc.Start_worker} exception as a means 73 | of clearing the call stack inherited from the parent, 74 | enabling the garbage collection of some useless data. 75 | If this [Start_worker] mechanism is used, 76 | the [worker_loop] function from the {!Nproc.worker_info} 77 | record needs to be called explicitly after catching 78 | the exception. 79 | *) 80 | 81 | val close : t -> unit Lwt.t 82 | (** Close a process pool. 83 | It waits for all submitted tasks to finish. *) 84 | 85 | val terminate : t -> unit 86 | (** Terminate the processes of a pool without waiting for the pending 87 | tasks to complete. *) 88 | 89 | val submit : 90 | t -> f: ('a -> 'b) -> 'a -> 'b option Lwt.t 91 | (** Submit a task. 92 | [submit ppool ~f x] passes [f] and [x] to one of the worker processes, 93 | which computes [f x] and passes the result back to the master process, 94 | i.e. to the calling process running the Lwt event loop. 95 | 96 | The current implementation uses the Marshal module to serialize 97 | and deserialize [f], its input and its output. 98 | *) 99 | 100 | val iter_stream : 101 | ?granularity: int -> 102 | ?init: (worker_info -> unit) -> 103 | nproc: int -> 104 | f: ('a -> 'b) -> 105 | g: ('b option -> unit) -> 106 | 'a Stream.t -> unit 107 | (** 108 | Iterate over a stream using a pool of 109 | [nproc] worker processes running in parallel. 110 | 111 | [iter_stream] runs the Lwt event loop internally. It is intended 112 | for programs that do not use Lwt otherwise. 113 | 114 | Function [f] runs in the worker processes. It is applied to elements 115 | of the stream that it receives from the master process. 116 | Function [g] is applied to the result of [f] in the master process. 117 | 118 | The current implementation uses the Marshal module to serialize 119 | and deserialize [f], its inputs (stream elements) and its outputs. 120 | [f] is serialized as many times as there are elements in the stream. 121 | If [f] relies on a large immutable data structure, we recommend 122 | using the [env] option of [Full.iter_stream]. 123 | 124 | @param granularity allows to improve the performance of short-lived 125 | tasks by grouping multiple tasks internally into 126 | a single task. 127 | This reduces the overhead of the underlying 128 | message-passing system but makes the tasks 129 | sequential within each group. 130 | The default [granularity] is 1. 131 | 132 | @param init see {!Nproc.create}. 133 | *) 134 | 135 | val log_error : (string -> unit) ref 136 | (** Function used by Nproc for printing error messages. 137 | By default it writes a message to the [stderr] channel 138 | and flushes its buffer. *) 139 | 140 | val log_info : (string -> unit) ref 141 | (** Function used by Nproc for printing informational messages. 142 | By default it writes a message to the [stderr] channel 143 | and flushes its buffer. *) 144 | 145 | val string_of_exn : (exn -> string) ref 146 | (** Function used by Nproc to convert exception into a string used 147 | in error messages. 148 | By default it is set to [Printexc.to_string]. 149 | Users might want to change it into a function that prints 150 | a stack backtrace, e.g. 151 | {v 152 | Nproc.string_of_exn := 153 | (fun e -> Printexc.get_backtrace () ^ Printexc.to_string e) 154 | v} 155 | *) 156 | 157 | (** Fuller interface allowing requests from a worker to the master 158 | and environment data residing in the workers. *) 159 | module Full : 160 | sig 161 | type ('serv_request, 'serv_response, 'env) t 162 | (** 163 | Type of a process pool. 164 | The type parameters correspond to the following: 165 | - ['serv_request]: type of the requests from worker to master, 166 | - ['serv_response]: type of the responses to the requests, 167 | - ['env]: type of the environment data passed just once to each 168 | worker process. 169 | *) 170 | 171 | val create : 172 | ?init: (worker_info -> unit) -> 173 | int -> 174 | ('serv_request -> 'serv_response Lwt.t) -> 175 | 'env -> 176 | ('serv_request, 'serv_response, 'env) t * unit Lwt.t 177 | (** Create a process pool. 178 | [create nproc service env] returns [(ppool, lwt)] where 179 | [ppool] is pool of [nproc] processes and [lwt] is a 180 | lightweight thread that finishes when the pool is closed. 181 | 182 | [service] is a service which is run asynchronously by the 183 | master process and can be called synchronously by the workers. 184 | 185 | [env] is arbitrary environment data, typically large, that 186 | is passed to the workers just once during their initialization. 187 | 188 | @param init see {!Nproc.create}. 189 | *) 190 | 191 | val close : 192 | ('serv_request, 'serv_response, 'env) t -> unit Lwt.t 193 | (** Close a process pool. 194 | It waits for all submitted tasks to finish. *) 195 | 196 | val terminate : 197 | ('serv_request, 'serv_response, 'env) t -> unit 198 | (** Terminate the processes of a pool without waiting for the pending 199 | tasks to complete. *) 200 | 201 | val submit : 202 | ('serv_request, 'serv_response, 'env) t -> 203 | f: (('serv_request -> 'serv_response) -> 'env -> 'a -> 'b) -> 204 | 'a -> 'b option Lwt.t 205 | (** Submit a task. 206 | [submit ppool ~f x] passes [f] and [x] to one of the worker processes, 207 | which computes [f service env x] and passes the result back 208 | to the master process, 209 | i.e. to the calling process running the Lwt event loop. 210 | 211 | The current implementation uses the Marshal module to serialize 212 | and deserialize [f], its input and its output. 213 | *) 214 | 215 | val iter_stream : 216 | ?granularity: int -> 217 | ?init: (worker_info -> unit) -> 218 | nproc: int -> 219 | serv: ('serv_request -> 'serv_response Lwt.t) -> 220 | env: 'env -> 221 | f: (('serv_request -> 'serv_response) -> 'env -> 'a -> 'b) -> 222 | g: ('b option -> unit) -> 223 | 'a Stream.t -> unit 224 | (** 225 | Iterate over a stream using a pool of 226 | [nproc] worker processes running in parallel. 227 | 228 | [iter_stream] runs the Lwt event loop internally. It is intended 229 | for programs that do not use Lwt otherwise. 230 | 231 | Function [f] runs in the worker processes. It is applied to elements 232 | of the stream that it receives from the master process. 233 | Function [g] is applied to the result of [f] in the master process. 234 | 235 | The current implementation uses the Marshal module to serialize 236 | and deserialize [f], its inputs (stream elements) and its outputs. 237 | [f] is serialized as many times as there are elements in the stream. 238 | If [f] relies on a large immutable data structure, it should be 239 | putting into [env] in order to avoid costly and 240 | repetitive serialization of that data. 241 | 242 | @param init see {!Nproc.create}. 243 | *) 244 | 245 | end 246 | -------------------------------------------------------------------------------- /test_nproc.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let exception_in_f () = 4 | let n = 100 in 5 | let strm = Stream.from (fun i -> if i < n then Some i else None) in 6 | let error_count = ref 0 in 7 | Nproc.iter_stream 8 | ~nproc: 8 9 | ~f: (fun x -> if x = 50 then failwith "raised from f") 10 | ~g: (function None -> incr error_count | Some _ -> ()) 11 | strm; 12 | assert (!error_count = 1) 13 | 14 | let exception_in_g () = 15 | let n = 100 in 16 | let strm = Stream.from (fun i -> if i < n then Some i else None) in 17 | let real_error_count = ref 0 in 18 | Nproc.iter_stream 19 | ~nproc: 8 20 | ~f: (fun n -> -n) 21 | ~g: (function 22 | Some x -> if x = -50 then failwith "raised from g" 23 | | None -> incr real_error_count) 24 | strm; 25 | assert (!real_error_count = 0) 26 | 27 | let fatal_exit_in_f () = 28 | let n = 100 in 29 | let strm = Stream.from (fun i -> if i < n then Some i else None) in 30 | let error_count = ref 0 in 31 | Nproc.iter_stream 32 | ~nproc: 8 33 | ~f: (fun x -> if x = 50 then exit 1) 34 | ~g: (fun _ -> incr error_count) 35 | strm; 36 | assert (!error_count = 0); 37 | assert false 38 | 39 | let test_lwt_interface () = 40 | let l = Array.to_list (Array.init 300 (fun i -> i)) in 41 | let p, t = Nproc.create 100 in 42 | let acc = ref [] in 43 | let error_count1 = ref 0 in 44 | let error_count2 = ref 0 in 45 | List.iter ( 46 | fun x -> 47 | ignore ( 48 | Lwt.bind (Nproc.submit p (fun n -> Unix.sleep 1; (n, -n)) x) 49 | (function 50 | Some (x, y) -> 51 | if y <> -x then 52 | incr error_count1; 53 | acc := y :: !acc; 54 | Lwt.return () 55 | | None -> 56 | incr error_count2; 57 | Lwt.return () 58 | ) 59 | ) 60 | ) l; 61 | Lwt_main.run (Nproc.close p); 62 | assert (!error_count1 = 0); 63 | assert (!error_count2 = 0); 64 | assert (List.sort compare (List.map (~-) !acc) = l) 65 | 66 | let within mini maxi x = 67 | x >= mini && x <= maxi 68 | 69 | let timed mini maxi f = 70 | let t1 = Unix.gettimeofday () in 71 | f (); 72 | let t2 = Unix.gettimeofday () in 73 | let dt = t2 -. t1 in 74 | printf "total time: %.6fs\n%!" dt; 75 | dt >= mini && dt <= maxi 76 | 77 | let test_stream_interface_gen granularity () = 78 | let l = Array.to_list (Array.init 300 (fun i -> i)) in 79 | let strm = Stream.of_list l in 80 | let error_count = ref 0 in 81 | let acc = ref [] in 82 | Nproc.iter_stream 83 | ~granularity 84 | ~nproc: 100 85 | ~f: (fun n -> Unix.sleep 1; (n, -n)) 86 | ~g: (function Some (x, y) -> acc := y :: !acc | None -> incr error_count) 87 | strm; 88 | assert (!error_count = 0); 89 | assert (List.sort compare (List.map (~-) !acc) = l) 90 | 91 | let test_stream_interface () = 92 | assert (timed 2.99 3.20 (test_stream_interface_gen 1)) 93 | 94 | let test_stream_interface_g10 () = 95 | assert (timed 9.99 10.20 (test_stream_interface_gen 10)) 96 | 97 | let make_list len x = 98 | let rec loop acc len x = 99 | if len > 0 then loop (x :: acc) (len - 1) x 100 | else acc 101 | in 102 | loop [] len x 103 | 104 | let get_live_words () = 105 | (Gc.stat ()).Gc.live_words 106 | 107 | let print_live_words () = 108 | printf "live_words: %i\n%!" (get_live_words ()) 109 | 110 | let test_unstack () = 111 | try 112 | let in_list = [1;2;3;4] in 113 | let out_list = ref [] in 114 | let strm = Stream.of_list in_list in 115 | let x = make_list 1_000_000 0 in 116 | printf "GC stats in parent:\n"; 117 | print_live_words (); 118 | assert (get_live_words () > 2_000_000); 119 | 120 | printf "GC stats in children:\n%!"; 121 | Nproc.iter_stream 122 | ~init: (fun x -> raise (Nproc.Start_worker x)) 123 | ~nproc:2 124 | ~f: (fun x -> 125 | Gc.compact (); 126 | print_live_words (); 127 | assert (get_live_words () < 100_000); 128 | x 129 | ) 130 | ~g: (function 131 | Some x -> out_list := x :: !out_list 132 | | None -> assert false) 133 | strm; 134 | 135 | assert (get_live_words () > 2_000_000); 136 | ignore (List.hd x); 137 | assert (List.sort compare !out_list = List.sort compare in_list); 138 | 139 | with Nproc.Start_worker x -> 140 | printf "Starting worker %i\n%!" x.Nproc.worker_id; 141 | x.Nproc.worker_loop () 142 | 143 | let run name f = 144 | printf "[%s]\n%!" name; 145 | f (); 146 | printf "OK\n%!" 147 | 148 | let tests = 149 | [ 150 | (* shorter tests *) 151 | "exception in f", exception_in_f; 152 | "exception in g", exception_in_g; 153 | "unstack child", test_unstack; 154 | 155 | (* longer tests *) 156 | "lwt interface", test_lwt_interface; 157 | "stream interface", test_stream_interface; 158 | "stream interface with granularity=10", test_stream_interface_g10; 159 | (*"fatal exit in f", fatal_exit_in_f;*) 160 | ] 161 | 162 | let main () = List.iter (fun (name, f) -> run name f) tests 163 | 164 | let () = main () 165 | --------------------------------------------------------------------------------