Merge performance improvements

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
 

ocaml/xapi/helpers.ml

@@ -427,6 +427,11 @@ module TraceHelper = struct
     Tracing_propagator.Propagator.Http.inject_into trace_context
 end
 
+(** Once the server functor has been instantiated, xapi sets this reference to the appropriate
+    "fake_rpc" (loopback non-HTTP) rpc function. 
+    This way, internally the coordinator can short-circuit API calls without having to go over the network. *)
+let rpc_fun : (Http.Request.t -> Rpc.call -> Rpc.response) option ref = ref None
+
 let choose_rpc () =
   let open Xmlrpc_client in
   if !Xapi_globs.use_xmlrpc then
@@ -445,19 +450,24 @@ let make_rpc' ~subtask_of ?task_id ~__context rpc : Rpc.response =
   let dorpc, path = choose_rpc () in
   let http = xmlrpc ~subtask_of ~version:"1.1" path in
   let http = TraceHelper.inject_span_into_req tracing http in
-  let transport =
-    if Pool_role.is_master () then
-      Unix Xapi_globs.unix_domain_socket
-    else
-      SSL
-        ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ())
-            ?task_id:(Option.map Ref.string_of task_id)
-            ()
-        , Pool_role.get_master_address ()
-        , !Constants.https_port
-        )
-  in
-  dorpc ~srcstr:"xapi" ~dststr:"xapi" ~transport ~http rpc
+  match !rpc_fun with
+  | Some rpcfun when Pool_role.is_master () ->
+      rpcfun http rpc
+  | _ ->
+      let transport =
+        if Pool_role.is_master () then
+          Unix Xapi_globs.unix_domain_socket
+        else
+          SSL
+            ( SSL.make ~use_stunnel_cache:true
+                ~verify_cert:(Stunnel_client.pool ())
+                ?task_id:(Option.map Ref.string_of task_id)
+                ()
+            , Pool_role.get_master_address ()
+            , !Constants.https_port
+            )
+      in
+      dorpc ~srcstr:"xapi" ~dststr:"xapi" ~transport ~http rpc
 
 (* erase optional labeled arguments for partial applications to work *)
 let make_rpc ~__context rpc =

ocaml/xapi/server.mli

@@ -3,4 +3,4 @@ module Make : functor
   (_ : Custom_actions.CUSTOM_ACTIONS)
   -> sig
   val dispatch_call :
-    Http.Request.t -> Unix.file_descr -> Rpc.call -> Rpc.response end
+    Http.Request.t -> Unix.file_descr option -> Rpc.call -> Rpc.response end

ocaml/xapi/server_helpers.mli

@@ -61,7 +61,7 @@ val do_dispatch :
   -> string
   -> (__context:Context.t -> 'a)
   -> ('a -> Rpc.t)
-  -> Unix.file_descr
+  -> Unix.file_descr option
   -> Http.Request.t
   -> string
   -> [< `Async | `InternalAsync | `Sync > `Sync `InternalAsync]

ocaml/xapi/xapi.ml

@@ -159,11 +159,14 @@ let random_setup () =
   finally (fun () -> really_input chan s 0 n) (fun () -> close_in chan) ;
   Random.full_init (Array.init n (fun i -> Char.code (Bytes.get s i)))
 
+let fake_rpc2 req rpc = Api_server.Server.dispatch_call req None rpc
+
 let register_callback_fns () =
   let fake_rpc req sock xml : Rpc.response =
     Api_server.callback1 false req sock xml
   in
   Xapi_cli.rpc_fun := Some fake_rpc ;
+  Helpers.rpc_fun := Some fake_rpc2 ;
   Message_forwarding.register_callback_fns ()
 
 let noevents = ref false

ocaml/xapi/xapi_globs.ml

@@ -1106,7 +1106,7 @@ let max_traces = ref 10000
 
 let max_span_depth = ref 100
 
-let use_xmlrpc = ref true
+let use_xmlrpc = ref false
 
 let compress_tracing_files = ref true
 
@@ -1187,7 +1187,8 @@ let make_batching name ~delay_before ~delay_between =
   (config, (name, Arg.String set, get, desc))
 
 let event_from_delay, event_from_entry =
-  make_batching "event_from" ~delay_before:Mtime.Span.zero
+  make_batching "event_from"
+    ~delay_before:Mtime.Span.(50 * ms)
     ~delay_between:Mtime.Span.(50 * ms)
 
 let event_from_task_delay, event_from_task_entry =