Merge performance improvements (#6987)

Draft, waiting for testing  and PR reviews to complete.

Depends on:
#6974
#6971

Also would be good to have an updated ocaml-rpc for the JSONRPC fixes in
xs-opam.

PRs for ocaml-rpc optimizations:
mirage/ocaml-rpc#194
mirage/ocaml-rpc#193
mirage/ocaml-rpc#192
mirage/ocaml-rpc#184

The optimizations are not strictly required, but the first PR about
fixing 4.14 build is, otherwise we can't take the new version into
xs-opam.

Author: psafont

ocaml/idl/ocaml_backend/gen_server.ml

@@ -465,7 +465,7 @@ let gen_module api : O.Module.t =
              ~params:
                [
                  O.Anon (Some "http_req", "Http.Request.t")
-               ; O.Anon (Some "fd", "Unix.file_descr")
+               ; O.Anon (Some "fd", "Unix.file_descr option")
                ; O.Anon (Some "call", "Rpc.call")
                ]
              ~ty:"response"

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml

@@ -40,7 +40,17 @@ module List = struct
         inv_assoc k t
 
   (* Tail-recursive map. *)
-  let map_tr f l = rev (rev_map f l)
+
+  let[@tail_mod_cons] rec map_tr f l =
+    match l with
+    | [] ->
+        []
+    | [x] ->
+        [f x]
+    | x1 :: x2 :: xs ->
+        let fx1 = f x1 in
+        let fx2 = f x2 in
+        fx1 :: fx2 :: map_tr f xs
 
   let count pred l =
     fold_left

ocaml/libs/xml-light2/dune

@@ -1,20 +1,12 @@
 (library
-  (name xmllight2)
-  (public_name xml-light2)
-  (modules xml)
-  (wrapped false)
-  (libraries
-    threads
-    xmlm
-  )
-)
+ (name xmllight2)
+ (public_name xml-light2)
+ (modules xml)
+ (wrapped false)
+ (libraries threads xapi-stdext-std xmlm))
 
 (executable
-  (modes exe)
-  (name xmlpp)
-  (modules xmlpp)
-  (libraries
-    xml-light2
-  )
-)
-
+ (modes exe)
+ (name xmlpp)
+ (modules xmlpp)
+ (libraries xml-light2))

ocaml/libs/xml-light2/xml.ml

@@ -42,19 +42,17 @@ let _ =
 (* internal parse function *)
 let is_empty xml =
   let is_empty_string s =
-    let is_empty = ref true in
-    for i = 0 to String.length s - 1 do
-      if s.[i] <> '\n' && s.[i] <> ' ' && s.[i] <> '\t' then is_empty := false
-    done ;
-    !is_empty
+    String.for_all (function '\n' | ' ' | '\t' -> true | _ -> false) s
   in
   match xml with PCData data when is_empty_string data -> true | _ -> false
 
 let _parse i =
   let el (tag : Xmlm.tag) (children : xml list) : xml =
     let name_local = snd (fst tag) in
     let attrs' =
