CP-307933: Start using DB_ACCESS2

`ministat` confirms a speedup:
```
Db.Pool.get_all_records  :
    N           Min           Max        Median           Avg        Stddev
x 432     54115.256     493532.78      56048.42     57937.384      24117.68
+ 524     22642.778     333257.36     23595.495     24679.258     15206.708
Difference at 95.0% confidence
        -33258.1 +/- 2513.99
        -57.4036% +/- 2.90374%
        (Student's t, pooled s = 19737.2)

>>>>  Db.VM.set_NVRAM  :
    N           Min           Max        Median           Avg        Stddev
x 132         36794     2355369.4     1095736.6     1107222.1      298247.5
+ 168     49167.417     1485278.1     678231.31     685636.89     161480.92
Difference at 95.0% confidence
        -421585 +/- 52835.6
        -38.0759% +/- 3.54275%
        (Student's t, pooled s = 231767)
```

Signed-off-by: Edwin Török <[email protected]>

Author: edwintorok

ocaml/database/db_cache.ml

@@ -19,30 +19,32 @@ module D = Debug.Make (struct let name = "db_cache" end)
 open D
 
 (** Masters will use this to modify the in-memory cache directly *)
-module Local_db : DB_ACCESS = Db_interface_compat.OfCached (Db_cache_impl)
+module Local_db : DB_ACCESS2 = Db_cache_impl
 
 (** Slaves will use this to call the master by XMLRPC *)
-module Remote_db : DB_ACCESS = Db_rpc_client_v1.Make (struct
+module Remote_db : DB_ACCESS2 =
+Db_interface_compat.OfCompat (Db_rpc_client_v1.Make (struct
   let initialise () =
     ignore (Master_connection.start_master_connection_watchdog ()) ;
     ignore (Master_connection.open_secure_connection ())
 
   let rpc request = Master_connection.execute_remote_fn request
-end)
+end))
 
 let get = function
   | Db_ref.In_memory _ ->
-      (module Local_db : DB_ACCESS)
+      (module Local_db : DB_ACCESS2)
   | Db_ref.Remote ->
-      (module Remote_db : DB_ACCESS)
+      (module Remote_db : DB_ACCESS2)
 
 let lifecycle_state_of ~obj fld =
   let open Datamodel in
   let {fld_states; _} = StringMap.find obj all_lifecycles in
   StringMap.find fld fld_states
 
+module DB = Db_interface_compat.OfCached (Local_db)
+
 let apply_delta_to_cache entry db_ref =
-  let module DB : DB_ACCESS = Local_db in
   match entry with
   | Redo_log.CreateRow (tblname, objref, kvs) ->
       debug "Redoing create_row %s (%s)" tblname objref ;

ocaml/database/db_cache.mli

@@ -12,6 +12,6 @@
  * GNU Lesser General Public License for more details.
  *)
 
-val get : Db_ref.t -> (module Db_interface.DB_ACCESS)
+val get : Db_ref.t -> (module Db_interface.DB_ACCESS2)
 
 val apply_delta_to_cache : Redo_log.t -> Db_ref.t -> unit

ocaml/idl/ocaml_backend/gen_api.ml

@@ -484,7 +484,9 @@ let gen_db_actions _config highapi =
            (toposort_types highapi only_records)
        ; (* NB record types are ignored by dm_to_string and string_to_dm *)
          O.Module.strings_of (dm_to_string all_types_in_db)
+       ; O.Module.strings_of (dm_to_field all_types_in_db)
        ; O.Module.strings_of (string_to_dm all_types_in_db)
+       ; O.Module.strings_of (field_to_dm all_types_in_db)
        ; O.Module.strings_of (db_action highapi_in_db)
        ]
     @ List.map O.Module.strings_of (Gen_db_check.all highapi_in_db)

ocaml/idl/ocaml_backend/gen_db_actions.ml

@@ -25,8 +25,12 @@ open DT
 (* Names of the modules we're going to generate (use these to prevent typos) *)
 let _dm_to_string = "DM_to_String"
 
+let _dm_to_field = "DM_to_Field"
+
 let _string_to_dm = "String_to_DM"
 
+let _field_to_dm = "Field_to_DM"
+
 let _db_action = "DB_Action"
 
 let _db_defaults = "DB_DEFAULTS"
@@ -109,6 +113,44 @@ let dm_to_string tys : O.Module.t =
     ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys)
     ()
 
