From ebd847dc8bf5362af9fc97750d616b700146728e Mon Sep 17 00:00:00 2001 From: Luc Maranget Date: Thu, 22 Jul 2004 17:23:48 +0000 Subject: [PATCH] bit vectors does not work yet git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@6563 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/transljoin.ml | 62 +++++++++++++++-- otherlibs/threads/join.ml | 135 ++++++++++++++++++++++++++----------- otherlibs/threads/join.mli | 35 +++++----- 3 files changed, 172 insertions(+), 60 deletions(-) diff --git a/bytecomp/transljoin.ml b/bytecomp/transljoin.ml index a13089da29b4..160c1e062174 100644 --- a/bytecomp/transljoin.ml +++ b/bytecomp/transljoin.ml @@ -600,15 +600,68 @@ let build_lets bds r = | Some y -> Llet (Strict, y, lam, r)) bds r -let build_mask names jpats = + +let nslots n_names = (n_names + 30) / 31 +let major i = i / 31 +and minor i = i mod 31 + +let build_singleton n_names num = + if n_names < 32 then + lambda_int (1 lsl num) + else + let nslots = nslots n_names + and slot = major num + and idx = minor num in + let rec do_rec i = + if i >= nslots then [] + else + lambda_int + (if i = slot then (1 lsl idx) else 0):: + do_rec (i+1) in + Lprim (Pmakearray Pintarray, do_rec 0) + + +let build_int_mask names jpats = let rec do_rec mask = function | [] -> mask | jpat::rem -> let jid,_ = jpat.jpat_desc in let i = get_num "(build_mask)" names jid.jident_desc in do_rec (mask lor (1 lsl i)) rem in - do_rec 0 jpats + lambda_int (do_rec 0 jpats) + +and build_bv_mask n_names names jpats = + let nslots = nslots n_names in + + let rec empty i = + if i <= 0 then [] + else 0::empty (i-1) in + + let rec set_bit slot idx i = function + | [] -> assert false + | num::rem -> + if i = slot then + num lor (1 lsl idx)::rem + else + num::set_bit slot idx (i+1) rem in + + let rec do_rec mask = function + | [] -> mask + | jpat::rem -> + let jid,_ = jpat.jpat_desc in + let i = get_num "(build_mask)" names jid.jident_desc in + do_rec + (set_bit (major i) (minor i) 0 mask) rem in + + Lprim + (Pmakearray Pintarray, + List.map lambda_int (do_rec (empty nslots) jpats)) +let build_mask n_names names jpats = + if n_names < 32 then + build_int_mask names jpats + else + build_bv_mask n_names names jpats let rec explode = function | [] -> [] @@ -630,6 +683,7 @@ let create_table some_loc auto1 gs r = let ngs = Array.length gs and name = auto1.jauto_name and names = auto1.jauto_names in + let n_names = List.length names in let rec do_guard i = if i >= ngs then [] @@ -663,7 +717,7 @@ let create_table some_loc auto1 gs r = Lapply (Lvar g, [do_get_queue (Lvar name) num])])) in Lprim (Pmakeblock (0, Immutable), - [lambda_int (1 lsl num); lambda_int ipri; lam]) + [build_singleton n_names num ; lambda_int ipri; lam]) ::do_guard (i+1) | Reaction (pats, _) -> let pats = explode pats in @@ -720,7 +774,7 @@ let create_table some_loc auto1 gs r = (Lvar goid, [pri_kont ; Lapply (Lvar g, args)]))) in Lprim (Pmakeblock (0, Immutable), - [lambda_int (build_mask names jpats) ; + [build_mask n_names names jpats ; lambda_int ipri ; real_g])::r in List.fold_right create_reaction pats (do_guard (i+1)) in diff --git a/otherlibs/threads/join.ml b/otherlibs/threads/join.ml index 0bd7d1948edc..7185f7a5c584 100644 --- a/otherlibs/threads/join.ml +++ b/otherlibs/threads/join.ml @@ -232,17 +232,24 @@ let create_process f = type queue = Obj.t list -type status = int + (* set idx sets status bit idx, it answers true if + that bit status changes (ie it was unset) *) -type automaton = { - mutable status : status ; +type 'a status = + { set : int -> bool ; + erase : int -> unit ; + includes : 'a -> bool ; + to_string : unit -> string ; } + +type 'a automaton = { + status : 'a status ; mutex : Mutex.t ; queues : queue array ; - mutable matches : (reaction) array ; + mutable matches : ('a reaction) array ; names : Obj.t ; } -and reaction = status * int * (Obj.t -> Obj.t) +and 'a reaction = 'a * int * (Obj.t -> Obj.t) let put_queue auto idx a = auto.queues.(idx) <- a :: auto.queues.(idx) @@ -251,29 +258,83 @@ let get_queue auto idx = match auto.queues.(idx) with | a::rem -> auto.queues.(idx) <- rem ; begin match rem with - | [] -> auto.status <- auto.status land (lnot (1 lsl idx)) + | [] -> auto.status.erase idx | _ -> () end ; a -let create_automaton nchans = +let int_ops () = + let me = ref 0 in + { + set = (fun i -> + let old_me = !me in + let new_me = old_me lor (1 lsl i) in + me := new_me ; + old_me <> new_me) ; + erase = (fun i -> me := !me land (lnot (1 lsl i))) ; + includes = (fun mask -> !me land mask = mask) ; + to_string = (fun () -> sprintf "%08x" !me) ; + } + +let major i = i / 31 +and minor i = i mod 31 + +let bv_ops nchans = + let nslots = (nchans + 30) / 31 in (* eh oui *) + let me = Array.create nslots 0 in + let set i = + let slot = major i and idx = minor i in + let old_me = me.(slot) in + let new_me = old_me lor (1 lsl idx) in + me.(slot) <- new_me ; + old_me <> new_me in + + let erase i = + let slot = major i and idx = minor i in + me.(slot) <- me.(slot) land (lnot (1 lsl idx)) in + + let rec do_includes mask slot = + if slot >= nslots then true + else + let m = mask.(slot) in + me.(slot) land m = m && do_includes mask (slot+1) in + + let includes mask = do_includes mask 0 in + + let rec do_to_string slot = + if slot >= nslots then [] + else + Printf.sprintf "%x08" me.(slot):: + do_to_string (slot+1) in + + let to_string () = String.concat "" (do_to_string 0) in + { - status = 0 ; - mutex = Mutex.create () ; - queues = Array.create nchans [] ; - matches = [| |] ; - names = Obj.magic 0 ; + set = set ; + erase = erase ; + includes = includes ; + to_string = to_string ; } +let empty_status nchans = + if nchans > 31 then + Obj.magic (int_ops ()) + else + Obj.magic (bv_ops nchans) + let create_automaton_debug nchans names = + let status = empty_status nchans in { - status = 0 ; + status = status ; mutex = Mutex.create () ; queues = Array.create nchans [] ; matches = [| |] ; names = names ; } +let create_automaton nchans = create_automaton_debug nchans (Obj.magic 0) + + let get_name auto idx = Obj.magic (Obj.field auto.names idx) let patch_table auto t = auto.matches <- t @@ -296,9 +357,9 @@ let kont_create auto = (* Asynchronous sends *) (**********************) -type async = - Async of (automaton) * int - | Alone of (automaton) * int +type 'a async = + Async of ('a automaton) * int + | Alone of ('a automaton) * int let create_async auto i = Async (auto, i) @@ -331,11 +392,12 @@ let just_go_async auto f = let rec attempt_match tail auto reactions idx i = if i >= Obj.size reactions then begin -(*DEBUG*)debug3 "ATTEMPT FAILED" (sprintf "%s %i" (get_name auto idx) auto.status) ; +(*DEBUG*)debug3 "ATTEMPT FAILED" (sprintf "%s %s" +(*DEBUG*) (get_name auto idx) (auto.status.to_string ())) ; Mutex.unlock auto.mutex end else begin let (ipat, iprim, f) = Obj.magic (Obj.field reactions i) in - if ipat land auto.status = ipat then + if auto.status.includes ipat then if iprim < 0 then begin f (if tail then just_go_async else fire_go) (* f will unlock auto's mutex *) end else begin @@ -346,16 +408,14 @@ let rec attempt_match tail auto reactions idx i = end let direct_send_async auto idx a = -(*DEBUG*)debug3 "SEND_ASYNC" (sprintf "channel=%s, status=%x" -(*DEBUG*) (get_name auto idx) auto.status ) ; +(*DEBUG*)debug3 "SEND_ASYNC" (sprintf "channel=%s, status=%s" +(*DEBUG*) (get_name auto idx) (auto.status.to_string ())) ; (* Acknowledge new message by altering queue and status *) Mutex.lock auto.mutex ; - let old_status = auto.status in - let new_status = old_status lor (1 lsl idx) in put_queue auto idx a ; - auto.status <- new_status ; - if old_status = new_status then begin -(*DEBUG*)debug3 "SEND_ASYNC" (sprintf "Return: %i" auto.status) ; + if not (auto.status.set idx) then begin +(*DEBUG*)debug3 "SEND_ASYNC" (sprintf "Return: %s" +(*DEBUG*) (auto.status.to_string ())) ; Mutex.unlock auto.mutex end else begin attempt_match false auto (Obj.magic auto.matches) idx 0 @@ -374,16 +434,14 @@ let send_async chan a = match chan with let tail_direct_send_async auto idx a = -(*DEBUG*)debug3 "TAIL_ASYNC" (sprintf "channel %s, status=%i" -(*DEBUG*) (get_name auto idx) auto.status) ; +(*DEBUG*)debug3 "TAIL_ASYNC" (sprintf "channel %s, status=%s" +(*DEBUG*) (get_name auto idx) (auto.status.to_string ())) ; (* Acknowledge new message by altering queue and status *) Mutex.lock auto.mutex ; - let old_status = auto.status in - let new_status = old_status lor (1 lsl idx) in put_queue auto idx a ; - auto.status <- new_status ; - if old_status = new_status then begin -(*DEBUG*) debug3 "TAIL_ASYNC" (sprintf "Return: %i" auto.status) ; + if not (auto.status.set idx) then begin +(*DEBUG*)debug3 "TAIL_ASYNC" (sprintf "Return: %s" +(*DEBUG*) (auto.status.to_string ())) ; Mutex.unlock auto.mutex end else begin attempt_match true auto (Obj.magic auto.matches) idx 0 @@ -460,11 +518,12 @@ let fire_suspend k _ f = let rec attempt_match_sync idx kont auto reactions i = if i >= Obj.size reactions then begin -(*DEBUG*)debug3 "SYNC ATTEMPT FAILED" (sprintf "%s %i" (get_name auto idx) auto.status) ; +(*DEBUG*)debug3 "SYNC ATTEMPT FAILED" (sprintf "%s %s" +(*DEBUG*) (get_name auto idx) (auto.status.to_string ())) ; kont_suspend kont end else begin let (ipat, ipri, f) = Obj.magic (Obj.field reactions i) in - if ipat land auto.status = ipat then begin + if auto.status.includes ipat then begin if ipri < 0 then f (fire_suspend kont) (* will create other thread *) else if ipri = idx then begin @@ -479,13 +538,11 @@ let send_sync auto idx a = (*DEBUG*) debug3 "SEND_SYNC" (sprintf "channel %s" (get_name auto idx)) ; (* Acknowledge new message by altering queue and status *) Mutex.lock auto.mutex ; - let old_status = auto.status in - let new_status = old_status lor (1 lsl idx) in let kont = kont_create auto in put_queue auto idx (Obj.magic (kont,a)) ; - auto.status <- new_status ; - if old_status = new_status then begin -(*DEBUG*) debug3 "SEND_SYNC" (sprintf "Return: %i" auto.status) ; + if not (auto.status.set idx) then begin +(*DEBUG*)debug3 "SEND_SYNC" (sprintf "Return: %s" +(*DEBUG*) (auto.status.to_string ())) ; kont_suspend kont end else begin attempt_match_sync idx kont auto (Obj.magic auto.matches) 0 diff --git a/otherlibs/threads/join.mli b/otherlibs/threads/join.mli index 87e45a1ea866..1fba7a2cff86 100644 --- a/otherlibs/threads/join.mli +++ b/otherlibs/threads/join.mli @@ -14,36 +14,37 @@ val create_process : (unit -> unit) -> unit -type automaton +type 'a automaton -val get_queue : automaton -> int -> Obj.t +val get_queue : 'a automaton -> int -> Obj.t -val create_automaton : int -> automaton -val create_automaton_debug : int -> Obj.t -> automaton +val create_automaton : int -> 'a automaton (* create_automaton nchans *) +val create_automaton_debug : int -> Obj.t -> 'a automaton -type reaction -val patch_table : automaton -> reaction array -> unit +type 'a reaction -type async -val create_async : automaton -> int -> async -val create_async_alone : automaton -> int -> async +val patch_table : 'a automaton -> 'a reaction array -> unit + +type 'a async +val create_async : 'a automaton -> int -> 'a async +val create_async_alone : 'a automaton -> int -> 'a async (* Asynchronous sends *) -val direct_send_async : automaton -> int -> Obj.t -> unit -val direct_send_async_alone : automaton -> int -> Obj.t -> unit -val send_async : async -> Obj.t -> unit +val direct_send_async : 'a automaton -> int -> Obj.t -> unit +val direct_send_async_alone : 'a automaton -> int -> Obj.t -> unit +val send_async : 'a async -> Obj.t -> unit -val tail_direct_send_async : automaton -> int -> Obj.t -> unit -val tail_direct_send_async_alone : automaton -> int -> Obj.t -> unit -val tail_send_async : async -> Obj.t -> unit +val tail_direct_send_async : 'a automaton -> int -> Obj.t -> unit +val tail_direct_send_async_alone : 'a automaton -> int -> Obj.t -> unit +val tail_send_async : 'a async -> Obj.t -> unit (* Synchornous sends *) -val send_sync : automaton -> int -> Obj.t -> Obj.t -val send_sync_alone : automaton -> int -> Obj.t -> Obj.t +val send_sync : 'a automaton -> int -> Obj.t -> Obj.t +val send_sync_alone : 'a automaton -> int -> Obj.t -> Obj.t type continuation val reply_to : Obj.t -> continuation -> unit