summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--sources/thibaut/globals.ml165
-rw-r--r--sources/thibaut/mesh.ml39
-rw-r--r--sources/thibaut/pacemaker.ml2
3 files changed, 113 insertions, 93 deletions
diff --git a/sources/thibaut/globals.ml b/sources/thibaut/globals.ml
index 08dcb71..632d59a 100644
--- a/sources/thibaut/globals.ml
+++ b/sources/thibaut/globals.ml
@@ -111,14 +111,14 @@ type round_data = {
module SlotArray : sig
- type 'a slot = Peer of 'a | Ask of 'a | AskRoot
+ type 'a slot = Peer of 'a | Ask of 'a | AskRoot | Empty
type 'a t
val make : int -> 'a t
val full : 'a t -> bool
val accept : 'a slot -> 'a t -> unit
val clear : 'a t -> unit
val iter : ('a slot -> unit) -> 'a t -> unit
- val ask_list : int -> 'a t -> ('a slot) list
+ val ask_list : 'a t -> ('a slot) array
val test : ('a slot -> bool) -> 'a t -> bool
val random_peer_avoid : ('a slot -> bool) -> 'a t -> 'a slot
val random_peer : 'a t -> 'a slot
@@ -127,62 +127,81 @@ module SlotArray : sig
val capacity : 'a t -> int
val length : 'a t -> int
val asks : 'a t -> int
- val append_asks : ('a slot list) -> 'a t -> unit
+ val append_asks : ('a slot array) -> 'a t -> unit
end = struct
- type 'a slot = Peer of 'a | Ask of 'a | AskRoot
+ type 'a slot = Peer of 'a | Ask of 'a | AskRoot | Empty
type 'a t = {
mutable npeers : int;
mutable nasks : int;
- mutable peers: ('a slot) list;
+ peers: ('a slot) array;
capacity: int;
- mutable asks: ('a slot) list
+ asks: ('a slot) array
}
let full sa = ( sa.npeers = sa.capacity )
+ let add_peer elem sa =
+ let length = sa.npeers in
+ sa.peers.(length) <- elem;
+ sa.npeers <- (length + 1)
+
+ let remove_peer pos sa =
+ let length = sa.npeers -1 in
+ sa.peers.(pos) <- sa.peers.(length);
+ sa.peers.(length) <- Empty;
+ sa.npeers <- length
+
+ let add_ask elem sa =
+ let length = sa.nasks in
+ sa.asks.(length) <- elem;
+ sa.nasks <- (length + 1)
+
+ let remove_ask pos sa =
+ let length = sa.nasks -1 in
+ sa.asks.(pos) <- sa.asks.(length);
+ sa.asks.(length) <- Empty;
+ sa.nasks <- length
+
let iter_asks f sa =
- let rec aux result peers asks = match asks with
- | [] -> sa.asks <- result; sa.peers <- peers
- | a::b ->
- if full sa then
- begin
- sa.asks <- (List.rev_append result asks);
- sa.peers <- peers
- end
- else
- begin match f a with
- | Peer p as e -> sa.npeers <- sa.npeers + 1;
- sa.nasks <- sa.nasks - 1;
- aux result (e::peers) b
- | Ask p as e -> aux (e::result) peers b
- | AskRoot -> sa.nasks <- sa.nasks - 1; aux result peers b
- end
- in
- aux [] sa.peers sa.asks
+ let rec aux n =
+ if n = sa.nasks then ()
+ else
+ if full sa then ()
+ else begin match f sa.asks.(n) with
+ | Ask _ as e -> sa.asks.(n) <- e; aux (n+1)
+ | AskRoot -> remove_ask n sa; aux n
+ | Peer _ as e -> add_peer e sa; remove_ask n sa; aux n
+ | _ -> failwith "Big problem"
+ end
+ in
+ aux 0
- let filter_peers f sa =
- let rec aux result peers = match peers with
- | [] -> sa.peers <- result
- | a::b ->
- if f a then aux (a::result) b
+ let filter_peers pred sa =
+ let rec aux n =
+ if n = sa.npeers then
+ ()
+ else
+ if not (pred sa.peers.(n)) then begin
+ remove_peer n sa;
+ aux n
+ end
else
- begin
- sa.npeers <- (sa.npeers - 1);
- aux result b
- end
- in
- aux [] sa.peers
-
+ aux (n+1)
+ in
+ aux 0
+
let clear sa =
- sa.peers <- [];
+ for i = 0 to sa.npeers - 1 do
+ sa.peers.(i) <- Empty
+ done;
sa.npeers <- 0
let make capacity = {
- peers = [];
- asks = [];
+ peers = Array.make capacity Empty;
+ asks = Array.make capacity Empty;
nasks = 0;
npeers = 0;
capacity = capacity
@@ -192,61 +211,47 @@ end = struct
let asks sa = sa.nasks
let capacity sa = sa.capacity
- let test f sa =
- let rec aux l = match l with
- | [] -> false
- | a::b -> (f a)||(aux b)
+ let test pred sa =
+ let rec aux n =
+ if n = sa.npeers then false
+ else (pred sa.peers.(n))||(aux (n+1))
in
- aux sa.peers
+ aux 0
- let accept p sa = if not (full sa) then begin
- sa.npeers <- sa.npeers + 1;
- sa.peers <- (p::sa.peers)
- end
+ let accept p sa = add_peer p sa
let iter f sa =
- let rec aux l = match l with
- | [] -> ()
- | a::b -> f a; aux b
- in
- aux sa.peers
+ for i = 0 to sa.npeers -1 do
+ f sa.peers.(i)
+ done
let random_peer sa =
let n = Random.int sa.npeers in
- let rec aux n peers = match n with
- | 0 -> List.hd peers
- | n -> aux (n-1) (List.tl peers)
- in aux n sa.peers
+ sa.peers.(n)
let random_peer_avoid pred sa =
if sa.npeers <= 1 then AskRoot
- else let n = Random.int (sa.npeers-1) in
- let rec aux n peers = match n with
- | 0 -> begin try List.hd peers with Failure s -> AskRoot end
- | n -> if pred (List.hd peers) then aux n (List.tl peers) else aux (n-1) (List.tl peers)
- in
- aux n sa.peers
+ else let n = Random.int sa.npeers in
+ if pred sa.peers.(n) then
+ if n = sa.npeers - 1 then sa.peers.(n-1)
+ else sa.peers.(n+1)
+ else
+ sa.peers.(n)
- let ask_list n sa =
- let rec aux n result peers = match n with
- | 0 -> result
- | n ->
- begin match peers with
- | [] -> result
- | a::b -> let Peer p = a in aux (n-1) ((Ask p)::result) b
- end
- in
- aux n [] sa.peers
+ let ask_list sa =
+ sa.peers
let append_asks list sa =
- let rec aux n result arg = match arg with
- | [] -> n, result
- | a::b -> aux (n+1) (a::result) b
+ let rec aux n =
+ if sa.nasks = sa.capacity then
+ ()
+ else
+ match list.(n) with
+ | Peer p -> add_ask (Ask p) sa; aux (n+1)
+ | Empty -> ()
+ | _ -> failwith "Big problem"
in
- let n, result = aux 0 sa.asks list in
- sa.nasks <- sa.nasks + n;
- sa.asks <- result
-
+ aux 0
end
type peer = {
diff --git a/sources/thibaut/mesh.ml b/sources/thibaut/mesh.ml
index 64fafad..e62553d 100644
--- a/sources/thibaut/mesh.ml
+++ b/sources/thibaut/mesh.ml
@@ -4,18 +4,20 @@ let ask = ref 0
let askroot = ref 0
let equal a b = match a with
- | Peer x -> let Peer y = b in x.id = y.id
- | _ -> false
+ | Peer x -> begin match b with
+ | Peer y -> x.id = y.id
+ | _ -> failwith "Big problem" end
+ | _ -> failwith "Big problem"
(* p is asking n slots to root *)
-let ask_root root p n =
+let ask_root root p =
incr askroot;
if not (SlotArray.full root.slots) then begin
SlotArray.accept (Peer p) root.slots;
- true, SlotArray.ask_list (n-1) root.slots
+ true, SlotArray.ask_list root.slots
end
else
- false, SlotArray.ask_list n root.slots
+ false, SlotArray.ask_list root.slots
(* peer is asking to p *)
let ask_peer peer p =
@@ -26,25 +28,38 @@ let ask_peer peer p =
else if p.con_state <> ON then
AskRoot
else begin
- if SlotArray.test (equal (Peer peer)) p.slots then
- SlotArray.random_peer_avoid (equal (Peer peer)) p.slots
+ if SlotArray.test (equal (Peer peer)) p.slots then begin
+ match SlotArray.random_peer_avoid (equal (Peer peer)) p.slots with
+ | Peer x -> Ask x
+ | AskRoot -> AskRoot
+ | _ -> failwith "Something is very wrong."
+ end
else if not (SlotArray.full p.slots) then begin
SlotArray.accept (Peer peer) p.slots;
Peer p
end
else match SlotArray.random_peer p.slots with
| Peer x -> Ask x
- | _ -> failwith "Something is very wrong.\n"
+ | _ -> failwith "Something is very wrong."
end
+let is_active slot = match slot with
+ | Peer p -> p.con_state = ON
+ | _ -> failwith "Big problem"
+
let do_peer root peer =
- let aux a = let Ask p = a in ask_peer peer p in
- SlotArray.filter_peers (fun (Peer p) -> p.con_state = ON) peer.slots;
+
+ let aux a = match a with
+ | Ask p -> ask_peer peer p
+ | _ -> failwith "Big problem"
+ in
+
+ SlotArray.filter_peers is_active peer.slots;
SlotArray.iter_asks aux peer.slots;
let free_slots = SlotArray.capacity peer.slots - SlotArray.length peer.slots
- SlotArray.asks peer.slots in
if free_slots > 0 then
- let (a,b) = ask_root root peer free_slots in
+ let (a,b) = ask_root root peer in
if a then begin
SlotArray.accept (Peer root) peer.slots;
SlotArray.append_asks b peer.slots
@@ -53,5 +68,5 @@ let do_peer root peer =
SlotArray.append_asks b peer.slots
let do_server root =
- SlotArray.filter_peers (fun (Peer p) -> p.con_state = ON) root.slots
+ SlotArray.filter_peers is_active root.slots
diff --git a/sources/thibaut/pacemaker.ml b/sources/thibaut/pacemaker.ml
index d37ef12..7534f66 100644
--- a/sources/thibaut/pacemaker.ml
+++ b/sources/thibaut/pacemaker.ml
@@ -25,7 +25,7 @@ let messages = ref 0
let send_message message receiver = match receiver with
| Peer peer -> incr messages; Queue.push message peer.messages
- | _ -> ()
+ | _ -> failwith "Big problem"
let server_init_seed peer round duration =
let data = {
generated by cgit v1.2.3-70-g09d2 (git 2.52.0) at 2025-12-21 16:15:30 +0000