CP-54826/CP-54827: optimize handling of the Pool object

ocaml/database/database_test.ml

@@ -269,9 +269,8 @@ functor
                     let row = Db_cache_types.Table.find r table in
                     let s =
                       Db_cache_types.Row.fold_over_recent g
-                        (fun k _ v acc ->
-                          Printf.sprintf "%s %s=%s" acc k
-                            (Schema.Value.marshal v)
+                        (fun k _ (_, cached) acc ->
+                          Printf.sprintf "%s %s=%s" acc k cached
                         )
                         row ""
                     in

ocaml/database/db_backend.ml

@@ -38,7 +38,7 @@ let blow_away_non_persistent_fields (schema : Schema.t) db =
   (* Generate a new row given a table schema *)
   let row schema row : Row.t * int64 =
     Row.fold
-      (fun name {Stat.created; modified; _} v (acc, max_upd) ->
+      (fun name {Stat.created; modified; _} (v, _) (acc, max_upd) ->
         try
           let col = Schema.Table.find name schema in
           let empty = col.Schema.Column.empty in

ocaml/database/db_cache_impl.ml

@@ -116,19 +116,18 @@ let read_record_internal db tblname objref =
       else
         None
     in
-    let map_fvlist v = Schema.Value.marshal v in
     (* Unfortunately the interface distinguishes between Set(Ref _) types and
        ordinary fields *)
     Row.fold
-      (fun k _ d (accum_fvlist, accum_setref) ->
+      (fun k _ (d, cached) (accum_fvlist, accum_setref) ->
         let accum_setref =
           match map_setref_opt k d with
           | Some v ->
               (k, v) :: accum_setref
           | None ->
               accum_setref
         in
-        let accum_fvlist = (k, map_fvlist d) :: accum_fvlist in
+        let accum_fvlist = (k, cached) :: accum_fvlist in
         (accum_fvlist, accum_setref)
       )
       row ([], [])
@@ -146,7 +145,8 @@ let delete_row_locked t tblname objref =
     Database.notify (PreDelete (tblname, objref)) db ;
     update_database t (remove_row tblname objref) ;
     Database.notify
-      (Delete (tblname, objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])
+      (Delete
+         (tblname, objref, Row.fold (fun k _ (v, _) acc -> (k, v) :: acc) row [])
       )
       (get_database t)
   with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref))
@@ -182,7 +182,10 @@ let create_row_locked t tblname kvs' new_objref =
   update_database t (add_row tblname new_objref row) ;
   Database.notify
     (Create
-       (tblname, new_objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])
+       ( tblname
+       , new_objref
+       , Row.fold (fun k _ (v, _) acc -> (k, v) :: acc) row []
+       )
     )
     (get_database t)
 

ocaml/database/db_cache_types.ml

@@ -136,10 +136,17 @@ functor
   end
 
 module Row = struct
-  include Make (Schema.Value)
+  module CachedValue = struct
+    type t = Schema.Value.t * string
+
+    let v v = (v, Schema.Value.marshal v)
+  end
+
+  include Make (CachedValue)
 
   let add gen key v =
     add gen key
+    @@ CachedValue.v
     @@
     match v with
     | Schema.Value.String x ->
@@ -153,8 +160,17 @@ module Row = struct
 
   type value = Schema.Value.t
 
+  let iter f t = iter (fun k (v, _) -> f k v) t
+
+  let touch generation key default row =
+    touch generation key (CachedValue.v default) row
+
+  let update gen key default f row =
+    let f (v, _) = f v |> CachedValue.v in
+    update gen key (CachedValue.v default) f row
+
   let find key t =
-    try find key t
+    try find key t |> fst
     with Not_found -> raise (DBCache_NotFound ("missing field", key, ""))
 
   let add_defaults g (schema : Schema.Table.t) t =

ocaml/database/db_cache_types.mli

@@ -82,6 +82,12 @@ end
 module Row : sig
   include MAP with type value = Schema.Value.t
 
+  val fold : (string -> Stat.t -> value * string -> 'b -> 'b) -> t -> 'b -> 'b
+  (** [fold f t initial] folds [f key stats value acc] over the items in [t] *)
+
+  val fold_over_recent :
+    Time.t -> (string -> Stat.t -> value * string -> 'b -> 'b) -> t -> 'b -> 'b
+
   val add_defaults : Time.t -> Schema.Table.t -> t -> t
   (** [add_defaults now schema t]: returns a row which is [t] extended to contain
       all the columns specified in the schema, with default values set if not already

ocaml/database/db_xml.ml

@@ -67,7 +67,7 @@ module To = struct
         make_tag "row"
           (List.rev
              (Row.fold
-                (fun k _ v acc ->
+                (fun k _ (v, _) acc ->
                   (k, Xml_spaces.protect (Schema.Value.marshal v)) :: acc
                 )
                 row preamble

ocaml/libs/clock/date.ml

@@ -64,12 +64,24 @@ let best_effort_iso8601_to_rfc3339 x =
       x
 
 let of_iso8601 x =
-  let rfc3339 = best_effort_iso8601_to_rfc3339 x in
-  match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with
-  | Error _ ->
-      invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x)
-  | Ok (t, tz, _) ->
-      {t; tz}
+  if String.length x > 5 && x.[4] <> '-' && x.[String.length x - 1] = 'Z' then
+    (* dates in the DB look like "20250319T04:16:24Z", so decoding that should be the fastpath *)
+    Scanf.sscanf x "%04i%02i%02iT%02i:%02i:%02iZ" (fun y mon d hh mm ss ->
+        let tz = 0 in
+        let date = (y, mon, d) and time = ((hh, mm, ss), tz) in
+        match Ptime.of_date_time (date, time) with
+        | Some t ->
+            {t; tz= Some tz}
+        | None ->
+            invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x)
+    )
+  else
+    let rfc3339 = best_effort_iso8601_to_rfc3339 x in
+    match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with
+    | Error _ ->
+        invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x)
+    | Ok (t, tz, _) ->
+        {t; tz}
 
 let print_tz tz_s =
   match tz_s with

ocaml/libs/log/test/log_test.t

@@ -1,8 +1,8 @@
   $ ./log_test.exe | sed -re 's/[0-9]+T[0-9:.]+Z//'
   [|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds")
   [|error||0 |main|backtrace] 1/4 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 7
-  [|error||0 |main|backtrace] 2/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24
-  [|error||0 |main|backtrace] 3/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39
+  [|error||0 |main|backtrace] 2/4 log_test.exe Called from file fun.ml, line 33
+  [|error||0 |main|backtrace] 3/4 log_test.exe Called from file fun.ml, line 38
   [|error||0 |main|backtrace] 4/4 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 14
   [|error||0 |main|backtrace] 
   [| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds")

ocaml/libs/sexpr/dune

@@ -1,22 +1,10 @@
-(menhir (modules sExprParser))
+(menhir
+ (modules sExprParser))
 
 (ocamllex sExprLexer)
 
 (library
-  (name sexpr)
-  (public_name sexpr)
-  (wrapped false)
-  (modules (:standard \ sexprpp))
-  (libraries
-    astring
-  )
-)
-
-(executable
-  (modes exe)
-  (name sexprpp)
-  (modules sexprpp)
-  (libraries
-    sexpr
-  )
-)
+ (name sexpr)
+ (public_name sexpr)
+ (wrapped false)
+ (libraries astring))

ocaml/libs/sexpr/sExpr.ml

@@ -23,7 +23,7 @@ let unescape_buf buf s =
   if Astring.String.fold_left aux false s then
     Buffer.add_char buf '\\'
 
-let is_escape_char = function '\\' | '"' | '\'' -> true | _ -> false
+let is_escape_char = function '\\' | '\'' -> true | _ -> false
 
 (* XXX: This escapes "'c'" and "\'c\'" to "\\'c\\'".
  * They are both unescaped as "'c'". They have been ported
@@ -32,26 +32,22 @@ let is_escape_char = function '\\' | '"' | '\'' -> true | _ -> false
  * - Astring.String.Ascii.escape_string
  * - Astring.String.Ascii.unescape
  * that have guaranteed invariants and optimised performances *)
-let escape s =
+let escape_buf escaped s =
   let open Astring in
-  if String.exists is_escape_char s then (
-    let escaped = Buffer.create (String.length s + 10) in
+  if String.exists is_escape_char s then
     String.iter
       (fun c ->
         match c with
         | '\\' ->
             Buffer.add_string escaped "\\\\"
-        | '"' ->
-            Buffer.add_string escaped "\\\""
         | '\'' ->
             Buffer.add_string escaped "\\\'"
         | _ ->
             Buffer.add_char escaped c
       )
-      s ;
-    Buffer.contents escaped
-  ) else
-    s
+      s
+  else
+    Buffer.add_string escaped s
 
 let unescape s =
   if String.contains s '\\' then (
@@ -82,22 +78,7 @@ let string_of sexpr =
         Buffer.add_char buf ')'
     | Symbol s | String s ->
         Buffer.add_string buf "\'" ;
-        Buffer.add_string buf (escape s) ;
+        escape_buf buf s ;
         Buffer.add_string buf "\'"
   in
   __string_of_rec sexpr ; Buffer.contents buf
-
-let rec output_fmt ff = function
-  | Node list ->
-      let rec aux ?(first = true) = function
-        | [] ->
-            ()
-        | h :: t when first ->
-            output_fmt ff h ; aux ~first:false t
-        | h :: t ->
-            Format.fprintf ff "@;<1 2>%a" output_fmt h ;
-            aux ~first t
-      in
-      Format.fprintf ff "@[(" ; aux list ; Format.fprintf ff ")@]"
-  | Symbol s | String s ->
-      Format.fprintf ff "\"%s\"" (escape s)

ocaml/libs/sexpr/sExpr.mli

@@ -16,5 +16,3 @@ type t = Node of t list | Symbol of string | String of string
 val mkstring : string -> t
 
 val string_of : t -> string
-
-val output_fmt : Format.formatter -> t -> unit

ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml

@@ -19,8 +19,8 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally
 module Mutex = struct
   (** execute the function f with the mutex hold *)
   let execute lock f =
-    Mutex.lock lock ;
-    finally f (fun () -> Mutex.unlock lock)
+    let finally () = Mutex.unlock lock in
+    Mutex.lock lock ; Fun.protect ~finally f
 end
 
 module Semaphore = struct