Skip to content

Commit

Permalink
bit vectors does not work yet
Browse files Browse the repository at this point in the history 
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@6563 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information
@maranget
maranget committed Jul 22, 2004
1 parent 71e8a2c commit ebd847d
Show file tree
Hide file tree
Showing 3 changed files with 172 additions and 60 deletions.
62 changes: 58 additions & 4 deletions bytecomp/transljoin.ml
View file
Expand Up @@ -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
| [] -> []
Expand All @@ -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 []
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
135 changes: 96 additions & 39 deletions otherlibs/threads/join.ml
View file
Expand Up @@ -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)

Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
35 changes: 18 additions & 17 deletions otherlibs/threads/join.mli
View file
Expand Up @@ -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

0 comments on commit ebd847d

Please sign in to comment.