-      List.map (fun (nameattr, str) -> (snd nameattr, str)) (snd tag)
+      Xapi_stdext_std.Listext.List.map_tr
+        (fun (nameattr, str) -> (snd nameattr, str))
+        (snd tag)
     in
     Element
       (name_local, attrs', List.filter (fun xml -> not (is_empty xml)) children)
@@ -93,28 +91,24 @@ let parse_string s =
 let esc_pcdata data =
   let buf = Buffer.create (String.length data + 10) in
   String.iter
-    (fun c ->
-      let s =
-        match c with
-        | '>' ->
-            "&gt;"
-        | '<' ->
-            "&lt;"
-        | '&' ->
-            "&amp;"
-        | '"' ->
-            "&quot;"
-        | c
-          when (c >= '\x20' && c <= '\xff')
-               || c = '\x09'
-               || c = '\x0a'
-               || c = '\x0d' ->
-            String.make 1 c
-        | _ ->
-            ""
-      in
-      Buffer.add_string buf s
-    )
+    (function
+      | '>' ->
+          Buffer.add_string buf "&gt;"
+      | '<' ->
+          Buffer.add_string buf "&lt;"
+      | '&' ->
+          Buffer.add_string buf "&amp;"
+      | '"' ->
+          Buffer.add_string buf "&quot;"
+      | c
+        when (c >= '\x20' && c <= '\xff')
+             || c = '\x09'
+             || c = '\x0a'
+             || c = '\x0d' ->
+          Buffer.add_char buf c
+      | _ ->
+          ()
+      )
     data ;
   Buffer.contents buf
 
@@ -139,9 +133,7 @@ let to_fct xml f =
         let astr = str_of_attrs attrs in
         let on = fmt "<%s%s>" name astr in
         let off = fmt "</%s>" name in
-        f on ;
-        List.iter (fun child -> print child) children ;
-        f off
+        f on ; List.iter print children ; f off
     | PCData data ->
         f (esc_pcdata data)
   in
@@ -213,22 +205,3 @@ let to_string_fmt xml =
   to_fct_fmt xml (fun s -> Buffer.add_string buffer s) ;
   let s = Buffer.contents buffer in
   Buffer.reset buffer ; s
-
-(* helpers functions *)
-exception Not_pcdata of string
-
-exception Not_element of string
-
-let pcdata = function PCData x -> x | e -> raise (Not_pcdata (to_string e))
-
-let children = function
-  | Element (_, _, c) ->
-      c
-  | e ->
-      raise (Not_element (to_string e))
-
-let tag = function
-  | Element (x, _, _) ->
-      x
-  | e ->
-      raise (Not_element (to_string e))

ocaml/libs/xml-light2/xml.mli

@@ -32,22 +32,6 @@ val parse_in : in_channel -> xml
 
 val parse_string : string -> xml
 
-val to_fct : xml -> (string -> unit) -> unit
-(** output functions *)
-
-val to_fct_fmt : xml -> (string -> unit) -> unit
-
 val to_string : xml -> string
 
 val to_string_fmt : xml -> string
-
-(** helper functions *)
-exception Not_pcdata of string
-
-exception Not_element of string
-
-val pcdata : xml -> string
-
-val children : xml -> xml list
-
-val tag : xml -> string

ocaml/tests/test_client.ml

@@ -10,7 +10,7 @@
     work in unit tests. *)
 let make_client_params ~__context =
   let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in
-  let rpc = Api_server.Server.dispatch_call req Unix.stdout in
+  let rpc = Api_server.Server.dispatch_call req None in
   let session_id =
     let session_id = Ref.make_secret () in
     let now = Clock.Date.now () in

ocaml/xapi-consts/constants.ml

@@ -315,7 +315,7 @@ let owner_key = "owner"
 (* set in VBD other-config to indicate that clients can delete the attached VDI on VM uninstall if they want.. *)
 
 (* xapi-cli-server doesn't link xapi-globs *)
-let use_event_next = ref true
+let use_event_next = ref false
 
 (* the time taken to wait before restarting in a different mode for pool eject/join operations *)
 let fuse_time = ref 10.

ocaml/xapi/api_server.ml

@@ -33,7 +33,7 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call =
   else
     let response =
       let@ req = Helper.with_tracing ~name:"Server.dispatch_call" req in
-      Server.dispatch_call req fd call
+      Server.dispatch_call req (Some fd) call
     in
     let translated =
       if

ocaml/xapi/context.ml

@@ -481,29 +481,28 @@ let get_http_other_config http_req =
 let of_http_req ?session_id ?(internal_async_subtask = false) ~generate_task_for
     ~supports_async ~label ~http_req ~fd () =
   let http_other_config = get_http_other_config http_req in
+  let origin =
+    match fd with None -> Internal | Some fd -> Http (http_req, fd)
+  in
   let new_task_context () =
     let subtask_of =
       Option.map Ref.of_string http_req.Http.Request.subtask_of
     in
     make ?session_id ?subtask_of ~http_other_config ~task_in_database:true
-      ~origin:(Http (http_req, fd))
-      label
+      ~origin label
   in
   if internal_async_subtask then
     new_task_context ()
   else
     match http_req.Http.Request.task with
     | Some task_id ->
-        from_forwarded_task ?session_id ~http_other_config
-          ~origin:(Http (http_req, fd))
+        from_forwarded_task ?session_id ~http_other_config ~origin
           (Ref.of_string task_id)
     | None ->
         if generate_task_for && supports_async then
           new_task_context ()
         else
-          make ?session_id ~http_other_config
-            ~origin:(Http (http_req, fd))
-            label
+          make ?session_id ~http_other_config ~origin label
 
 let set_test_rpc context rpc = context.test_rpc <- Some rpc
 

ocaml/xapi/context.mli

@@ -49,7 +49,7 @@ val of_http_req :
   -> supports_async:bool
   -> label:string
   -> http_req:Http.Request.t
-  -> fd:Unix.file_descr
+  -> fd:Unix.file_descr option
   -> unit
   -> t