pax_global_header00006660000000000000000000000064116670756240014530gustar00rootroot0000000000000052 comment=a2ea5673bbad4aa92d2da3ccda03f4f1f7fb075d nproc-0.5.1/000077500000000000000000000000001166707562400126545ustar00rootroot00000000000000nproc-0.5.1/INSTALL000066400000000000000000000004001166707562400136770ustar00rootroot00000000000000Building Nproc requires the following tools: - Make (command: make) - OCaml (command: ocamlc, ocamlopt) - Findlib (command: ocamlfind) - Lwt (check: ocamlfind list | grep lwt) Installation: $ make $ make install Uninstallation: $ make uninstall nproc-0.5.1/LICENSE000066400000000000000000000025511166707562400136640ustar00rootroot00000000000000Copyright (c) 2011 MyLife All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. nproc-0.5.1/META.in000066400000000000000000000001561166707562400137340ustar00rootroot00000000000000description = "Process pool" requires = "lwt.unix" archive(byte) = "nproc.cma" archive(native) = "nproc.cmxa" nproc-0.5.1/Makefile000066400000000000000000000014151166707562400143150ustar00rootroot00000000000000# This Makefile provides only what is needed to build and install nproc. # Development is done with omake using the OMakefile. .PHONY: default all opt install uninstall default: all opt META: META.in VERSION echo "version = \"$$(cat VERSION)\"" > META cat META.in >> META all: META ocamlfind ocamlc -c nproc.mli -package lwt.unix ocamlfind ocamlc -a -g nproc.ml -o nproc.cma -package lwt.unix opt: META ocamlfind ocamlc -c nproc.mli -package lwt.unix ocamlfind ocamlopt -a -g nproc.ml -o nproc.cmxa -package lwt.unix install: ocamlfind install nproc META \ `find nproc.mli nproc.cmi \ nproc.cmo nproc.cma \ nproc.cmx nproc.o nproc.cmxa nproc.a` uninstall: ocamlfind remove nproc .PHONY: clean clean: omake clean rm -f *.omc nproc-0.5.1/OMakefile000066400000000000000000000017461166707562400144430ustar00rootroot00000000000000USE_OCAMLFIND = true BYTE_ENABLED = true OCAMLDEP_MODULES_ENABLED = false OCAMLPACKS = lwt.unix OCAMLFLAGS = -annot -g FILES = nproc MLI = $(addsuffix .mli, $(FILES)) OCamlLibrary(nproc, $(FILES)) OCamlProgram(test_nproc, $(FILES) test_nproc) .DEFAULT: META nproc.cma nproc.cmxa test_nproc.opt META: META.in VERSION echo "version = \"$$(cat VERSION)\"" > META cat META.in >> META .PHONY: test test: test_nproc.opt ./test_nproc.opt .PHONY: install uninstall install: ocamlfind install nproc META nproc.mli nproc.cmi \ nproc.cmo nproc.cma \ nproc.cmx nproc.o nproc.cmxa nproc.a uninstall: ocamlfind remove nproc .PHONY: doc doc: doc/index.html doc/index.html: $(MLI) mkdir -p doc ocamlfind ocamldoc -d doc -html $(MLI) -package $(OCAMLPACKS) .PHONY: install-doc install-doc: doc cd ../mylifelabs.github.com && mkdir -p nproc cp doc/* ../mylifelabs.github.com/nproc .PHONY: clean clean: rm -f *.o *.a *.cm* *~ *.annot *.run *.opt test_nproc META doc/* nproc-0.5.1/OMakeroot000066400000000000000000000002001166707562400144670ustar00rootroot00000000000000# include the standard installed configuration file. include $(STDROOT) # include the OMakefile in this directory. .SUBDIRS: . nproc-0.5.1/README.md000066400000000000000000000023721166707562400141370ustar00rootroot00000000000000Nproc: Process pool implementation for OCaml ============================================ A master process creates a pool of N processes. Tasks can be submitted asynchronously as a function `f` and its argument `x`. As soon as one of the processes is available, it computes `f x` and returns the result. This library allows to take advantage of multicore architectures by message-passing and without blocking. Its implementation relies on fork, pipes, Marshal and [Lwt](http://ocsigen.org/lwt/manual/). Implementation status: ---------------------- - interface may still be subject to slight changes; - passed a few units tests; - used stream interface successfully at full scale. Performance status: ------------------- - observed 5x speedup on 8 cores when converting a stream of lines from one file to another. A task consisted in parsing a line, converting the record, doing one in-RAM database lookup per record, and printing the new record. Throughput was 50K records per second, using a granularity of 100 records per task. Do not hesitate to submit experience reports, either good or bad, and [interface](http://mylifelabs.github.com/nproc/Nproc.html) suggestions before it is too late. [Documentation](http://mylifelabs.github.com/nproc/Nproc.html) nproc-0.5.1/VERSION000066400000000000000000000000061166707562400137200ustar00rootroot000000000000000.5.1 nproc-0.5.1/nproc.ml000066400000000000000000000264571166707562400143450ustar00rootroot00000000000000open Printf type worker_info = { worker_id : int; worker_loop : 'a. unit -> 'a; } exception Start_worker of worker_info let log_error = ref (fun s -> eprintf "[err] %s\n%!" s) let log_info = ref (fun s -> eprintf "[info] %s\n%!" s) let string_of_exn = ref Printexc.to_string let report_error msg = try !log_error msg with e -> eprintf "%s\n" msg; eprintf "*** Critical error *** Error logger raised an exception:\n%s\n%!" (Printexc.to_string e) let report_info msg = try !log_info msg with e -> eprintf "%s\n" msg; eprintf "*** Critical error *** Info logger raised an exception:\n%s\n%!" (Printexc.to_string e) (* Get the n first elements of the stream as a reversed list. *) let rec npop acc n strm = if n > 0 then match Stream.peek strm with None -> acc | Some x -> Stream.junk strm; npop (x :: acc) (n-1) strm else acc (* Chunkify stream; each chunk is in reverse order. *) let chunkify n strm = Stream.from ( fun _ -> match npop [] n strm with [] -> None | l -> Some l ) module Full = struct type worker = { worker_pid : int; worker_in : Lwt_unix.file_descr; worker_out : Lwt_unix.file_descr; } type ('b, 'c) from_worker = Worker_res of 'b | Central_req of 'c | Worker_error of string type ('a, 'b, 'c, 'd, 'e) to_worker = Worker_req of (('c -> 'd) -> 'e -> 'a -> 'b) * 'a | Central_res of 'd (* --worker-- *) (* executed in worker processes right after the fork or in the master when closing the process pool. It closes the master side of the pipes. *) let close_worker x = Unix.close (Lwt_unix.unix_file_descr x.worker_in); Unix.close (Lwt_unix.unix_file_descr x.worker_out) (* --worker-- *) let cleanup_proc_pool a = for i = 0 to Array.length a - 1 do match a.(i) with None -> () | Some x -> close_worker x; a.(i) <- None done (* Exception raised by f *) let user_error1 e = sprintf "Exception raised by Nproc task: %s" (!string_of_exn e) (* Exception raised by g *) let user_error2 e = sprintf "Error while handling result of Nproc task: exception %s" (!string_of_exn e) (* --worker-- *) let start_worker_loop worker_data fd_in fd_out = let ic = Unix.in_channel_of_descr fd_in in let oc = Unix.out_channel_of_descr fd_out in let central_service x = Marshal.to_channel oc (Central_req x) [Marshal.Closures]; flush oc; match Marshal.from_channel ic with Central_res y -> y | Worker_req _ -> assert false in while true do let result = try match Marshal.from_channel ic with Worker_req (f, x) -> (try Worker_res (f central_service worker_data x) with e -> Worker_error (user_error1 e) ) | Central_res _ -> assert false with End_of_file -> exit 0 | e -> let msg = sprintf "Internal error in Nproc worker: %s" (!string_of_exn e) in Worker_error msg in try Marshal.to_channel oc result [Marshal.Closures]; flush oc with Sys_error "Broken pipe" -> exit 0 done; assert false let write_value oc x = Lwt.bind (Lwt_io.write_value oc ~flags:[Marshal.Closures] x) (fun () -> Lwt_io.flush oc) type in_t = Obj.t type out_t = Obj.t type ('a, 'b, 'c) t = { stream : ((('a -> 'b) -> 'c -> in_t -> out_t) * in_t * (out_t option -> unit)) Lwt_stream.t; push : (((('a -> 'b) -> 'c -> in_t -> out_t) * in_t * (out_t option -> unit)) option -> unit); kill_workers : unit -> unit; close : unit -> unit Lwt.t; closed : bool ref; } (* --master-- *) let pull_task kill_workers in_stream central_service worker = (* Note: input and output file descriptors are automatically closed when the end of the lwt channel is reached. *) let ic = Lwt_io.of_fd ~mode:Lwt_io.input worker.worker_in in let oc = Lwt_io.of_fd ~mode:Lwt_io.output worker.worker_out in let rec pull () = Lwt.bind (Lwt_stream.get in_stream) ( function None -> Lwt.return () | Some (f, x, g) -> let req = Worker_req (f, x) in Lwt.bind (write_value oc req) (read_from_worker g) ) and read_from_worker g () = Lwt.try_bind (fun () -> Lwt_io.read_value ic) (handle_input g) (fun e -> let msg = sprintf "Cannot read from Nproc worker: exception %s" (!string_of_exn e) in report_error msg; kill_workers (); exit 1 ) and handle_input g = function Worker_res result -> (try g (Some result) with e -> report_error (user_error2 e) ); pull () | Central_req x -> Lwt.bind (central_service x) ( fun y -> let res = Central_res y in Lwt.bind (write_value oc res) (read_from_worker g) ) | Worker_error msg -> report_error msg; (try g None with e -> report_error (user_error2 e) ); pull () in pull () (* --master-- *) let create_gen init (in_stream, push) nproc central_service worker_data = let proc_pool = Array.make nproc None in Array.iteri ( fun i _ -> let (in_read, in_write) = Lwt_unix.pipe_in () in let (out_read, out_write) = Lwt_unix.pipe_out () in match Unix.fork () with 0 -> (try Unix.close (Lwt_unix.unix_file_descr in_read); Unix.close (Lwt_unix.unix_file_descr out_write); cleanup_proc_pool proc_pool; let start () = start_worker_loop worker_data out_read in_write in init { worker_id = i; worker_loop = start }; start () with e -> match e with Start_worker start -> raise e | _ -> !log_error (sprintf "Uncaught exception in worker (pid %i): %s" (Unix.getpid ()) (!string_of_exn e)); exit 1 ) | child_pid -> Unix.close in_write; Unix.close out_read; proc_pool.(i) <- Some { worker_pid = child_pid; worker_in = in_read; worker_out = out_write; } ) proc_pool; (* Create nproc lightweight threads. Each lightweight thread pull tasks from the stream and feeds its worker until the stream is empty. *) let worker_info = Array.to_list (Array.map (function Some x -> x | None -> assert false) proc_pool) in let kill_workers () = Array.iter ( function None -> () | Some x -> (try close_worker x with _ -> ()); (try Unix.kill x.worker_pid Sys.sigkill; ignore (Unix.waitpid [] x.worker_pid) with e -> !log_error (sprintf "kill worker %i: %s" x.worker_pid (!string_of_exn e))) ) proc_pool in let jobs = Lwt.join (List.map (pull_task kill_workers in_stream central_service) worker_info) in let closed = ref false in let close_stream () = if not !closed then ( push None; closed := true; Lwt.bind jobs (fun () -> Lwt.return (kill_workers ())) ) else Lwt.return () in let p = { stream = in_stream; push = push; kill_workers = kill_workers; close = close_stream; closed = closed; } in p, jobs let default_init worker_info = () let create ?(init = default_init) nproc central_service worker_data = create_gen init (Lwt_stream.create ()) nproc central_service worker_data let close p = p.close () let terminate p = p.closed := true; p.kill_workers () let submit p ~f x = if !(p.closed) then Lwt.fail (Failure ("Cannot submit task to process pool because it is closed")) else let waiter, wakener = Lwt.task () in let handle_result y = Lwt.wakeup wakener y in p.push (Some (Obj.magic f, Obj.magic x, Obj.magic handle_result)); waiter let stream_pop x = let o = Stream.peek x in (match o with None -> () | Some _ -> Stream.junk x ); o let lwt_of_stream f g strm = Lwt_stream.from ( fun () -> let elt = match stream_pop strm with None -> None | Some x -> Some (Obj.magic f, Obj.magic x, Obj.magic g) in Lwt.return elt ) type 'a result_or_error = Result of 'a | Error of string let iter_stream ?(granularity = 1) ?(init = default_init) ~nproc ~serv ~env ~f ~g in_stream = if granularity <= 0 then invalid_arg (sprintf "Nproc.iter_stream: granularity=%i" granularity) else let task_stream = if granularity = 1 then lwt_of_stream f g in_stream else let in_stream' = chunkify granularity in_stream in let f' central_service worker_data l = List.rev_map ( fun x -> try Result (f central_service worker_data x) with e -> Error (user_error1 e) ) l in let g' = function None -> report_error "Nproc error: missing result due to an internal \ error in Nproc or due to a killed worker process" | Some l -> List.iter ( function Result y -> (try g (Some y) with e -> report_error (user_error2 e) ) | Error s -> report_error s; (try g None with e -> report_error (user_error2 e) ) ) l in lwt_of_stream f' g' in_stream' in let p, t = create_gen init (task_stream, (fun _ -> assert false) (* push *)) nproc serv env in try Lwt_main.run t; p.kill_workers (); with e -> p.kill_workers (); raise e end type t = (unit, unit, unit) Full.t let create ?init n = Full.create ?init n (fun () -> Lwt.return ()) () let close = Full.close let terminate = Full.terminate let submit p ~f x = Full.submit p ~f: (fun _ _ x -> f x) x let iter_stream ?granularity ?init ~nproc ~f ~g strm = Full.iter_stream ?granularity ?init ~nproc ~env: () ~serv: (fun () -> Lwt.return ()) ~f: (fun serv env x -> f x) ~g strm nproc-0.5.1/nproc.mli000066400000000000000000000225411166707562400145040ustar00rootroot00000000000000(** Process pools *) (** A process pool is a fixed set of processes that perform arbitrary computations for a master process, in parallel and without blocking the master. Master and workers communicate by message-passing. The implementation relies on fork, pipes, Marshal and {{:http://ocsigen.org/lwt/manual/}Lwt}. Error handling: - Functions passed by the user to Nproc should not raise exceptions. - Exceptions raised accidentally by user-given functions either in the master or in the workers are logged but not propagated as exceptions. The result of the call uses the [option] type and [None] indicates that an exception was caught. - Exceptions due to bugs in Nproc hopefully won't occur often but if they do they will be handled just like user exceptions. - Fatal errors occurring in workers result in the termination of the master and all the workers. Such errors include segmentation faults, sigkills sent by other processes, explicit calls to the exit function, etc. Logging: - Nproc logs error messages as well as informative messages that it judges useful and affordable in terms of performance. - The printing functions [log_error] and [log_info] can be redefined to take advantage of a particular logging system. - No logging takes place in the worker processes. - Only the function that converts exceptions into strings [string_of_exn] may be called in both master and workers. *) type t (** Type of a process pool *) type worker_info = private { worker_id : int; (** Worker identifier ranging between 0 and (number of workers - 1). *) worker_loop : 'a. unit -> 'a; (** Function that starts the worker's infinite loop. *) } exception Start_worker of worker_info (** This is the only exception that may be raised by the user from within the [init] function passed as an option to {!Nproc.create}. In this case it is the user's responsibility to catch the exception and to start the worker loop. The purpose of this exception is to allow the user to clear the call stack in the child processes, allowing the garbage collector to free up heap-allocated memory that would otherwise be wasted. *) val create : ?init: (worker_info -> unit) -> int -> t * unit Lwt.t (** Create a process pool. [create nproc] returns [(ppool, lwt)] where [ppool] is a pool of [nproc] processes and [lwt] is a lightweight thread that finishes when the pool is closed. @param init initialization function called at the beginning of of each worker process. By default it does nothing. Specifying a custom [init] function allows to perform some initial cleanup of resources inherited from the parent (master), such as closing files or connections. It may also raise the {!Nproc.Start_worker} exception as a means of clearing the call stack inherited from the parent, enabling the garbage collection of some useless data. If this [Start_worker] mechanism is used, the [worker_loop] function from the {!Nproc.worker_info} record needs to be called explicitly after catching the exception. *) val close : t -> unit Lwt.t (** Close a process pool. It waits for all submitted tasks to finish. *) val terminate : t -> unit (** Terminate the processes of a pool without waiting for the pending tasks to complete. *) val submit : t -> f: ('a -> 'b) -> 'a -> 'b option Lwt.t (** Submit a task. [submit ppool ~f x] passes [f] and [x] to one of the worker processes, which computes [f x] and passes the result back to the master process, i.e. to the calling process running the Lwt event loop. The current implementation uses the Marshal module to serialize and deserialize [f], its input and its output. *) val iter_stream : ?granularity: int -> ?init: (worker_info -> unit) -> nproc: int -> f: ('a -> 'b) -> g: ('b option -> unit) -> 'a Stream.t -> unit (** Iterate over a stream using a pool of [nproc] worker processes running in parallel. [iter_stream] runs the Lwt event loop internally. It is intended for programs that do not use Lwt otherwise. Function [f] runs in the worker processes. It is applied to elements of the stream that it receives from the master process. Function [g] is applied to the result of [f] in the master process. The current implementation uses the Marshal module to serialize and deserialize [f], its inputs (stream elements) and its outputs. [f] is serialized as many times as there are elements in the stream. If [f] relies on a large immutable data structure, we recommend using the [env] option of [Full.iter_stream]. @param granularity allows to improve the performance of short-lived tasks by grouping multiple tasks internally into a single task. This reduces the overhead of the underlying message-passing system but makes the tasks sequential within each group. The default [granularity] is 1. @param init see {!Nproc.create}. *) val log_error : (string -> unit) ref (** Function used by Nproc for printing error messages. By default it writes a message to the [stderr] channel and flushes its buffer. *) val log_info : (string -> unit) ref (** Function used by Nproc for printing informational messages. By default it writes a message to the [stderr] channel and flushes its buffer. *) val string_of_exn : (exn -> string) ref (** Function used by Nproc to convert exception into a string used in error messages. By default it is set to [Printexc.to_string]. Users might want to change it into a function that prints a stack backtrace, e.g. {v Nproc.string_of_exn := (fun e -> Printexc.get_backtrace () ^ Printexc.to_string e) v} *) (** Fuller interface allowing requests from a worker to the master and environment data residing in the workers. *) module Full : sig type ('serv_request, 'serv_response, 'env) t (** Type of a process pool. The type parameters correspond to the following: - ['serv_request]: type of the requests from worker to master, - ['serv_response]: type of the responses to the requests, - ['env]: type of the environment data passed just once to each worker process. *) val create : ?init: (worker_info -> unit) -> int -> ('serv_request -> 'serv_response Lwt.t) -> 'env -> ('serv_request, 'serv_response, 'env) t * unit Lwt.t (** Create a process pool. [create nproc service env] returns [(ppool, lwt)] where [ppool] is pool of [nproc] processes and [lwt] is a lightweight thread that finishes when the pool is closed. [service] is a service which is run asynchronously by the master process and can be called synchronously by the workers. [env] is arbitrary environment data, typically large, that is passed to the workers just once during their initialization. @param init see {!Nproc.create}. *) val close : ('serv_request, 'serv_response, 'env) t -> unit Lwt.t (** Close a process pool. It waits for all submitted tasks to finish. *) val terminate : ('serv_request, 'serv_response, 'env) t -> unit (** Terminate the processes of a pool without waiting for the pending tasks to complete. *) val submit : ('serv_request, 'serv_response, 'env) t -> f: (('serv_request -> 'serv_response) -> 'env -> 'a -> 'b) -> 'a -> 'b option Lwt.t (** Submit a task. [submit ppool ~f x] passes [f] and [x] to one of the worker processes, which computes [f service env x] and passes the result back to the master process, i.e. to the calling process running the Lwt event loop. The current implementation uses the Marshal module to serialize and deserialize [f], its input and its output. *) val iter_stream : ?granularity: int -> ?init: (worker_info -> unit) -> nproc: int -> serv: ('serv_request -> 'serv_response Lwt.t) -> env: 'env -> f: (('serv_request -> 'serv_response) -> 'env -> 'a -> 'b) -> g: ('b option -> unit) -> 'a Stream.t -> unit (** Iterate over a stream using a pool of [nproc] worker processes running in parallel. [iter_stream] runs the Lwt event loop internally. It is intended for programs that do not use Lwt otherwise. Function [f] runs in the worker processes. It is applied to elements of the stream that it receives from the master process. Function [g] is applied to the result of [f] in the master process. The current implementation uses the Marshal module to serialize and deserialize [f], its inputs (stream elements) and its outputs. [f] is serialized as many times as there are elements in the stream. If [f] relies on a large immutable data structure, it should be putting into [env] in order to avoid costly and repetitive serialization of that data. @param init see {!Nproc.create}. *) end nproc-0.5.1/test_nproc.ml000066400000000000000000000104561166707562400153740ustar00rootroot00000000000000open Printf let exception_in_f () = let n = 100 in let strm = Stream.from (fun i -> if i < n then Some i else None) in let error_count = ref 0 in Nproc.iter_stream ~nproc: 8 ~f: (fun x -> if x = 50 then failwith "raised from f") ~g: (function None -> incr error_count | Some _ -> ()) strm; assert (!error_count = 1) let exception_in_g () = let n = 100 in let strm = Stream.from (fun i -> if i < n then Some i else None) in let real_error_count = ref 0 in Nproc.iter_stream ~nproc: 8 ~f: (fun n -> -n) ~g: (function Some x -> if x = -50 then failwith "raised from g" | None -> incr real_error_count) strm; assert (!real_error_count = 0) let fatal_exit_in_f () = let n = 100 in let strm = Stream.from (fun i -> if i < n then Some i else None) in let error_count = ref 0 in Nproc.iter_stream ~nproc: 8 ~f: (fun x -> if x = 50 then exit 1) ~g: (fun _ -> incr error_count) strm; assert (!error_count = 0); assert false let test_lwt_interface () = let l = Array.to_list (Array.init 300 (fun i -> i)) in let p, t = Nproc.create 100 in let acc = ref [] in let error_count1 = ref 0 in let error_count2 = ref 0 in List.iter ( fun x -> ignore ( Lwt.bind (Nproc.submit p (fun n -> Unix.sleep 1; (n, -n)) x) (function Some (x, y) -> if y <> -x then incr error_count1; acc := y :: !acc; Lwt.return () | None -> incr error_count2; Lwt.return () ) ) ) l; Lwt_main.run (Nproc.close p); assert (!error_count1 = 0); assert (!error_count2 = 0); assert (List.sort compare (List.map (~-) !acc) = l) let within mini maxi x = x >= mini && x <= maxi let timed mini maxi f = let t1 = Unix.gettimeofday () in f (); let t2 = Unix.gettimeofday () in let dt = t2 -. t1 in printf "total time: %.6fs\n%!" dt; dt >= mini && dt <= maxi let test_stream_interface_gen granularity () = let l = Array.to_list (Array.init 300 (fun i -> i)) in let strm = Stream.of_list l in let error_count = ref 0 in let acc = ref [] in Nproc.iter_stream ~granularity ~nproc: 100 ~f: (fun n -> Unix.sleep 1; (n, -n)) ~g: (function Some (x, y) -> acc := y :: !acc | None -> incr error_count) strm; assert (!error_count = 0); assert (List.sort compare (List.map (~-) !acc) = l) let test_stream_interface () = assert (timed 2.99 3.20 (test_stream_interface_gen 1)) let test_stream_interface_g10 () = assert (timed 9.99 10.20 (test_stream_interface_gen 10)) let make_list len x = let rec loop acc len x = if len > 0 then loop (x :: acc) (len - 1) x else acc in loop [] len x let get_live_words () = (Gc.stat ()).Gc.live_words let print_live_words () = printf "live_words: %i\n%!" (get_live_words ()) let test_unstack () = try let in_list = [1;2;3;4] in let out_list = ref [] in let strm = Stream.of_list in_list in let x = make_list 1_000_000 0 in printf "GC stats in parent:\n"; print_live_words (); assert (get_live_words () > 2_000_000); printf "GC stats in children:\n%!"; Nproc.iter_stream ~init: (fun x -> raise (Nproc.Start_worker x)) ~nproc:2 ~f: (fun x -> Gc.compact (); print_live_words (); assert (get_live_words () < 100_000); x ) ~g: (function Some x -> out_list := x :: !out_list | None -> assert false) strm; assert (get_live_words () > 2_000_000); ignore (List.hd x); assert (List.sort compare !out_list = List.sort compare in_list); with Nproc.Start_worker x -> printf "Starting worker %i\n%!" x.Nproc.worker_id; x.Nproc.worker_loop () let run name f = printf "[%s]\n%!" name; f (); printf "OK\n%!" let tests = [ (* shorter tests *) "exception in f", exception_in_f; "exception in g", exception_in_g; "unstack child", test_unstack; (* longer tests *) "lwt interface", test_lwt_interface; "stream interface", test_stream_interface; "stream interface with granularity=10", test_stream_interface_g10; (*"fatal exit in f", fatal_exit_in_f;*) ] let main () = List.iter (fun (name, f) -> run name f) tests let () = main ()