(* remember to compile with ocamlc -vmthread threads.cma lec19.ml with any other options between the -vmthread and the threads.cma *) open Thread (* equivalence example *) let x, y = ref 0, ref 0 let _ = create (fun () -> if (!y)=1 then x:=(!x)+1) () (* 0 *) let _ = create (fun () -> if (!x)=1 then y:=(!y)+1) () (* 1 *) let _ = create (fun () -> y:=(!y)+1; if (!x)<>1 then y:=(!y)-1) () (* 2 *) (* Notice 0+1 is data-race free but 1+2 is not *) (* fork-join patterns note that caml provides a convenient syntax, but since the implementation runs only one thread at a time, none of this is worthwhile *) (* val fork_join : ('a -> 'b array) -> ('b -> 'c) -> ('c array -> 'd) -> 'a -> 'd *) let fork_join chunker processor merger data = let input_array = chunker data in let len = Array.length input_array in let output_array = Array.make len None in let thread_array = Array.mapi (fun index chunk -> Thread.create (fun () -> Array.set output_array index (Some(processor chunk))) ()) input_array in let _ = Array.iter join thread_array in (* wait! *) merger (Array.map (fun (Some x) -> x) output_array) (* Notice there is mutation in fork_join implementation, but its _interface_ is purely functional (if client doesn't mutate arrays) *) (* map over an array using /recursive/ divide-and-conquer *) let sequential_cutoff = 5000 let pmap f arr = (* assumes array length > 0 *) let ans = Array.make (Array.length arr) (f arr.(0)) in let rec for_range lo hi = if hi - lo < sequential_cutoff then let rec loop i = if i < hi then ((ans.(i) <- f arr.(i)); loop (i+1)) else () in loop lo else let t = Thread.create (fun () -> for_range ((lo+hi)/2) hi) () in for_range lo ((lo+hi)/2); Thread.join t in for_range 1 (Array.length arr); ans (* reduce over an array using /recursive/ divide-and-conquer operator should be associative (need not be commutative) *) let preduce f_elt f_combine arr = (* assumes array length > 0 *) let rec for_range lo hi = if hi - lo < sequential_cutoff then let rec loop v i = if i < hi then loop (f_combine v (f_elt arr.(i))) (i+1) else v in loop (f_elt arr.(lo)) (lo+1) else let r_ans = ref None in let t = Thread.create (fun () -> r_ans := Some (for_range ((lo+hi)/2) hi)) () in let l_ans = for_range lo ((lo+hi)/2) in Thread.join t; f_combine l_ans ((fun (Some x) -> x) !r_ans) in for_range 0 (Array.length arr) (* futures pattern *) (* interface for futures is functional: type 'a promise; abstract type constructor val future : (unit -> 'a) -> 'a promise creates parallelism val force : 'a promise -> 'a may block Implementation on top of shared memory straightforward: *) type 'a promise = Thread.t * 'a option ref let future thunk = let r = ref None in let thread = Thread.create (fun () -> r := Some (thunk ())) () in (thread, r) let force (thread,r) = Thread.join thread; match !r with Some ans -> ans | None -> failwith "impossible: promise should be set" (* basic example with locks *) type acct = { lk : Mutex.t; bal : float ref; avail : float ref } let mkAcct () = { lk = Mutex.create(); bal = ref 0.0; avail = ref 0.0 } let get a f = Mutex.lock a.lk; (if(!(a.avail) > f) then (a.bal := !(a.bal) -. f; a.avail := !(a.avail) -. f)); Mutex.unlock a.lk let put a f = Mutex.lock a.lk; a.bal := !(a.bal) +. f; a.avail := !(a.avail) +. (if f < 500. then f else 500.); Mutex.unlock a.lk let xferRace1 a1 a2 f = get a1 f; put a2 f let xferRace2 a1 a2 f = put a2 f; get a1 f (* breaks abstraction and doesn't work *) let xferDeadlock a1 a2 f = Mutex.lock a1.lk; Mutex.lock a2.lk; (if(!(a1.avail) > f) then (a1.bal := !(a1.bal) -. f; a1.avail := !(a1.avail) -. f; a2.bal := !(a2.bal) +. f; a2.avail := !(a2.avail) +. (if f < 500. then f else 500.))); Mutex.unlock a2.lk; Mutex.unlock a1.lk