+let dm_to_field tys : O.Module.t =
+  let tys = List.filter type_marshalled_in_db tys in
+  (* For every type, we create a single function *)
+  let ty_fun ty =
+    let body =
+      match ty with
+      | DT.Map (String, String) ->
+          "Schema.Value.pairs"
+      | DT.Map (key, value) ->
+          Printf.sprintf
+            "fun s ->  s |> List.map (fun (k, v) -> %s.%s k, %s.%s v) |> \
+             Schema.Value.pairs"
+            _dm_to_string (OU.alias_of_ty key) _dm_to_string
+            (OU.alias_of_ty value)
+      | DT.Set String ->
+          "Schema.Value.set"
+      | DT.Set ty ->
+          Printf.sprintf "fun s ->  s |> List.map %s.%s |> Schema.Value.set"
+            _dm_to_string (OU.alias_of_ty ty)
+      | DT.String ->
+          "Schema.Value.string"
+      | _ ->
+          Printf.sprintf "fun s -> s |> %s.%s |> Schema.Value.string"
+            _dm_to_string (OU.alias_of_ty ty)
+    in
+    O.Let.make ~name:(OU.alias_of_ty ty) ~params:[] ~ty:"Db_interface.field_in"
+      ~body:[body] ()
+  in
+  O.Module.make ~name:_dm_to_field
+    ~preamble:
+      [
+        "exception StringEnumTypeError of string"
+      ; "exception DateTimeError of string"
+      ]
+    ~letrec:true
+    ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys)
+    ()
+
 (** Generate a module of string to datamodel type unmarshalling functions *)
 let string_to_dm tys : O.Module.t =
   let tys = List.filter type_marshalled_in_db tys in
@@ -171,6 +213,53 @@ let string_to_dm tys : O.Module.t =
     ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys)
     ()
 
+let field_to_dm tys : O.Module.t =
+  let tys = List.filter type_marshalled_in_db tys in
+  (* For every type, we create a single function *)
+  let ty_fun ty =
+    let name = OU.alias_of_ty ty in
+    let body =
+      match ty with
+      | DT.Map (key, value) ->
+          let conv =
+            match (key, value) with
+            | DT.String, DT.String ->
+                ""
+            | _ ->
+                Printf.sprintf " |> List.map (fun (k, v) -> %s.%s k, %s.%s v)"
+                  _string_to_dm (OU.alias_of_ty key) _string_to_dm
+                  (OU.alias_of_ty value)
+          in
+          "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.Pairs \
+           |> Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.pairs"
+          ^ conv
+      | DT.Set ty ->
+          let conv =
+            match ty with
+            | DT.String ->
+                ""
+            | _ ->
+                Printf.sprintf " |> List.map %s.%s" _string_to_dm
+                  (OU.alias_of_ty ty)
+          in
+          "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.Set |> \
+           Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.set"
+          ^ conv
+      | DT.String ->
+          "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.String \
+           |> Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.string"
+      | _ ->
+          Printf.sprintf "fun f -> f |> Schema.CachedValue.string_of |> %s.%s"
+            _string_to_dm name
+    in
+    O.Let.make ~name ~params:[] ~ty:(OU.alias_of_ty ty) ~body:[body] ()
+  in
+  O.Module.make ~name:_field_to_dm
+    ~preamble:["exception StringEnumTypeError of string"]
+    ~letrec:true
+    ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys)
+    ()
+
 (** True if a field is actually in this table, false if stored elsewhere
     (ie Set(Ref _) are stored in foreign tables *)
 let field_in_this_table = function
@@ -283,7 +372,7 @@ let open_db_module =
   [
     "let __t = Context.database_of __context in"
   ; "let module DB = (val (Xapi_database.Db_cache.get __t) : \
-     Xapi_database.Db_interface.DB_ACCESS) in"
+     Xapi_database.Db_interface.DB_ACCESS2) in"
   ]
 
 let db_action api : O.Module.t =
