├── .gitignore ├── .travis.yml ├── ForkWork.ml ├── ForkWork.mli ├── Helpers.ml ├── META ├── Makefile ├── README.md ├── _oasis ├── _tags ├── configure ├── examples ├── estimate_pi.ml └── estimate_pi_interval.ml ├── forkwork.mllib ├── forkwork.odocl ├── myocamlbuild.ml ├── setup.ml ├── tests.ml └── travis-ci.sh /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | _build/ 11 | *.native 12 | setup.data 13 | setup.log 14 | *.docdir 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | script: bash -ex travis-ci.sh 3 | -------------------------------------------------------------------------------- /ForkWork.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Helpers 3 | ;; 4 | 5 | let ncores, set_ncores = 6 | let attempt_detect ndefault = 7 | (* TODO: use a binding to sysconf() to do this *) 8 | try 9 | let inchan = Unix.open_process_in "sh -c \"cat /proc/cpuinfo | grep -e processor[[:space:]]*: | wc -l\" 2>/dev/null" in 10 | let stdout = input_line inchan in 11 | match Unix.close_process_in inchan with 12 | | Unix.WEXITED 0 -> max 1 (int_of_string stdout) 13 | | _ -> raise Exit 14 | with _ -> ndefault 15 | in 16 | let n = ref (attempt_detect 4) in 17 | (fun () -> !n), (fun ?(detect=false) n' -> n := (if detect then attempt_detect n' else n')) 18 | ;; 19 | 20 | (* types *) 21 | type job = int 22 | 23 | type 'a result = [`OK of 'a | `Exn of string list] 24 | 25 | type 'a internal_result = [`OK of 'a | `Exn of string list | `IPC_Failure of exn] 26 | 27 | type 'a mgr = { 28 | maxprocs : int; 29 | pending : (int,(int*Unix.file_descr)) Hashtbl.t; (* job -> pid*result_fd *) 30 | results: (int,'a internal_result) Hashtbl.t (* job -> result *) 31 | } 32 | 33 | exception ChildExn of string list 34 | 35 | (* finalizer: if the manager is being garbage-collected while there are still 36 | outstanding child processes, close the corresponding temporary file 37 | descriptors. We'll stop short of actually killing the child processes, though. 38 | Library users should really be discouraged from putting us in this situation. *) 39 | let finalize_manager {pending} = Hashtbl.iter (fun _ (_,fd) -> Unix.close fd) pending 40 | 41 | let manager ?maxprocs () = 42 | let maxprocs = (match maxprocs with Some n -> n | None -> ncores ()) in 43 | let mgr = { 44 | maxprocs; 45 | pending = Hashtbl.create maxprocs; 46 | results = Hashtbl.create maxprocs 47 | } in begin 48 | Gc.finalise finalize_manager mgr; 49 | mgr 50 | end 51 | ;; 52 | 53 | (* internal: the default prefork actions *) 54 | let default_prefork () = 55 | flush stdout; 56 | flush stderr; 57 | Gc.full_major () 58 | ;; 59 | 60 | (* internal: the worker process *) 61 | let worker f x result_fd = 62 | (* perform the computation *) 63 | let result = 64 | try 65 | let ans = ((f x):'a) in 66 | `OK ans 67 | with 68 | | ChildExn info -> `Exn info 69 | | exn when Printexc.backtrace_status () -> `Exn ["_"; Printexc.to_string exn; Printexc.get_backtrace ()] 70 | | exn -> `Exn ["_"; Printexc.to_string exn] 71 | in 72 | (* write the results to result_fd *) 73 | try 74 | let result_chan = Unix.out_channel_of_descr result_fd in begin 75 | Marshal.(to_channel result_chan (result:('a result)) [Closures]); 76 | flush result_chan; 77 | close_out result_chan; 78 | exit 0 79 | end 80 | with exn -> begin 81 | eprintf "[PANIC] ForkWork subprocess %d (parent %d) failed to write result: %s\n" (Unix.getpid ()) (Unix.getppid ()) (Printexc.to_string exn); 82 | if Printexc.backtrace_status() then Printexc.print_backtrace stderr; 83 | exit 1 84 | end 85 | ;; 86 | 87 | (* internal: attempt to read a child process result from the temp file 88 | descriptor, and (whatever happens) close the file descriptor *) 89 | let receive_result pid result_fd = 90 | let result_chan = begin 91 | try 92 | (* detect if the child process exited abnormally before writing its result 93 | (it's also possible it crashes while writing the result; in this case we 94 | have to rely on Marshal to detect the truncation) *) 95 | let { Unix.st_size } = Unix.fstat result_fd in begin 96 | if st_size = 0 then failwith (sprintf "ForkWork subprocess %d (parent %d) exited abnormally" pid (Unix.getpid ())); 97 | ignore Unix.(lseek result_fd 0 SEEK_SET); 98 | Unix.in_channel_of_descr result_fd 99 | end 100 | with exn -> (Unix.close result_fd; raise exn) 101 | end in 102 | finally (fun () -> close_in result_chan) (fun () -> Marshal.from_channel result_chan) 103 | ;; 104 | 105 | (* internal: collect all newly-available results *) 106 | let collect_results (mgr:'a mgr) = 107 | (* poll the pending child processes to see which ones have exited since the 108 | last time we checked. 109 | TODO: is it safe to Hashtbl.remove during Hashtbl.iter? *) 110 | let pending = Hashtbl.fold (fun k v lst -> (k,v) :: lst) mgr.pending [] in 111 | List.iter 112 | (fun (id,(pid,result_fd)) -> if child_process_done pid then begin 113 | (* remove this child process from the 'pending' table *) 114 | Hashtbl.remove mgr.pending id; 115 | (* collect its result and store it in the 'results' table *) 116 | try 117 | let result = (((receive_result pid result_fd):'a result) :> 'a internal_result) in 118 | Hashtbl.add mgr.results id result 119 | with exn -> Hashtbl.add mgr.results id (`IPC_Failure exn) 120 | end) 121 | pending 122 | ;; 123 | 124 | exception Busy 125 | ;; 126 | 127 | let fork ?(prepare=default_prefork) ?(nonblocking=false) mgr f x = 128 | collect_results mgr; 129 | (* ensure there are fewer than maxprocs outstanding child processes *) 130 | while Hashtbl.length mgr.pending >= mgr.maxprocs do 131 | if nonblocking then raise Busy 132 | else ignore (Unix.wait ()); 133 | collect_results mgr 134 | done; 135 | let id = fresh_id () in 136 | let result_fd = unlinked_temp_fd () in 137 | prepare (); 138 | match Unix.fork () with 139 | | x when x < 0 -> assert false (* supposed to raise an exception, not this *) 140 | | 0 -> begin 141 | (* in child process: wipe out my copy of the manager state, since it's unneeded *) 142 | Hashtbl.iter (fun _ (_,fd) -> Unix.close fd) mgr.pending; 143 | Hashtbl.clear mgr.pending; Hashtbl.clear mgr.results; 144 | 145 | (* execute worker logic *) 146 | worker f x result_fd 147 | end 148 | | pid -> begin 149 | (* master process: add the new child process to the 'pending' table *) 150 | Hashtbl.add mgr.pending id (pid,result_fd); 151 | id 152 | end 153 | ;; 154 | 155 | exception IPC_Failure of job*exn 156 | ;; 157 | 158 | let result ?(keep=false) mgr job = 159 | collect_results mgr; 160 | try 161 | let ans = Hashtbl.find mgr.results job in begin 162 | if not keep then Hashtbl.remove mgr.results job; 163 | match ans with 164 | | (`OK _) as ans -> Some ans 165 | | (`Exn _) as ans -> Some ans 166 | | `IPC_Failure exn -> raise (IPC_Failure (job,exn)) 167 | end 168 | with Not_found -> begin 169 | ignore (Hashtbl.find mgr.pending job); (* raise Not_found if this job is unknown to us *) 170 | None 171 | end 172 | ;; 173 | 174 | let any_result ?(keep=false) mgr = 175 | collect_results mgr; 176 | let ans = ref None in begin 177 | (try 178 | Hashtbl.iter (fun job result -> ans := Some (job,result); raise Exit) mgr.results 179 | with Exit -> ()); 180 | match !ans with 181 | | None -> None 182 | | Some (job,result) -> begin 183 | if not keep then Hashtbl.remove mgr.results job; 184 | match result with 185 | | (`OK _) as x -> Some (job,x) 186 | | (`Exn _) as x -> Some (job,x) 187 | | `IPC_Failure exn -> raise (IPC_Failure (job,exn)) (* TODO: communicate job back to caller *) 188 | end 189 | end 190 | ;; 191 | 192 | let rec await_result ?keep mgr job = 193 | match result ?keep mgr job with 194 | | Some ans -> ans 195 | | None -> begin 196 | ignore (Unix.wait ()); 197 | await_result ?keep mgr job 198 | end 199 | ;; 200 | 201 | exception Idle 202 | ;; 203 | 204 | let rec await_any_result ?keep mgr = 205 | match any_result ?keep mgr with 206 | | Some ans -> ans 207 | | None when Hashtbl.length mgr.pending = 0 -> raise Idle 208 | | None -> begin 209 | ignore (Unix.wait ()); 210 | await_any_result ?keep mgr 211 | end 212 | ;; 213 | 214 | let rec await_all mgr = 215 | collect_results mgr; 216 | if Hashtbl.length mgr.pending > 0 then begin 217 | ignore (Unix.wait ()); 218 | await_all mgr 219 | end 220 | ;; 221 | 222 | exception ChildProcExn of string*(string option) 223 | ;; 224 | 225 | let ignore_results mgr = 226 | let results = Hashtbl.fold (fun k r lst -> (k,r) :: lst) mgr.results [] in 227 | List.iter 228 | (fun (job,res) -> 229 | Hashtbl.remove mgr.results job; 230 | match res with 231 | | `Exn info -> raise (ChildExn info) 232 | | `IPC_Failure exn -> raise (IPC_Failure (job,exn)) 233 | | `OK _ -> ()) 234 | results 235 | ;; 236 | 237 | let kill ?(wait=false) mgr job = 238 | try 239 | let (pid,result_fd) = Hashtbl.find mgr.pending job in begin 240 | Hashtbl.remove mgr.pending job; 241 | Unix.close result_fd; 242 | if not (child_process_done pid) then begin 243 | (try Unix.kill pid Sys.sigterm with _ -> ()); 244 | if wait then 245 | while not (child_process_done pid) do 246 | ignore (Unix.wait ()) 247 | done 248 | end 249 | end 250 | with Not_found when Hashtbl.mem mgr.results job -> Hashtbl.remove mgr.results job 251 | ;; 252 | 253 | let kill_all ?(wait=false) mgr = 254 | let pending = Hashtbl.fold (fun job (pid,fd) lst -> (job,pid,fd) :: lst) mgr.pending [] in begin 255 | (* SIGTERM everybody *) 256 | List.iter 257 | (fun (_,pid,_) -> 258 | try 259 | if not (child_process_done pid) then Unix.kill pid Sys.sigterm 260 | with _ -> ()) 261 | pending; 262 | (* wait, if requested *) 263 | if wait then 264 | List.iter 265 | (fun (_,pid,_) -> 266 | while not (child_process_done pid) do 267 | ignore (Unix.wait ()) 268 | done) 269 | pending; 270 | (* clean up *) 271 | List.iter (fun (job,_,fd) -> Hashtbl.remove mgr.pending job; Unix.close fd) pending 272 | end; 273 | let results = Hashtbl.fold (fun k _ lst -> k :: lst) mgr.results [] in 274 | List.iter (Hashtbl.remove mgr.results) results 275 | ;; 276 | 277 | let map_array ?maxprocs ?(fail_fast=false) f ar = 278 | let f' (i,x) = (i, (f x)) in 279 | let n = Array.length ar in 280 | let results = Array.make n None in 281 | let mgr = manager ?maxprocs () in 282 | let rec collect () = match any_result mgr with 283 | | None -> () 284 | | Some (job,`Exn info) -> begin 285 | if fail_fast then 286 | kill_all ~wait:true mgr 287 | else 288 | await_all mgr; 289 | raise (ChildExn info) 290 | end 291 | | Some (job,`OK (i,res)) -> begin 292 | assert (results.(i) = None); 293 | results.(i) <- Some res; 294 | collect () 295 | end 296 | in 297 | default_prefork (); 298 | for i = 0 to Array.length ar - 1 do 299 | collect (); 300 | ignore (fork ~prepare:Gc.minor mgr f' (i,ar.(i))) 301 | done; 302 | await_all mgr; 303 | collect (); 304 | Array.map (function Some x -> x | None -> assert false) results 305 | ;; 306 | 307 | let map_list ?maxprocs ?fail_fast f lst = Array.to_list (map_array ?maxprocs ?fail_fast f (Array.of_list lst)) 308 | ;; 309 | -------------------------------------------------------------------------------- /ForkWork.mli: -------------------------------------------------------------------------------- 1 | (** Fork child processes to perform work on multiple cores. 2 | 3 | ForkWork is intended for workloads that a master process can partition into 4 | independent jobs, each of which will typically take a while to execute 5 | (several seconds, or more). Also, the resulting values should not be too 6 | massive, since they must be marshalled for transmission back to the master 7 | process. *) 8 | 9 | (** Get the number of processors believed to be available. The library 10 | attempts to detect this at program startup (currently only works on Linux), 11 | and if that fails it defaults to 4. *) 12 | val ncores : unit -> int 13 | 14 | (** Override the number of processors believed to be available. 15 | 16 | @param detect if set to true, attempt to detect the number of processors, and 17 | if that fails then use the provided value. *) 18 | val set_ncores : ?detect:bool -> int -> unit 19 | 20 | (** {2 High-level interface} 21 | 22 | These map functions suffice for many use cases. *) 23 | 24 | val map_list : ?maxprocs:int -> ?fail_fast:bool -> ('a -> 'b) -> ('a list) -> ('b list) 25 | 26 | val map_array : ?maxprocs:int -> ?fail_fast:bool -> ('a -> 'b) -> ('a array) -> ('b array) 27 | (** Map a list or array, forking one child process per item to map. In 28 | general, the result type ['b] should not include anything that's difficult to 29 | marshal, including functions, exceptions, weak arrays, or custom values from C 30 | bindings. 31 | 32 | If a child process ends with an exception, the master process waits for any 33 | other running child processes to exit, and then raises an exception to the 34 | caller. However, the exception raised to the caller may not be the same one 35 | raised in the child process (see below). If multiple child processes end with 36 | exceptions, it is undefined which one the caller learns about. Once any 37 | exception is detected, no new child processes will be forked. 38 | 39 | @param maxprocs maximum number of child processes to run at any one time 40 | (default [ncores ()]). ForkWork takes care of keeping [maxprocs] child 41 | processes running at steady-state, even if their individual runtimes vary. 42 | 43 | @param fail_fast if set to true, then as soon as any child process ends with 44 | an exception, SIGTERM is sent to all other child processes, and the exception 45 | is raised to the caller once they all exit. *) 46 | 47 | exception ChildExn of string list 48 | (** Due to limitations of OCaml's marshalling capabilities, communication of 49 | exceptions from a child process to the master process is tightly restricted: 50 | 51 | - If the child process raises [ForkWork.ChildExn lst], the same exception is 52 | re-raised in the master process. You can put any information you want into 53 | the string list, including marshalled values. 54 | 55 | - If the child process ends with any other exception [exn], the master process 56 | sees either [ForkWork.ChildExn ["_"; Printexc.to_string exn]] or 57 | [ForkWork.ChildExn ["_"; Printexc.to_string exn; Printexc.get_backtrace ()]], 58 | depending on the status of [Printexc.backtrace_status ()]. 59 | 60 | - It follows that if you're raising [ChildExn] with information to be 61 | interpreted by the master process, you probably should not put the string 62 | ["_"] as the first element of the list. 63 | 64 | Another, more type-safe option is to encode errors in the result type instead 65 | of raising an exception. The disadvantage of this is that ForkWork would still 66 | proceed with running all the remaining map operations. 67 | 68 | @see < http://caml.inria.fr/mantis/view.php?id=1961 > Mantis: 0001961 (exception marshalling) 69 | *) 70 | 71 | (** {2 Lower-level interface } 72 | 73 | The lower-level interface provides much more control over child process 74 | scheduling and result retrieval. For example, the master process does not have 75 | to be blocked while child processes are running, and the result of any 76 | individual child process can be retrieved as soon as it finishes. 77 | 78 | {b Types} *) 79 | 80 | (** The type of a ForkWork manager for a particular result type *) 81 | type 'a mgr 82 | 83 | (** A child process can either complete successfully with a result or end with 84 | an exception, as described above. *) 85 | type 'a result = [`OK of 'a | `Exn of string list] 86 | 87 | (** An abstract value representing a forked child process *) 88 | type job 89 | 90 | (** {b Forking child processes} *) 91 | 92 | (** Create a job manager. 93 | 94 | @param maxprocs the maximum number of child processes the manager will permit 95 | at any one time (default [ncores ()]) *) 96 | val manager : ?maxprocs:int -> unit -> 'a mgr 97 | 98 | (** [ForkWork.fork mgr f x] forks a child process to compute [(f x)]. If the 99 | manager already has [maxprocs] outstanding jobs, then by default [fork] blocks 100 | until one of them exits. 101 | 102 | @param prepare actions to be performed immediately before invoking 103 | [Unix.fork]. The default actions are to flush stdout and stderr, and 104 | [Gc.full_major ()]. 105 | 106 | @param nonblocking if set to [true] and there are already [maxprocs] 107 | outstanding jobs, [fork] raises [Busy] instead of blocking. The low-level 108 | interface doesn't provide a way to "enqueue" an arbitrary number of jobs, but 109 | it's straightforward to layer such logic on top. *) 110 | val fork : ?prepare:(unit->unit) -> ?nonblocking:bool -> 'a mgr -> ('b -> 'a) -> 'b -> job 111 | 112 | (** raised by [fork] iff [~nonblocking:true] and the manager already has 113 | [maxprocs] outstanding child processes *) 114 | exception Busy 115 | 116 | (** {b Retrieving results} *) 117 | 118 | (** Non-blocking query for the result of a job. By default, if a result is 119 | returned, then it is also removed from the job manager's memory, such that 120 | future calls with the same job would raise [Not_found]. 121 | 122 | @return [None] if the job is still running. There are no side effects in 123 | this case. 124 | 125 | @raise Not_found if the job is not known to the manager 126 | 127 | @param keep setting to true keeps the result in the job manager's memory, so 128 | that it can be retrieved again. The result cannot be garbage-collected unless 129 | it is later removed. *) 130 | val result : ?keep:bool -> 'a mgr -> job -> 'a result option 131 | 132 | (** Non-blocking query for any available result. 133 | 134 | Repeated calls to [any_result] with [~keep:true] may return the same result. 135 | *) 136 | val any_result : ?keep:bool -> 'a mgr -> (job * 'a result) option 137 | 138 | (** Get the result of the job, blocking the caller until it's available. *) 139 | val await_result : ?keep:bool -> 'a mgr -> job -> 'a result 140 | 141 | (** Get the result of any job, blocking the caller until one is available. 142 | 143 | Repeated calls to [await_any_result] with [~keep:true] may return the same 144 | result. 145 | 146 | @raise Idle if no results are available and there are no outstanding jobs *) 147 | val await_any_result : ?keep:bool -> 'a mgr -> job * 'a result 148 | 149 | (** raised by [await_any_result] iff no results are available and there are no 150 | outstanding jobs *) 151 | exception Idle 152 | 153 | (** Block the caller until all outstanding jobs are done. The results of the 154 | jobs are still stored in the manager's memory, and can be retrieved as above. 155 | *) 156 | val await_all : 'a mgr -> unit 157 | 158 | (** Convenience function for child processes launched just for side-effects: 159 | for each result {e currently available} in the job manager's memory, remove it 160 | therefrom; and if it's an exception result, raise [ChildExn]. The result 161 | values are lost! This function never blocks; results from any still-running 162 | child processes remain pending. *) 163 | val ignore_results : 'a mgr -> unit 164 | 165 | (** Any of the result retrieval functions might raise [IPC_Failure] if an 166 | exception occurs while trying to receive a result from a child process. This 167 | is a severe internal error, and it's probably reasonable to clean up and abort 168 | the entire program if it occurs. Possible causes include: 169 | 170 | - Child process segfaults or is killed 171 | - System out of memory 172 | - System out of disk space 173 | - Corruption of certain temp files *) 174 | exception IPC_Failure of job*exn 175 | 176 | (** {b Killing jobs} *) 177 | 178 | (** Kill a job. The job is removed from the manager's memory and the child 179 | process is sent SIGTERM if it's still running. 180 | 181 | @param wait if set to true, wait for the child process to exit before 182 | returning. 183 | *) 184 | val kill : ?wait:bool -> 'a mgr -> job -> unit 185 | 186 | (** Kill all outstanding jobs, and also remove all results from the job 187 | manager's memory. This effectively resets the job manager. *) 188 | val kill_all : ?wait:bool -> 'a mgr -> unit 189 | 190 | (** {2 General restrictions} 191 | 192 | The master process {b SHOULD NOT}: 193 | - fork a new child process while multiple threads exist 194 | - call ForkWork functions concurrently from multiple threads. Excepting the 195 | previous point, calling ForkWork functions from multiple threads is OK if 196 | protected by a single mutex for all job managers. 197 | - use [Sys.command], [Unix.fork], [Unix.wait], or [Unix.waitpid] from multiple 198 | threads at any time. Using them in a single-threaded program is possible 199 | with the following restriction: if you [fork] your own child processes and 200 | subsequently [wait]/[waitpid] for them, you should not interleave any 201 | ForkWork functions in between those two steps. ([Sys.command] always 202 | satisfies this restriction in a single-threaded program.) 203 | - allow a ForkWork manager to be garbage-collected while it still has child 204 | processes running 205 | 206 | Child processes {b SHOULD NOT}: 207 | - use [Unix.fork] or [Unix.exec*] independently of each other (fork-exec and 208 | [Sys.command] are OK) 209 | - use any ForkWork-related state adopted from the master process 210 | - do anything you typically can't do from a forked child process, e.g. mutate 211 | global state and expect it to be reflected in the parent process 212 | - neglect to do any of the typical chores that may be required 213 | of a forked child process, e.g. closing sockets that were open in the master 214 | at the fork point (if they need to be closed promptly) 215 | 216 | Lastly, there's a pedantic chance of ForkWork operations hanging or sending 217 | SIGTERM to the wrong process if/when the kernel recycles process IDs. Do not 218 | use ForkWork for avionics, nuclear equipment, etc. *) 219 | -------------------------------------------------------------------------------- /Helpers.ml: -------------------------------------------------------------------------------- 1 | (* we don't use pid's to represent jobs because they can be recycled *) 2 | let fresh_id = 3 | let nxt = ref 0 in 4 | (fun () -> incr nxt; !nxt) 5 | ;; 6 | 7 | exception Inner of exn 8 | exception Finally of exn*exn 9 | let finally finalize f = 10 | try 11 | let ans = f () in begin 12 | (try finalize () with exn -> raise (Inner exn)); 13 | ans 14 | end 15 | with 16 | | Inner exn -> raise exn 17 | | exn -> begin 18 | (try finalize () with exn2 -> raise (Finally(exn,exn2))); 19 | raise exn 20 | end 21 | ;; 22 | 23 | (* Premature optimization: if available, use /dev/shm for temporary storage of 24 | subprocess results *) 25 | let temp_dir = 26 | try 27 | if Sys.is_directory "/run/shm" then Some "/run/shm" else None 28 | with Sys_error _ -> None 29 | ;; 30 | 31 | (* Create a temp file, unlink it, and return an open file descriptor. Child 32 | processes use these unlinked temp files to communicate their results back to 33 | the master. *) 34 | let unlinked_temp_fd () = 35 | let fn = Filename.temp_file ?temp_dir "ForkWork" "mar" in 36 | let fd = Unix.(openfile fn [O_RDWR] 0600) in begin 37 | Unix.unlink fn; 38 | fd 39 | end 40 | ;; 41 | 42 | (* Check if the child process pid has exited. Due to various complications 43 | with waitpid state management, we do not check the exit status -- instead, we 44 | will check for a result written to the temp file *) 45 | let child_process_done pid = 46 | try 47 | match Unix.(waitpid [WNOHANG] pid) with 48 | | (0,_) -> false 49 | | (pid',_) when pid=pid' -> true 50 | | _ -> assert false 51 | with Unix.Unix_error (Unix.ECHILD,_,_) -> true 52 | ;; 53 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 7c2c70ba9564ec78cc239fd10ddfc28b) 3 | version = "0.3.2" 4 | description = "Fork child processes to perform work on multiple cores" 5 | requires = "unix" 6 | archive(byte) = "forkwork.cma" 7 | archive(byte, plugin) = "forkwork.cma" 8 | archive(native) = "forkwork.cmxa" 9 | archive(native, plugin) = "forkwork.cmxs" 10 | exists_if = "forkwork.cma" 11 | # OASIS_STOP 12 | 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 37 | 38 | # OASIS_STOP 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [ForkWork](https://github.com/mlin/forkwork) 2 | 3 | A simple OCaml library for forking child processes to perform work on multiple cores. 4 | 5 | ForkWork is intended for workloads that a master process can partition into independent jobs, each of which will typically take a while to execute (several seconds, or more). Also, the resulting values should not be too massive, since they must be marshalled for transmission back to the master process. 6 | 7 | Among the numerous tools for multicore parallelism available in the OCaml ecosystem, ForkWork fits somewhere in between [Netmcore](http://projects.camlcity.org/projects/dl/ocamlnet-3.6.1/doc/html-main/Netmcore.html) and [Parmap](http://www.dicosmo.org/code/parmap/). It's a bit easier to use than the former, and a bit more flexible than the latter. 8 | 9 | ## API documentation 10 | 11 | See [ocamldoc:ForkWork](http://mlin.github.com/forkwork/ForkWork.html) 12 | 13 | ## Installation 14 | 15 | ForkWork is mainly tested on Linux and Mac OS X with OCaml 3.12 and above. It should work on most flavors of Unix. The easiest way to install it is by using [OPAM](http://opam.ocamlpro.com): 16 | `opam install forkwork`. 17 | 18 | If you don't use OPAM, set up [findlib](http://projects.camlcity.org/projects/findlib.html), 19 | define the `OCAMLFIND_DESTDIR` environment variable if necessary and 20 | 21 | ```git clone https://github.com/mlin/forkwork.git && cd forkwork && make && make install``` 22 | 23 | [![Build Status](https://travis-ci.org/mlin/forkwork.png)](https://travis-ci.org/mlin/forkwork) 24 | 25 | You can then use `ocamlfind` as usual to include the `forkwork` package when 26 | compiling your program (making sure `OCAMLPATH` includes `OCAMLFIND_DESTDIR` if 27 | you changed it). 28 | 29 | ## High-level example 30 | 31 | ForkWork provides a high-level interface consisting of parallel map functions for lists and arrays. Here's a program that forks four worker processes to compute a Monte Carlo estimate of π: 32 | 33 | ``` 34 | (* Worker: sample k points uniformly at random from the unit square; return 35 | how many fall inside and outside of the unit circle *) 36 | let worker k = 37 | Random.self_init (); 38 | let inside = ref 0 in 39 | let outside = ref 0 in begin 40 | for i = 1 to k do 41 | let x = Random.float 1.0 in 42 | let y = Random.float 1.0 in 43 | incr (if x *. x +. y *. y <= 1.0 then inside else outside) 44 | done; 45 | (!inside,!outside) 46 | end 47 | ;; 48 | 49 | let estimate_pi n k = 50 | (* Fork n parallel worker processes to collect samples *) 51 | let results = ForkWork.map_array worker (Array.make n k) in 52 | (* Combine the results and derive the estimate *) 53 | let insides, outsides = List.split (Array.to_list results) in 54 | let inside = float (List.fold_left (+) 0 insides) in 55 | let outside = float (List.fold_left (+) 0 outsides) in 56 | 4.0 *. (inside /. (inside +. outside)) 57 | ;; 58 | 59 | let n = 30 and k = 25_000_000 in 60 | Printf.printf "Based on %.1e samples, π ≈ %f\n" (float (n*k)) (estimate_pi n k) 61 | ;; 62 | ``` 63 | 64 | Run this like so: 65 | 66 | ``` 67 | $ ocamlfind ocamlopt -o estimate_pi -package forkwork -linkpkg estimate_pi.ml && time ./estimate_pi 68 | Based on 7.5e+08 samples, π ≈ 3.141497 69 | 70 | real 0m51.119s 71 | user 3m16.268s 72 | sys 0m1.084s 73 | ``` 74 | 75 | One other salient feature of ForkWork's high-level interface is that it tries to deal with worker exceptions in a reasonable way, which is difficult because exceptions [cannot be marshalled reliably](http://caml.inria.fr/mantis/view.php?id=1961). There's a mechanism for workers to cause ForkWork to both abort the parallel computation and also raise an OCaml exception to the caller with specifc information about the problem. The author was motivated to write ForkWork in part because similar existing libraries did not handle this well, at the time. 76 | 77 | ## Lower-level example 78 | 79 | There is also a lower-level interface providing much more control over the scheduling of child processes and retrieval of their results. For example, the master process can do other things while worker processes are running, including launch more worker processes, and the result of any individual child process can be retrieved as soon as it finishes. 80 | 81 | A [fancier version of the estimate_pi example](https://github.com/mlin/forkwork/blob/master/examples/estimate_pi_interval.ml) uses the lower-level interface to run the Monte Carlo sampling until the estimate reaches a certain theoretical accuracy threshold, using the available processors continuously and terminating the outstanding workers when done. 82 | 83 | ## Running tests 84 | 85 | The tests use [kaputt](http://kaputt.x9c.fr). To run them, `./configure --enable-tests` and `make test`. 86 | 87 | They also run on Travis CI: [![Build Status](https://travis-ci.org/mlin/forkwork.png)](https://travis-ci.org/mlin/forkwork) -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.3 2 | Name: forkwork 3 | Version: 0.3.2 4 | Synopsis: Fork child processes to perform work on multiple cores 5 | Authors: Mike Lin 6 | Maintainers: mlin@mlin.net 7 | License: LGPL-2.1 with OCaml linking exception 8 | Homepage: https://github.com/mlin/forkwork 9 | Description: ForkWork is intended for workloads that a master process can partition into independent jobs, each of which will typically take a while to execute (several seconds, or more). Also, the resulting values should not be too massive, since they must be marshalled for transmission back to the master process. 10 | 11 | Among the numerous tools for multicore parallelism available in the OCaml ecosystem, ForkWork fits somewhere in between Netmcore and Parmap. It's a bit easier to use than the former, and a bit more flexible than the latter. 12 | Plugins: DevFiles (0.3), META (0.3) 13 | 14 | Library forkwork 15 | Path: . 16 | BuildTools: ocamlbuild 17 | BuildDepends: unix 18 | Modules: ForkWork 19 | InternalModules: Helpers 20 | 21 | Executable unit_tests 22 | Path: . 23 | MainIs: tests.ml 24 | Install: false 25 | Build$: flag(tests) 26 | BuildTools: ocamlbuild 27 | BuildDepends: unix,kaputt,bigarray 28 | CompiledObject: best 29 | 30 | Test test 31 | TestTools: unit_tests 32 | Command: $unit_tests 33 | 34 | Document forkwork 35 | Title: ForkWork API reference 36 | Type: OCamlbuild (0.3) 37 | InstallDir: $docdir 38 | BuildTools: ocamlbuild,ocamldoc 39 | XOCamlbuildPath: . 40 | XOCamlbuildLibraries: forkwork 41 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2f02c96978e840ff424d5ab59b6343e5) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | <**/.svn>: -traverse 7 | <**/.svn>: not_hygienic 8 | ".bzr": -traverse 9 | ".bzr": not_hygienic 10 | ".hg": -traverse 11 | ".hg": not_hygienic 12 | ".git": -traverse 13 | ".git": not_hygienic 14 | "_darcs": -traverse 15 | "_darcs": not_hygienic 16 | # Library forkwork 17 | "forkwork.cmxs": use_forkwork 18 | # Executable unit_tests 19 | : pkg_unix 20 | : pkg_kaputt 21 | : pkg_bigarray 22 | <*.ml{,i}>: pkg_unix 23 | <*.ml{,i}>: pkg_kaputt 24 | <*.ml{,i}>: pkg_bigarray 25 | # OASIS_STOP 26 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /examples/estimate_pi.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Estimate pi using a ForkWork-powered Monte Carlo simulation. 3 | 4 | $ ocamlfind ocamlopt -o estimate_pi -package forkwork -linkpkg estimate_pi.ml && time ./estimate_pi 5 | Based on 1.0e+08 samples, π ≈ 3.141717 6 | 7 | real 0m6.843s 8 | user 0m26.428s 9 | sys 0m0.052s 10 | *) 11 | 12 | (* Worker: sample k points uniformly at random from the unit square; return 13 | how many fall inside and outside of the unit circle *) 14 | let worker k = 15 | Random.self_init (); 16 | let inside = ref 0 in 17 | let outside = ref 0 in begin 18 | for i = 1 to k do 19 | let x = Random.float 1.0 in 20 | let y = Random.float 1.0 in 21 | incr (if x *. x +. y *. y <= 1.0 then inside else outside) 22 | done; 23 | (!inside,!outside) 24 | end 25 | ;; 26 | 27 | let estimate_pi n k = 28 | (* Fork n parallel worker processes to collect samples *) 29 | let results = ForkWork.map_array worker (Array.make n k) in 30 | (* Combine the results and derive the estimate *) 31 | let insides, outsides = List.split (Array.to_list results) in 32 | let inside = float (List.fold_left (+) 0 insides) in 33 | let outside = float (List.fold_left (+) 0 outsides) in 34 | 4.0 *. (inside /. (inside +. outside)) 35 | ;; 36 | 37 | let n = 30 and k = 25_000_000 in 38 | Printf.printf "Based on %.1e samples, π ≈ %f\n" (float (n*k)) (estimate_pi n k) 39 | ;; 40 | -------------------------------------------------------------------------------- /examples/estimate_pi_interval.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Compute an interval estimate of pi, using a ForkWork-powered Monte Carlo 3 | simulation that runs until the estimate reaches a certain theoretical accuracy 4 | threshold. This is a demonstration of using ForkWork's lower-level interface 5 | so that the master process can do other things while child processes are 6 | working, including launch more child processes. 7 | 8 | $ ocamlfind ocamlopt -o estimate_pi_interval -package forkwork -linkpkg estimate_pi_interval.ml && time ./estimate_pi_interval 9 | Based on 1.8e+08 samples, π ∊ [3.141173,3.141663] 10 | 11 | real 0m16.962s 12 | user 1m3.540s 13 | sys 0m0.168s 14 | *) 15 | 16 | (* Worker: sample k points uniformly at random from the unit square; return 17 | how many fall inside and outside of the unit circle *) 18 | let worker k = 19 | Random.self_init (); 20 | let inside = ref 0 in 21 | let outside = ref 0 in begin 22 | for i = 1 to k do 23 | let x = Random.float 1.0 in 24 | let y = Random.float 1.0 in 25 | incr (if x *. x +. y *. y <= 1.0 then inside else outside) 26 | done; 27 | (!inside,!outside) 28 | end 29 | ;; 30 | 31 | (* Based on the samples taken so far, return a lower & upper bound on pi *) 32 | let pi_interval inside outside = 33 | (* Bayesian posterior mean & variance of the binomial proportion, with a 34 | uniform prior (Beta[1,1]) *) 35 | let a = float (inside+1) and b = float (outside+1) in 36 | let n = a +. b in 37 | let p = a /. n in 38 | let p_var = (a *. b) /. (n ** 3.0 +. n ** 2.0) in 39 | (* Perfect so far -- now do a lousy 2*sigma interval *) 40 | let pi = 4.0 *. p in 41 | let pi_sd = 4.0 *. sqrt p_var in 42 | (pi -. 2.0 *. pi_sd, pi +. 2.0 *. pi_sd) 43 | ;; 44 | 45 | (* Run the simulation until the credible interval is less than 'acc' wide *) 46 | let rec iter mgr acc k inside outside = 47 | let pi_lo, pi_hi = pi_interval inside outside in begin 48 | if pi_hi -. pi_lo <= acc then begin 49 | (* The estimate has reached the desired accuracy, so kill workers and 50 | report results *) 51 | ForkWork.kill_all mgr; 52 | Printf.printf "Based on %.1e samples, π ∊ [%f,%f]\n" (float (inside+outside)) pi_lo pi_hi 53 | end else 54 | (* Collect more data from whichever worker process finishes next. This 55 | blocks until it's available, but there's also a nonblocking version. *) 56 | match ForkWork.await_any_result mgr with 57 | | _, `OK (more_inside, more_outside) -> begin 58 | (* Launch a new worker process to replace the one whose result we 59 | just got; continue to the next iteration *) 60 | ignore (ForkWork.fork mgr worker k); 61 | iter mgr acc k (inside+more_inside) (outside+more_outside) 62 | end 63 | (* worker crashed or ended with an exception *) 64 | | _ -> assert false 65 | end 66 | ;; 67 | 68 | (* Instantiate the "ForkWork manager", launch the initial fleet of worker 69 | processes, and enter the main loop. *) 70 | let acc = 5e-4 and k = 10_000_000 in 71 | let mgr = ForkWork.manager () in begin 72 | for i = 1 to 4 do 73 | ignore (ForkWork.fork mgr worker k) 74 | done; 75 | iter mgr acc k 0 0 76 | end 77 | ;; 78 | -------------------------------------------------------------------------------- /forkwork.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 00c601b9dd49fc5246f3da12c314dc0d) 3 | ForkWork 4 | Helpers 5 | # OASIS_STOP 6 | -------------------------------------------------------------------------------- /forkwork.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 46853bf6eb15d46c07fa25c2432773fa) 3 | ForkWork 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 295f6b0cbc6499fec6712ee7aaebee63) *) 3 | module OASISGettext = struct 4 | (* # 21 "/home/mlin/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) 5 | 6 | let ns_ str = 7 | str 8 | 9 | let s_ str = 10 | str 11 | 12 | let f_ (str : ('a, 'b, 'c, 'd) format4) = 13 | str 14 | 15 | let fn_ fmt1 fmt2 n = 16 | if n = 1 then 17 | fmt1^^"" 18 | else 19 | fmt2^^"" 20 | 21 | let init = 22 | [] 23 | 24 | end 25 | 26 | module OASISExpr = struct 27 | (* # 21 "/home/mlin/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) 28 | 29 | 30 | 31 | open OASISGettext 32 | 33 | type test = string 34 | 35 | type flag = string 36 | 37 | type t = 38 | | EBool of bool 39 | | ENot of t 40 | | EAnd of t * t 41 | | EOr of t * t 42 | | EFlag of flag 43 | | ETest of test * string 44 | 45 | 46 | type 'a choices = (t * 'a) list 47 | 48 | let eval var_get t = 49 | let rec eval' = 50 | function 51 | | EBool b -> 52 | b 53 | 54 | | ENot e -> 55 | not (eval' e) 56 | 57 | | EAnd (e1, e2) -> 58 | (eval' e1) && (eval' e2) 59 | 60 | | EOr (e1, e2) -> 61 | (eval' e1) || (eval' e2) 62 | 63 | | EFlag nm -> 64 | let v = 65 | var_get nm 66 | in 67 | assert(v = "true" || v = "false"); 68 | (v = "true") 69 | 70 | | ETest (nm, vl) -> 71 | let v = 72 | var_get nm 73 | in 74 | (v = vl) 75 | in 76 | eval' t 77 | 78 | let choose ?printer ?name var_get lst = 79 | let rec choose_aux = 80 | function 81 | | (cond, vl) :: tl -> 82 | if eval var_get cond then 83 | vl 84 | else 85 | choose_aux tl 86 | | [] -> 87 | let str_lst = 88 | if lst = [] then 89 | s_ "" 90 | else 91 | String.concat 92 | (s_ ", ") 93 | (List.map 94 | (fun (cond, vl) -> 95 | match printer with 96 | | Some p -> p vl 97 | | None -> s_ "") 98 | lst) 99 | in 100 | match name with 101 | | Some nm -> 102 | failwith 103 | (Printf.sprintf 104 | (f_ "No result for the choice list '%s': %s") 105 | nm str_lst) 106 | | None -> 107 | failwith 108 | (Printf.sprintf 109 | (f_ "No result for a choice list: %s") 110 | str_lst) 111 | in 112 | choose_aux (List.rev lst) 113 | 114 | end 115 | 116 | 117 | # 117 "myocamlbuild.ml" 118 | module BaseEnvLight = struct 119 | (* # 21 "/home/mlin/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) 120 | 121 | module MapString = Map.Make(String) 122 | 123 | type t = string MapString.t 124 | 125 | let default_filename = 126 | Filename.concat 127 | (Sys.getcwd ()) 128 | "setup.data" 129 | 130 | let load ?(allow_empty=false) ?(filename=default_filename) () = 131 | if Sys.file_exists filename then 132 | begin 133 | let chn = 134 | open_in_bin filename 135 | in 136 | let st = 137 | Stream.of_channel chn 138 | in 139 | let line = 140 | ref 1 141 | in 142 | let st_line = 143 | Stream.from 144 | (fun _ -> 145 | try 146 | match Stream.next st with 147 | | '\n' -> incr line; Some '\n' 148 | | c -> Some c 149 | with Stream.Failure -> None) 150 | in 151 | let lexer = 152 | Genlex.make_lexer ["="] st_line 153 | in 154 | let rec read_file mp = 155 | match Stream.npeek 3 lexer with 156 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 157 | Stream.junk lexer; 158 | Stream.junk lexer; 159 | Stream.junk lexer; 160 | read_file (MapString.add nm value mp) 161 | | [] -> 162 | mp 163 | | _ -> 164 | failwith 165 | (Printf.sprintf 166 | "Malformed data file '%s' line %d" 167 | filename !line) 168 | in 169 | let mp = 170 | read_file MapString.empty 171 | in 172 | close_in chn; 173 | mp 174 | end 175 | else if allow_empty then 176 | begin 177 | MapString.empty 178 | end 179 | else 180 | begin 181 | failwith 182 | (Printf.sprintf 183 | "Unable to load environment, the file '%s' doesn't exist." 184 | filename) 185 | end 186 | 187 | let var_get name env = 188 | let rec var_expand str = 189 | let buff = 190 | Buffer.create ((String.length str) * 2) 191 | in 192 | Buffer.add_substitute 193 | buff 194 | (fun var -> 195 | try 196 | var_expand (MapString.find var env) 197 | with Not_found -> 198 | failwith 199 | (Printf.sprintf 200 | "No variable %s defined when trying to expand %S." 201 | var 202 | str)) 203 | str; 204 | Buffer.contents buff 205 | in 206 | var_expand (MapString.find name env) 207 | 208 | let var_choose lst env = 209 | OASISExpr.choose 210 | (fun nm -> var_get nm env) 211 | lst 212 | end 213 | 214 | 215 | # 215 "myocamlbuild.ml" 216 | module MyOCamlbuildFindlib = struct 217 | (* # 21 "/home/mlin/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 218 | 219 | (** OCamlbuild extension, copied from 220 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 221 | * by N. Pouillard and others 222 | * 223 | * Updated on 2009/02/28 224 | * 225 | * Modified by Sylvain Le Gall 226 | *) 227 | open Ocamlbuild_plugin 228 | 229 | (* these functions are not really officially exported *) 230 | let run_and_read = 231 | Ocamlbuild_pack.My_unix.run_and_read 232 | 233 | let blank_sep_strings = 234 | Ocamlbuild_pack.Lexers.blank_sep_strings 235 | 236 | let split s ch = 237 | let x = 238 | ref [] 239 | in 240 | let rec go s = 241 | let pos = 242 | String.index s ch 243 | in 244 | x := (String.before s pos)::!x; 245 | go (String.after s (pos + 1)) 246 | in 247 | try 248 | go s 249 | with Not_found -> !x 250 | 251 | let split_nl s = split s '\n' 252 | 253 | let before_space s = 254 | try 255 | String.before s (String.index s ' ') 256 | with Not_found -> s 257 | 258 | (* this lists all supported packages *) 259 | let find_packages () = 260 | List.map before_space (split_nl & run_and_read "ocamlfind list") 261 | 262 | (* this is supposed to list available syntaxes, but I don't know how to do it. *) 263 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 264 | 265 | (* ocamlfind command *) 266 | let ocamlfind x = S[A"ocamlfind"; x] 267 | 268 | let dispatch = 269 | function 270 | | Before_options -> 271 | (* by using Before_options one let command line options have an higher priority *) 272 | (* on the contrary using After_options will guarantee to have the higher priority *) 273 | (* override default commands by ocamlfind ones *) 274 | Options.ocamlc := ocamlfind & A"ocamlc"; 275 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 276 | Options.ocamldep := ocamlfind & A"ocamldep"; 277 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 278 | Options.ocamlmktop := ocamlfind & A"ocamlmktop" 279 | 280 | | After_rules -> 281 | 282 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 283 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 284 | 285 | (* For each ocamlfind package one inject the -package option when 286 | * compiling, computing dependencies, generating documentation and 287 | * linking. *) 288 | List.iter 289 | begin fun pkg -> 290 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; 291 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; 292 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; 293 | flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; 294 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; 295 | end 296 | (find_packages ()); 297 | 298 | (* Like -package but for extensions syntax. Morover -syntax is useless 299 | * when linking. *) 300 | List.iter begin fun syntax -> 301 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 302 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 303 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 304 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 305 | end (find_syntaxes ()); 306 | 307 | (* The default "thread" tag is not compatible with ocamlfind. 308 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 309 | * options when using this tag. When using the "-linkpkg" option with 310 | * ocamlfind, this module will then be added twice on the command line. 311 | * 312 | * To solve this, one approach is to add the "-thread" option when using 313 | * the "threads" package using the previous plugin. 314 | *) 315 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 316 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 317 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 318 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) 319 | 320 | | _ -> 321 | () 322 | 323 | end 324 | 325 | module MyOCamlbuildBase = struct 326 | (* # 21 "/home/mlin/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 327 | 328 | (** Base functions for writing myocamlbuild.ml 329 | @author Sylvain Le Gall 330 | *) 331 | 332 | 333 | 334 | open Ocamlbuild_plugin 335 | module OC = Ocamlbuild_pack.Ocaml_compiler 336 | 337 | type dir = string 338 | type file = string 339 | type name = string 340 | type tag = string 341 | 342 | (* # 56 "/home/mlin/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 343 | 344 | type t = 345 | { 346 | lib_ocaml: (name * dir list) list; 347 | lib_c: (name * dir * file list) list; 348 | flags: (tag list * (spec OASISExpr.choices)) list; 349 | (* Replace the 'dir: include' from _tags by a precise interdepends in 350 | * directory. 351 | *) 352 | includes: (dir * dir list) list; 353 | } 354 | 355 | let env_filename = 356 | Pathname.basename 357 | BaseEnvLight.default_filename 358 | 359 | let dispatch_combine lst = 360 | fun e -> 361 | List.iter 362 | (fun dispatch -> dispatch e) 363 | lst 364 | 365 | let tag_libstubs nm = 366 | "use_lib"^nm^"_stubs" 367 | 368 | let nm_libstubs nm = 369 | nm^"_stubs" 370 | 371 | let dispatch t e = 372 | let env = 373 | BaseEnvLight.load 374 | ~filename:env_filename 375 | ~allow_empty:true 376 | () 377 | in 378 | match e with 379 | | Before_options -> 380 | let no_trailing_dot s = 381 | if String.length s >= 1 && s.[0] = '.' then 382 | String.sub s 1 ((String.length s) - 1) 383 | else 384 | s 385 | in 386 | List.iter 387 | (fun (opt, var) -> 388 | try 389 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 390 | with Not_found -> 391 | Printf.eprintf "W: Cannot get variable %s" var) 392 | [ 393 | Options.ext_obj, "ext_obj"; 394 | Options.ext_lib, "ext_lib"; 395 | Options.ext_dll, "ext_dll"; 396 | ] 397 | 398 | | After_rules -> 399 | (* Declare OCaml libraries *) 400 | List.iter 401 | (function 402 | | nm, [] -> 403 | ocaml_lib nm 404 | | nm, dir :: tl -> 405 | ocaml_lib ~dir:dir (dir^"/"^nm); 406 | List.iter 407 | (fun dir -> 408 | List.iter 409 | (fun str -> 410 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 411 | ["compile"; "infer_interface"; "doc"]) 412 | tl) 413 | t.lib_ocaml; 414 | 415 | (* Declare directories dependencies, replace "include" in _tags. *) 416 | List.iter 417 | (fun (dir, include_dirs) -> 418 | Pathname.define_context dir include_dirs) 419 | t.includes; 420 | 421 | (* Declare C libraries *) 422 | List.iter 423 | (fun (lib, dir, headers) -> 424 | (* Handle C part of library *) 425 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 426 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 427 | A("-l"^(nm_libstubs lib))]); 428 | 429 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 430 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 431 | 432 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 433 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 434 | 435 | (* When ocaml link something that use the C library, then one 436 | need that file to be up to date. 437 | *) 438 | dep ["link"; "ocaml"; "program"; tag_libstubs lib] 439 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 440 | 441 | dep ["compile"; "ocaml"; "program"; tag_libstubs lib] 442 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 443 | 444 | (* TODO: be more specific about what depends on headers *) 445 | (* Depends on .h files *) 446 | dep ["compile"; "c"] 447 | headers; 448 | 449 | (* Setup search path for lib *) 450 | flag ["link"; "ocaml"; "use_"^lib] 451 | (S[A"-I"; P(dir)]); 452 | ) 453 | t.lib_c; 454 | 455 | (* Add flags *) 456 | List.iter 457 | (fun (tags, cond_specs) -> 458 | let spec = 459 | BaseEnvLight.var_choose cond_specs env 460 | in 461 | flag tags & spec) 462 | t.flags 463 | | _ -> 464 | () 465 | 466 | let dispatch_default t = 467 | dispatch_combine 468 | [ 469 | dispatch t; 470 | MyOCamlbuildFindlib.dispatch; 471 | ] 472 | 473 | end 474 | 475 | 476 | # 476 "myocamlbuild.ml" 477 | open Ocamlbuild_plugin;; 478 | let package_default = 479 | { 480 | MyOCamlbuildBase.lib_ocaml = [("forkwork", [])]; 481 | lib_c = []; 482 | flags = []; 483 | includes = []; 484 | } 485 | ;; 486 | 487 | let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; 488 | 489 | # 490 "myocamlbuild.ml" 490 | (* OASIS_STOP *) 491 | Ocamlbuild_plugin.dispatch dispatch_default;; 492 | -------------------------------------------------------------------------------- /tests.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open ForkWork 3 | open Kaputt.Abbreviations 4 | ;; 5 | 6 | Test.add_simple_test ~title:"fork a subprocess and recover the result" (fun () -> 7 | let mgr = manager () in 8 | let iou = fork mgr (fun () -> 42) () in 9 | let ans = await_result mgr iou in 10 | Assert.equal (`OK 42) ans) 11 | ;; 12 | 13 | Test.add_simple_test ~title:"fork a subprocess and recover a specific ChildExn" (fun () -> 14 | let mgr = manager () in 15 | let iou = fork mgr (fun () -> raise (ForkWork.ChildExn ["foo"])) () in 16 | Assert.is_true (match await_result mgr iou with `Exn ["foo"] -> true | _ -> false)) 17 | ;; 18 | 19 | exception MyException of int 20 | ;; 21 | 22 | Test.add_simple_test ~title:"fork a subprocess and recover some other exception" (fun () -> 23 | let mgr = manager () in 24 | let iou = fork mgr (fun () -> raise (MyException 42)) () in 25 | Assert.is_true (match await_result mgr iou with `Exn ("_" :: _) -> true | _ -> false)) 26 | ;; 27 | 28 | Test.add_simple_test ~title:"raise IPC_Failure upon abnormal exit of a subprocess" (fun () -> 29 | let mgr = manager () in 30 | let iou = fork mgr (fun () -> exit 1) () in 31 | Assert.make_raises 32 | (function IPC_Failure _ -> true | _ -> false) 33 | Printexc.to_string 34 | (fun () -> ForkWork.await_result mgr iou)) 35 | ;; 36 | 37 | exception Fdcount 38 | ;; 39 | 40 | let fdcount () = 41 | let dir = sprintf "/proc/%d/fd" (Unix.getpid ()) in 42 | if not (Sys.file_exists dir && Sys.is_directory dir) then raise Fdcount; 43 | Array.length (Sys.readdir dir) 44 | ;; 45 | 46 | Test.add_simple_test ~title:"don't leak file descriptors" (fun () -> 47 | try 48 | let fd0 = fdcount () in 49 | let mgr = manager () in 50 | let worker i = match i mod 4 with 51 | | 0 -> 42 52 | | 1 -> raise (MyException 42) 53 | | 2 -> exit 0 54 | | 3 -> exit 1 55 | | _ -> assert false 56 | in begin 57 | for i = 1 to 64 do 58 | ignore (fork mgr worker i) 59 | done; 60 | await_all mgr; 61 | Assert.equal fd0 (fdcount ()) 62 | end 63 | with Fdcount -> printf "(skipping file descriptor leak tests since /proc/%d/fd does not exist)\n" (Unix.getpid ())) 64 | ;; 65 | 66 | Test.add_simple_test ~title:"use Sys.command in child processes" (fun () -> 67 | let randsleep () = ignore (Sys.command (sprintf "sleep %.2f" (Random.float 1.0))) in 68 | let intmgr = manager ~maxprocs:4 () in 69 | let floatmgr = manager ~maxprocs:4 () in 70 | let strmgr = manager ~maxprocs:4 () in begin 71 | for i = 1 to 4 do 72 | ignore (fork intmgr (fun () -> randsleep (); Random.int 1234567) ()); 73 | ignore (fork floatmgr (fun () -> randsleep (); Random.float 1.0) ()); 74 | ignore (fork strmgr (fun () -> randsleep (); String.create (Random.int 1000)) ()) 75 | done; 76 | await_all intmgr; ignore_results intmgr; 77 | await_all floatmgr; ignore_results floatmgr; 78 | await_all strmgr; ignore_results strmgr 79 | end) 80 | ;; 81 | 82 | Test.add_simple_test ~title:"use Sys.command in master process" (fun () -> 83 | let randsleep () = ignore (Sys.command (sprintf "sleep %.2f" (Random.float 0.1))) in 84 | let mgr = manager ~maxprocs:10 () in begin 85 | for i = 1 to 50 do 86 | (try ignore (fork ~nonblocking:true mgr randsleep ()) with Busy -> ()); 87 | randsleep () 88 | done; 89 | await_all mgr; 90 | ignore_results mgr 91 | end) 92 | ;; 93 | 94 | Test.add_assert_test ~title:"kill a child process" 95 | (fun () -> Filename.temp_file "ForkWorkTests" "") 96 | (fun fn -> 97 | let f () = (Unix.sleep 2; ignore (Sys.command ("echo foo > " ^ fn))) in 98 | let mgr = manager () in 99 | let job = fork mgr f () in begin 100 | Unix.sleep 1; 101 | kill ~wait:true mgr job; 102 | Unix.sleep 2; 103 | Assert.equal_int 0 Unix.((stat fn).st_size); 104 | fn 105 | end) 106 | Sys.remove 107 | ;; 108 | 109 | let abort_map_test fail_fast fn = 110 | let fd = Unix.(openfile fn [O_RDWR] 0o600) in 111 | Assert.equal 128 (Unix.write fd (String.make 128 (Char.chr 0)) 0 128); 112 | let shm = Bigarray.Array1.map_file fd ~pos:0L Bigarray.nativeint Bigarray.c_layout true (-1) in 113 | let f i = 114 | if i = 10 then failwith ""; 115 | Unix.sleep 1; 116 | shm.{i} <- Nativeint.one (* I sure hope this is atomic! *) 117 | in begin 118 | Assert.raises (fun () -> map_array f (Array.init 16 (fun i -> i))); 119 | let zeroes = ref 0 in begin 120 | for i = 0 to 15 do 121 | match shm.{i} with 122 | | x when x = Nativeint.zero -> incr zeroes 123 | | x when x = Nativeint.one -> () 124 | | _ -> assert false 125 | done; 126 | (* Check that at least 1 < N < 16 processes did not complete. Hmm, I suppose 127 | this is not actually guaranteed to happen, but it seems very likely. *) 128 | Assert.is_true (!zeroes > 1 && !zeroes < 16); 129 | Unix.close fd; 130 | fn 131 | end 132 | end 133 | ;; 134 | 135 | Test.add_assert_test ~title:"ChildExn aborts the map operation" 136 | (fun () -> Filename.temp_file "ForkWorkTests" "") 137 | (abort_map_test false) 138 | Sys.remove 139 | ;; 140 | 141 | Test.add_assert_test ~title:"ChildExn aborts the map operation (fail_fast)" 142 | (fun () -> Filename.temp_file "ForkWorkTests" "") 143 | (abort_map_test true) 144 | Sys.remove 145 | ;; 146 | 147 | 148 | let timed f x = 149 | let t0 = Unix.gettimeofday () in 150 | let y = f x in 151 | y, (Unix.gettimeofday () -. t0) 152 | ;; 153 | 154 | Test.add_simple_test ~title:"speed up estimation of pi" (fun () -> 155 | let f n = 156 | Random.init n; 157 | let inside = ref 0 in 158 | let outside = ref 0 in begin 159 | for i = 1 to n do 160 | let x = Random.float 1.0 in 161 | let y = Random.float 1.0 in 162 | incr (if x *. x +. y *. y < 1.0 then inside else outside) 163 | done; 164 | (!inside,!outside) 165 | end 166 | in 167 | let inputs = Array.init 32 (fun i -> int_of_float (1e6 *. (Random.float 10.0))) in 168 | let par_results, par_time = timed (map_list f) (Array.to_list inputs) in 169 | let _, ser_time = timed (Array.map f) inputs in 170 | let speedup = ser_time /. par_time in 171 | let insides, outsides = List.split par_results in 172 | let inside = float (List.fold_left (+) 0 insides) in 173 | let outside = float (List.fold_left (+) 0 outsides) in 174 | let est_pi = 4.0 *. (inside /. (inside +. outside)) in 175 | printf "speedup on estimation of pi: %.2fx; estimate = %f\n" speedup est_pi) 176 | ;; 177 | 178 | open Test 179 | ;; 180 | launch_tests () 181 | ;; -------------------------------------------------------------------------------- /travis-ci.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -ex 2 | 3 | # OPAM version to install 4 | export OPAM_VERSION=1.0.0 5 | # OPAM packages needed to build tests 6 | export OPAM_PACKAGES='ocamlfind kaputt' 7 | 8 | # install ocaml from apt 9 | sudo apt-get update -qq 10 | sudo apt-get install -qq ocaml 11 | 12 | # install opam 13 | curl -L https://github.com/OCamlPro/opam/archive/${OPAM_VERSION}.tar.gz | tar xz -C /tmp 14 | pushd /tmp/opam-${OPAM_VERSION} 15 | ./configure 16 | make 17 | sudo make install 18 | opam init -y 19 | eval `opam config env` 20 | popd 21 | 22 | # install packages from opam 23 | opam install -q -y ${OPAM_PACKAGES} 24 | 25 | # compile & run tests (an OASIS DevFiles project might use ./configure --enable-tests && make test) 26 | ./configure --enable-tests 27 | make test 28 | --------------------------------------------------------------------------------