CP-52225 - poll: Reduce unnecessary allocations

No need to maintain interface compatibility with select anymore,
allocate an array of connection's poll status and modify that instead of
allocating an array, three lists, and a hash table on each iteration of
the main listening loop.

Signed-off-by: Andrii Sultanov <[email protected]>

Author: Andrii Sultanov

oxenstored/connections.ml

@@ -20,7 +20,9 @@ module Xeneventchn = Eventchn
 let debug fmt = Logging.debug "connections" fmt
 
 type t = {
-    anonymous: (Unix.file_descr, Connection.t) Hashtbl.t
+    anonymous: (Unix.file_descr, Connection.t * int) Hashtbl.t
+        (* (fd -> Connection.t, index) where index maps to the poll_status array *)
+  ; mutable poll_status: (Unix.file_descr * Poll.event) array
   ; domains: (int, Connection.t) Hashtbl.t
   ; ports: (Xeneventchn.t, Connection.t) Hashtbl.t
   ; mutable watches: Connection.watch list Trie.t
@@ -30,6 +32,7 @@ type t = {
 let create () =
   {
     anonymous= Hashtbl.create 37
+  ; poll_status= [||]
   ; domains= Hashtbl.create 37
   ; ports= Hashtbl.create 37
   ; watches= Trie.create ()
@@ -43,11 +46,15 @@ let get_capacity () =
   ; maxwatchevents= !Define.maxwatchevents
   }
 
+let default_poll_status () = (Unix.stdin, Poll.init_event ())
+
 let add_anonymous cons fd =
   let capacity = get_capacity () in
   let xbcon = Xenbus.Xb.open_fd fd ~capacity in
   let con = Connection.create xbcon None in
-  Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con
+  Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon)
+    (con, Array.length cons.poll_status) ;
+  cons.poll_status <- Array.append cons.poll_status [|default_poll_status ()|]
 
 let add_domain cons dom =
   let capacity = get_capacity () in
@@ -60,20 +67,26 @@ let add_domain cons dom =
   Hashtbl.add cons.domains (Domain.get_id dom) con ;
   Hashtbl.add cons.ports (Domain.get_local_port dom) con
 
-let select ?(only_if = fun _ -> true) cons =
-  Hashtbl.fold
-    (fun _ con (ins, outs) ->
-      if only_if con then
-        let fd = Connection.get_fd con in
-        let in_fds = if Connection.can_input con then fd :: ins else ins in
-        let out_fds = if Connection.has_output con then fd :: outs else outs in
-        (in_fds, out_fds)
-      else
-        (ins, outs)
+let refresh_poll_status ?(only_if = fun _ -> true) cons =
+  Hashtbl.iter
+    (fun _ (con, index) ->
+      let only = only_if con in
+      let fd = Connection.get_fd con in
+      let open Poll in
+      let event =
+        {
+          read= only && Connection.can_input con
+        ; write= only && Connection.has_output con
+        ; except= false
+        }
+      in
+      cons.poll_status.(index) <- (fd, event)
     )
-    cons.anonymous ([], [])
+    cons.anonymous
 
-let find cons = Hashtbl.find cons.anonymous
+let find cons fd =
+  let c, _ = Hashtbl.find cons.anonymous fd in
+  c
 
 let find_domain cons = Hashtbl.find cons.domains
 
@@ -97,8 +110,19 @@ let del_watches cons con =
 let del_anonymous cons con =
   try
     Hashtbl.remove cons.anonymous (Connection.get_fd con) ;
-    del_watches cons con ;
-    Connection.close con
+    (* Reallocate the poll_status array, update indices pointing to it *)
+    cons.poll_status <-
+      Array.make (Hashtbl.length cons.anonymous) (default_poll_status ()) ;
+    let _ =
+      Hashtbl.fold
+        (fun key (con, _) i ->
+          Hashtbl.replace cons.anonymous key (con, i) ;
+          i + 1
+        )
+        cons.anonymous 0
+    in
+
+    del_watches cons con ; Connection.close con
   with exn -> debug "del anonymous %s" (Printexc.to_string exn)
 
 let del_domain cons id =
@@ -116,7 +140,8 @@ let del_domain cons id =
 
 let iter_domains cons fct = Hashtbl.iter (fun _ c -> fct c) cons.domains
 
-let iter_anonymous cons fct = Hashtbl.iter (fun _ c -> fct c) cons.anonymous
+let iter_anonymous cons fct =
+  Hashtbl.iter (fun _ (c, _) -> fct c) cons.anonymous
 
 let iter cons fct = iter_domains cons fct ; iter_anonymous cons fct
 
@@ -227,7 +252,7 @@ let stats cons =
 let debug cons =
   let anonymous =
     Hashtbl.fold
-      (fun _ con accu -> Connection.debug con :: accu)
+      (fun _ (con, _) accu -> Connection.debug con :: accu)
       cons.anonymous []
   in
   let domains =
@@ -258,6 +283,7 @@ let debug_watchevents cons con =
 
 let filter ~f cons =
   let fold _ v acc = if f v then v :: acc else acc in
-  [] |> Hashtbl.fold fold cons.anonymous |> Hashtbl.fold fold cons.domains
+  let fold_a _ (v, _) acc = if f v then v :: acc else acc in
+  [] |> Hashtbl.fold fold_a cons.anonymous |> Hashtbl.fold fold cons.domains
 
 let prevents_quit cons = filter ~f:Connection.prevents_live_update cons

oxenstored/poll.ml

@@ -17,6 +17,8 @@
    readfds, writefds, exceptfds concept as in select. *)
 type event = {mutable read: bool; mutable write: bool; mutable except: bool}
 
+let init_event () = {read= false; write= false; except= false}
+
 external select_on_poll : (Unix.file_descr * event) array -> int -> int
   = "stub_select_on_poll"
 
@@ -31,33 +33,8 @@ let get_sys_fs_nr_open () =
     close_in_noerr ch ; v
   with _ -> 1024 * 1024
 
-let init_event () = {read= false; write= false; except= false}
-
-let poll_select in_fds out_fds exc_fds timeout =
-  let h = Hashtbl.create 57 in
-  let add_event event_set fd =
-    let e =
-      try Hashtbl.find h fd
-      with Not_found ->
-        let e = init_event () in
-        Hashtbl.add h fd e ; e
-    in
-    event_set e
-  in
-  List.iter (add_event (fun x -> x.read <- true)) in_fds ;
-  List.iter (add_event (fun x -> x.write <- true)) out_fds ;
-  List.iter (add_event (fun x -> x.except <- true)) exc_fds ;
-  (* Unix.stdin and init_event are dummy input as stubs, which will
-            always be overwritten later on. *)
-  let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in
-  let i = ref (-1) in
-  Hashtbl.iter
-    (fun fd event ->
-      incr i ;
-      Array.set a !i (fd, event)
-    )
-    h ;
-  let n = select_on_poll a (int_of_float (timeout *. 1000.)) in
+let poll_select fdarr timeout =
+  let n = select_on_poll fdarr (int_of_float (timeout *. 1000.)) in
   let r = ([], [], []) in
   if n = 0 then
     r
@@ -69,6 +46,6 @@ let poll_select in_fds out_fds exc_fds timeout =
         , if event.except then fd :: x else x
         )
       )
-      a r
+      fdarr r
 
 let () = set_fd_limit (get_sys_fs_nr_open ())

oxenstored/poll.mli

@@ -12,10 +12,11 @@
  * GNU Lesser General Public License for more details.
  *)
 
+type event = {mutable read: bool; mutable write: bool; mutable except: bool}
+
+val init_event : unit -> event
+
 val poll_select :
-     Unix.file_descr list
-  -> Unix.file_descr list
-  -> Unix.file_descr list
+     (Unix.file_descr * event) array
   -> float
   -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
-(** Same interface and semantics as [Unix.select], implemented using poll(3). *)

oxenstored/xenstored.ml

@@ -681,9 +681,9 @@ let () =
       in
       if peaceful_mw <> [] then 0. else until_next_activity
     in
-    let inset, outset = Connections.select ~only_if:is_peaceful cons in
+    Connections.refresh_poll_status ~only_if:is_peaceful cons ;
     let rset, wset, _ =
-      try Poll.poll_select (spec_fds @ inset) outset [] timeout
+      try Poll.poll_select cons.poll_status timeout
       with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
     in
     let sfds, cfds = List.partition (fun fd -> List.mem fd spec_fds) rset in