@@ -331,7 +420,7 @@ let db_action api : O.Module.t =
           let ty_alias = OU.alias_of_ty f.DT.ty in
           let accessor = "find_regular" in
           let field_name = Escaping.escape_id f.full_name in
-          Printf.sprintf {|%s.%s (%s "%s")|} _string_to_dm ty_alias accessor
+          Printf.sprintf {|%s.%s (%s "%s")|} _field_to_dm ty_alias accessor
             field_name
     in
     let make_field f =
@@ -433,8 +522,13 @@ let db_action api : O.Module.t =
     let to_string arg =
       let binding = O.string_of_param arg in
       let converter = O.type_of_param arg in
-      Printf.sprintf "let %s = %s.%s %s in" binding _dm_to_string converter
-        binding
+      Printf.sprintf "let %s = %s.%s %s in" binding
+        ( if binding = Client._self || binding = "ref" then
+            _dm_to_string
+          else
+            _dm_to_field
+        )
+        converter binding
     in
     let body =
       match tag with
@@ -445,37 +539,38 @@ let db_action api : O.Module.t =
             (Escaping.escape_id fld.DT.full_name)
       | FromField (Getter, {DT.ty; full_name; _}) ->
           Printf.sprintf "%s.%s (DB.read_field __t \"%s\" \"%s\" %s)"
-            _string_to_dm (OU.alias_of_ty ty)
+            _field_to_dm (OU.alias_of_ty ty)
             (Escaping.escape_obj obj.DT.name)
             (Escaping.escape_id full_name)
             Client._self
       | FromField (Add, {DT.ty= DT.Map (_, _); full_name; _}) ->
           Printf.sprintf
-            "DB.process_structured_field __t (%s,%s) \"%s\" \"%s\" %s \
-             AddMapLegacy"
+            "DB.process_structured_field __t (Schema.Value.marshal %s, \
+             Schema.Value.marshal %s) \"%s\" \"%s\" %s AddMapLegacy"
             Client._key Client._value
             (Escaping.escape_obj obj.DT.name)
             (Escaping.escape_id full_name)
             Client._self
       | FromField (Add, {DT.ty= DT.Set _; full_name; _}) ->
           Printf.sprintf
-            "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s AddSet"
+            "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \
+             \"%s\" \"%s\" %s AddSet"
             Client._value
             (Escaping.escape_obj obj.DT.name)
             (Escaping.escape_id full_name)
             Client._self
       | FromField (Remove, {DT.ty= DT.Map (_, _); full_name; _}) ->
           Printf.sprintf
-            "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s \
-             RemoveMap"
+            "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \
+             \"%s\" \"%s\" %s RemoveMap"
             Client._key
             (Escaping.escape_obj obj.DT.name)
             (Escaping.escape_id full_name)
             Client._self
       | FromField (Remove, {DT.ty= DT.Set _; full_name; _}) ->
           Printf.sprintf
-            "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s \
-             RemoveSet"
+            "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \
+             \"%s\" \"%s\" %s RemoveSet"
             Client._value
             (Escaping.escape_obj obj.DT.name)
             (Escaping.escape_id full_name)
@@ -517,7 +612,9 @@ let db_action api : O.Module.t =
         match (x.msg_params, x.msg_result) with
         | [{param_name= name; _}], Some (result_ty, _) ->
             let query =
-              Printf.sprintf "DB.db_get_by_uuid __t \"%s\" %s"
+              Printf.sprintf
+                "DB.db_get_by_uuid __t \"%s\" (Schema.Value.Unsafe_cast.string \
+                 %s)"
                 (Escaping.escape_obj obj.DT.name)
                 (OU.escape name)
             in
@@ -530,7 +627,7 @@ let db_action api : O.Module.t =
               ^ ")"
             in
             let query_opt =
-              Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" %s"
+              Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" (%s)"
                 (Escaping.escape_obj obj.DT.name)
                 (OU.escape name)
             in
@@ -555,7 +652,9 @@ let db_action api : O.Module.t =
         match (x.msg_params, x.msg_result) with
         | [{param_name= name; _}], Some (Set result_ty, _) ->
             let query =
