fixup! CP-52225 - poll: Reduce unnecessary allocations

oxenstored/connections.ml

@@ -48,6 +48,8 @@ let get_capacity () =
 
 let default_poll_status () = (Unix.stdin, Poll.init_event ())
 
+let spec_poll_status () = Poll.{read= true; write= false; except= false}
+
 let add_anonymous cons fd =
   let capacity = get_capacity () in
   let xbcon = Xenbus.Xb.open_fd fd ~capacity in
@@ -67,7 +69,12 @@ let add_domain cons dom =
   Hashtbl.replace cons.domains (Domain.get_id dom) con ;
   Hashtbl.replace cons.ports (Domain.get_local_port dom) con
 
-let refresh_poll_status ?(only_if = fun _ -> true) cons =
+let refresh_poll_status ?(only_if = fun _ -> true) cons spec_fds =
+  (* special fds are always read=true, but get overwritten by select_stubs, so we
+     need to reset the event we are polling for *)
+  List.iteri
+    (fun index fd -> cons.poll_status.(index) <- (fd, spec_poll_status ()))
+    spec_fds ;
   Hashtbl.iter
     (fun _ (con, index) ->
       let only = only_if con in
@@ -107,19 +114,32 @@ let del_watches cons con =
     |> Connection.Watch.Set.filter @@ fun w -> Connection.get_con w != con
     )
 
-let del_anonymous cons con =
+let del_anonymous cons con spec_fds =
   try
     Hashtbl.remove cons.anonymous (Connection.get_fd con) ;
     (* Reallocate the poll_status array, update indices pointing to it *)
     cons.poll_status <-
-      Array.make (Hashtbl.length cons.anonymous) (default_poll_status ()) ;
+      Array.make
+        (Hashtbl.length cons.anonymous + List.length spec_fds)
+        (default_poll_status ()) ;
+
+    (* Keep the special fds at the beginning *)
+    let i =
+      List.fold_left
+        (fun index fd ->
+          cons.poll_status.(index) <- (fd, spec_poll_status ()) ;
+          index + 1
+        )
+        0 spec_fds
+    in
+
     let _ =
       Hashtbl.fold
         (fun key (con, _) i ->
           Hashtbl.replace cons.anonymous key (con, i) ;
           i + 1
         )
-        cons.anonymous 0
+        cons.anonymous i
     in
 
     del_watches cons con ; Connection.close con

oxenstored/xenstored.ml

@@ -29,20 +29,20 @@ let debug fmt = Logging.debug "xenstored" fmt
 let info fmt = Logging.info "xenstored" fmt
 
 (*------------ event klass processors --------------*)
-let process_connection_fds store cons domains rset wset =
+let process_connection_fds store cons domains rset wset spec_fds =
   let try_fct fct c =
     try fct store cons domains c with
     | Unix.Unix_error (err, "write", _) ->
-        Connections.del_anonymous cons c ;
+        Connections.del_anonymous cons c spec_fds ;
         error "closing socket connection: write error: %s"
           (Unix.error_message err)
     | Unix.Unix_error (err, "read", _) ->
-        Connections.del_anonymous cons c ;
+        Connections.del_anonymous cons c spec_fds ;
         if err <> Unix.ECONNRESET then
           error "closing socket connection: read error: %s"
             (Unix.error_message err)
     | Xenbus.Xb.End_of_file ->
-        Connections.del_anonymous cons c ;
+        Connections.del_anonymous cons c spec_fds ;
         debug "closing socket connection"
   in
   let process_fdset_with fds fct =
@@ -528,6 +528,13 @@ let () =
     (match rw_sock with None -> [] | Some x -> [x])
     @ if cf.domain_init then [Event.fd eventchn] else []
   in
+  (* Always positioned at the start of cons.poll_status, maintained during
+     reallocations *)
+  cons.poll_status <-
+    Array.append cons.poll_status
+      (Array.of_list
+         (List.map (fun fd -> (fd, Connections.spec_poll_status ())) spec_fds)
+      ) ;
 
   let process_special_fds rset =
     let accept_connection fd =
@@ -681,7 +688,7 @@ let () =
       in
       if peaceful_mw <> [] then 0. else until_next_activity
     in
-    Connections.refresh_poll_status ~only_if:is_peaceful cons ;
+    Connections.refresh_poll_status ~only_if:is_peaceful cons spec_fds ;
     let rset, wset, _ =
       try Poll.poll_select cons.poll_status timeout
       with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
@@ -691,7 +698,7 @@ let () =
       process_special_fds sfds ;
 
     if cfds <> [] || wset <> [] then
-      process_connection_fds store cons domains cfds wset ;
+      process_connection_fds store cons domains cfds wset spec_fds ;
     ( if timeout <> 0. then
         let now = Unix.gettimeofday () in
         if now > !period_start +. period_ops_interval then (