(* Programs that use system threads must be linked as follows: * ocamlc -thread other options unix.cma threads.cma other files * ocamlopt -thread other options unix.cmxa threads.cmxa other files * * To get a version of the ocaml top level with threads, run: * ocamlmktop -thread unix.cma threads.cma -o mytop * Then run the resulting executable: ./mytop -I +threads *) (* PRODUCER/CONSUMER PATTERN using mutex. * * A shared queue, with one group of threads storing data in the queue * (producers) and the other removing it (consumers). Each party * accessing the queue excludes the others. * * To guarantee proper operation, the queue is manipulated by only one * party at a time in order to ensure that the insert and remove * operations on the queue maintain their integrity, using a mutex to * guarantee exclusion. * *) let f = Queue.create() and m = Mutex.create() let produce i p d = incr p; Thread.delay d; (* Simulate time to produce something by sleeping *) Printf.printf "Producer %d has produced %d" i !p; print_newline() (* Lock the mutex (blocking until it is free) before adding to the * queue, unlock when done. For illustration here printing is done in * the critical section, but generally doing IO with a mutex locked is * not a good idea because it prevents others who might be waiting for * the mutex from running, while doing something that is non-CPU * intensive. *) let store i p = Mutex.lock m; Queue.add (i, !p) f; Printf.printf "Producer %d has added its %d-th product" i !p; print_newline(); Mutex.unlock m (* A producer has a product counter p and a time d it takes to produce * a unit. They produce a unit and then store it, saving both producer * id and product counter. store gets the lock before accessing the * queue and releases it after. *) let producer (n, i) = let p = ref 0 and d = Random.float 2. in for j = 1 to n do produce i p d; store i p; Thread.delay (Random.float 2.5) done; Printf.printf "Producer %d is exiting." i; print_newline() (* A consumer tries to get a unit, with try/catch handling when * queue is empty. Prints out own id, and if gets product then * producer id and product id *) let consumer (n, i) = for j = 1 to n do Mutex.lock m; (try let ip, p = Queue.take f in Printf.printf "Consumer %d has taken product (%d,%d)" i ip p; print_newline() with Queue.Empty -> Printf.printf "Consumer %d has returned empty-handed" i; print_newline()); Mutex.unlock m; Thread.delay (Random.float 2.5) done; Printf.printf "Consumer %d is exiting." i; print_newline() (* Let's try four producers and four consumers *) let test_producer_consumer () = for i = 1 to 4 do ignore (Thread.create producer (25, i)); ignore (Thread.create consumer (50, i)) done (* PRODUCER/CONSUMER REVISITED with condition variables, so consumer * waits for goods if there are none. * * Mutual exclusion used above is very coarse grained, it is often * desirable to communicate conditions between processes/threads. For * instance one could have consumers wait until stock is re-supplied * rather than trying, failing and leaving empty handed (doing no * work). This can be done by having the producers signal when stock * has been added using a condition variable. *) let c = Condition.create() (* As above, but signal that condition of product being ready is true after storing product and before releasing lock. *) let store2 i p = Mutex.lock m; Queue.add (i, !p) f; Printf.printf "Producer %d has added its %d-th product" i !p; print_newline(); Condition.signal c; Mutex.unlock m (* As above, but using new store function that sends signal that * material has been produced *) let producer2 (n, i) = let p = ref 0 and d = Random.float 2. in for j = 1 to n do produce i p d; store2 i p; Thread.delay (Random.float 2.5) done; Printf.printf "Producer %d is exiting." i; print_newline() (* Wait for the condition of product being available to be true before * taking from the queue . *NOTE* wait2 returns with mutex locked, * which must be promptly unlocked. * * If this were done without the Condition.wait then this would be a * busy-wait (using up CPU unlike sleeping) looking for something in * the queue but with the lock held. Nothing could ever be put in the * queue because we would hold the lock, so it would loop forever. *) let wait i = Mutex.lock m; (* Standard pattern for use of condition variable: with the mutex * locked check that we can do work, if not wait (possibly again). *) while Queue.length f = 0 do Printf.printf "Consumer %d is waiting" i; print_newline(); (* Condition.wait releases mutex, waits (sleeps) for condition, * reacquires mutex when woken. Since it's in the while loop, upon * waking goes back and checks Queue.length and if nothing * is still available then waits again, else exits and returns. *) Condition.wait c m done (* Take from the queue, which is guaranteed to have something in it * because wait (which must be called immediately prior to this) only * returns when something is in the queue, and does so with the mutex * locked so nobody else will have emptied the queue. Print producer id * and product id. When done release the lock. *) let take i = let ip, p = Queue.take f in Printf.printf "Consumer %d has taken product (%d,%d)" i ip p; print_newline(); (* Note *MUST* unlock the mutex or eveyone is blocked. The * separation of the code into wait which takes the lock and take * which releases it makes this not apparent and can be a source * of bugs. *) Mutex.unlock m let consumer2 (n, i) = for j = 1 to n do (* wait is locking the mutex and take is unlocking it, so do not place other computation between these unless it is supposed to be done in the critical section. *) wait i; take i; Thread.delay (Random.float 2.5) done; Printf.printf "Consumer %d is exiting." i; print_newline() (* Let's try four producers and four consumers, using conditions so * consumers never leave empty handed. *) let test_producer_consumer2 () = for i = 1 to 4 do ignore (Thread.create producer2 (25, i)); ignore (Thread.create consumer2 (25, i)) done (* THREAD POOL - on creation a set of worker threads are started. * Work to be done is added to the thread pool, and an available worker * thread gets to that work when it can. There are no guarantees about * when the work will be done, or in what order. *) module type SIMPLE_THREAD_POOL = sig type pool (* A No_workers exception is thrown if addwork is called when the threadpool is being shut down. The work is not added. *) exception No_workers (* create a thread pool with the specified number of worker threads *) val create: int -> pool (* add work to the pool, where work is any unit -> unit function *) val addwork: (unit -> unit) -> pool -> unit (* destroy a thread pool, stopping all the threads once all work * in the pool has been completed. *) val destroy: pool -> unit end let debug = true let dbgprint str = if debug then (Printf.printf "Worker %d is %s" (Thread.id (Thread.self())) str; print_newline()) else () module Tpool : SIMPLE_THREAD_POOL = struct (* Implementation as a 4-tuple of: thread count, mutable queue of * functions waiting to be run, mutex protecting thread count and * queue, and condition variable signaling work to be done. *) type pool = (int ref * (unit -> unit) Queue.t * Mutex.t * Condition.t) exception No_workers (* Loop run by each worker thread, consumes work from the queue * following producer/consumer pattern with a condition variable, * described previously. *) let dowork (tp : pool) = match tp with (nworkers, q, m, c) -> Mutex.lock m; (* When nworkers <= 0, the thread pool is being * destroyed. If that is true and there is also no work left to do * then stop looping and drop through to exit processing. *) while (!nworkers > 0) || (Queue.length q > 0) do (* If nworkers > 0, wait for stuff in the queue. *) while (!nworkers > 0) && (Queue.length q = 0) do dbgprint "waiting"; Condition.wait c m done; (* Verify something in the queue rather than we are now being * shut down, then get the work from the queue, unlock the * mutex, do the work and relock the mutex before looping * back. *) if Queue.length q > 0 then let f = Queue.take q in dbgprint "starting work"; Mutex.unlock m; (* Don't let an exception in the work, f, kill the thread, * just catch it and go on. *) (try ignore (f()) with _ -> ()); Mutex.lock m done; (* A worker thread exits when the pool is being shut down. It * decrements the worker count, which should be -n when all * threads are finished, where n was the number of threads in * the pool (counts down from 0). *) decr nworkers; dbgprint "exiting"; Mutex.unlock m (* Creates the counter, queue, mutex used to protect these mutable * variables, and condition used to signal worker threads. Creates * the specified number of threads, each running the dowork * loop. Returns the newly created threadpool. *) let create size = if size < 1 then failwith "Tpool create needs at least one thread" else let tp = (ref 0, Queue.create(), Mutex.create(), Condition.create()) in match tp with (nworkers, _, m, _) -> Mutex.lock m; while !nworkers < size do ignore (Thread.create dowork tp); incr nworkers done; Mutex.unlock m; tp (* Adds the specified function as work to the thread pool's work * queue, following producer/consumer pattern using condition * variable described previously. Note that work need not run in the * order it was added (it will be dequeued in order but the threads * need not run sequentially). *) let addwork (f : unit -> unit) (tp : pool) = match tp with (nworkers, q, m, c) -> Mutex.lock m; if !nworkers < 1 then (Mutex.unlock m; raise No_workers) else (Queue.add f q; Condition.signal c; Mutex.unlock m) (* Waits for all threads to exit, each of which decrements nworkers * from 0, so when it gets to -n we are done. Used in destroy. *) let rec done_wait (tp : pool) (n : int) = match tp with (nworkers, _, m, _) -> Mutex.lock m; if !nworkers <= -n then Mutex.unlock m else (Printf.printf "Tpool destroy, still waiting for %d threads." (n + !nworkers); print_newline(); Mutex.unlock m; Thread.delay 0.1; done_wait tp n) (* Destroys the thread pool by setting nworkers to zero, then wakes * all threads waiting for the worker condition variable so that they * can exit if they find no work in the queue remaining to be * done. Note any worker thread caught in an infinite loop will not * be stopped this way and tpool will not shut down. Keeping a list * of worker thread id's and using Thread.kill after some timeout * would be the right way to handle this, but Thread.kill is not * implemented in all OCaml versions. *) let destroy (tp : pool) = match tp with (nworkers, _, m, c) -> Mutex.lock m; let n = !nworkers in nworkers := 0; Condition.broadcast c; Mutex.unlock m; done_wait tp n end (* TESTING: create a thread pool with t threads, add n units of work to the threadpool in two threads, sleep for 1 second, add n more units of work in main thread, then destroy the pool. *) let test_tpool (t, num) = let tp = Tpool.create t in let rec iter n = if n <= 0 then () else (Tpool.addwork (function () -> dbgprint "doing one unit of work"; ignore (3/0)) tp; print_endline "Added work unit"; iter (n - 1)) in ignore (Thread.create iter (num/2)); ignore (Thread.create iter (num/2)); Thread.delay 1.0; iter num; Tpool.destroy tp (* Testing which adds one job that loops for a while to test destroy wait for finish. *) let test_tpool2 (t, num) = let tp = Tpool.create t in let rec iter n = if n <= 0 then () else (Tpool.addwork (function () -> dbgprint "doing one unit of work"; ignore (3/0)) tp; print_endline "Added work unit"; iter (n - 1)) in ignore (Thread.create iter (num/2)); ignore (Thread.create iter (num/2)); Thread.delay 1.0; Tpool.addwork (function () -> for i = 1 to 50 do dbgprint "looping"; Thread.delay 0.1 done) tp; iter num; Tpool.destroy tp