-              Printf.sprintf "DB.db_get_by_name_label __t \"%s\" %s"
+              Printf.sprintf
+                "DB.db_get_by_name_label __t \"%s\" \
+                 (Schema.Value.Unsafe_cast.string %s)"
                 (Escaping.escape_obj obj.DT.name)
                 (OU.escape name)
             in
@@ -606,13 +705,15 @@ let db_action api : O.Module.t =
       | FromObject GetAllRecordsWhere ->
           String.concat "\n"
             [
-              "let expr' = Xapi_database.Db_filter.expr_of_string expr in"
+              "let expr' = Xapi_database.Db_filter.expr_of_string \
+               (Schema.Value.Unsafe_cast.string expr) in"
             ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'"
             ]
       | FromObject GetAllWhere ->
           String.concat "\n"
             [
-              "let expr' = Xapi_database.Db_filter.expr_of_string expr in"
+              "let expr' = Xapi_database.Db_filter.expr_of_string \
+               (Schema.Value.Unsafe_cast.string expr) in"
             ; "get_refs_where ~" ^ Gen_common.context ^ " ~expr:expr'"
             ]
       | _ ->

ocaml/xapi/console.ml

@@ -185,7 +185,7 @@ let console_of_request __context req =
   let db = Context.database_of __context in
   let is_vm, _ =
     let module DB =
-      (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS)
+      (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS2)
     in
     match DB.get_table_from_ref db _ref with
     | Some c when c = Db_names.vm ->

ocaml/xapi/db.ml

@@ -23,5 +23,5 @@ let is_valid_ref __context r =
     false
   else
     let t = Context.database_of __context in
-    let module DB = (val Db_cache.get t : Db_interface.DB_ACCESS) in
+    let module DB = (val Db_cache.get t : Db_interface.DB_ACCESS2) in
     DB.is_valid_ref t (Ref.string_of r)

ocaml/xapi/db_gc_util.ml

@@ -28,7 +28,7 @@ let gc_connector ~__context get_all get_record valid_ref1 valid_ref2
     delete_record =
   let db = Context.database_of __context in
   let module DB =
-    (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS)
+    (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS2)
   in
   let all_refs = get_all ~__context in
   let do_gc ref =

ocaml/xapi/eventgen.ml

@@ -107,7 +107,7 @@ open Xapi_database.Db_action_helper
 let is_valid_ref db = function
   | Schema.Value.String r -> (
     try
-      ignore (Database.table_of_ref r db) ;
+      ignore (Database.table_of_ref (r :> string) db) ;
       true
     with _ -> false
   )

ocaml/xapi/helpers.ml

@@ -1349,13 +1349,19 @@ let vm_to_string __context vm =
     raise (Api_errors.Server_error (Api_errors.invalid_value, [str])) ;
   let t = Context.database_of __context in
   let module DB =
-    (val Xapi_database.Db_cache.get t : Xapi_database.Db_interface.DB_ACCESS)
+    (val Xapi_database.Db_cache.get t : Xapi_database.Db_interface.DB_ACCESS2)
   in
-  let fields = fst (DB.read_record t Db_names.vm str) in
+  let fields, _ = DB.read_record t Db_names.vm str in
   let sexpr =
     SExpr.Node
       (List.map
-         (fun (key, value) -> SExpr.Node [SExpr.String key; SExpr.String value])
+         (fun (key, value) ->
+           SExpr.Node
+             [
+               SExpr.String key
+             ; SExpr.String (Schema.CachedValue.string_of value)
+             ]
+         )
          fields
       )
   in

ocaml/xapi/xapi_vm_snapshot.ml

@@ -167,8 +167,10 @@ let copy_vm_fields ~__context ~metadata ~dst ~do_not_copy ~overrides =
   debug "copying metadata into %s" (Ref.string_of dst) ;
   let db = Context.database_of __context in
   let module DB =
-    (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS)
-  in
+    Xapi_database.Db_interface_compat.OfCached
+      (( val Xapi_database.Db_cache.get db
+           : Xapi_database.Db_interface.DB_ACCESS2
+         )) in
   List.iter
     (fun (key, value) ->
       let value = Option.value ~default:value (List.assoc_opt key overrides) in