Use arrays instead of lists for mesh construction

git-svn-id: https://scm.gforge.inria.fr/svn/pacemaker@28 30fcff6e-8de6-41c7-acce-77ff6d1dd07b

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 = {