CP-307958: Benchmark for Db writes

No functional change

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

Author: edwintorok

ocaml/tests/bench/bench_pool_field.ml

@@ -17,7 +17,8 @@ open Bechamel
 let () =
   Suite_init.harness_init () ;
   Printexc.record_backtrace true ;
-  Debug.set_level Syslog.Emerg
+  Debug.set_level Syslog.Emerg ;
+  Xapi_event.register_hooks ()
 
 let date = "20250102T03:04:05Z"
 
@@ -36,11 +37,21 @@ let json_str =
 
 let __context = Test_common.make_test_database ()
 
+let host = Test_common.make_host ~__context ()
+
+let pool = Test_common.make_pool ~__context ~master:host ()
+
 let () =
-  let host = Test_common.make_host ~__context () in
-  let pool = Test_common.make_pool ~__context ~master:host () in
   Db.Pool.set_license_server ~__context ~self:pool
-    ~value:[("jsontest", json_str)]
+    ~value:[("jsontest", json_str)] ;
+  let open Xapi_database in
+  Db_ref.update_database
+    (Context.database_of __context)
+    (Db_cache_types.Database.register_callback "redo_log"
+       Redo_log.database_callback
+    )
+
+let vm = Test_common.make_vm ~__context ~name_label:"test" ()
 
 let get_all () : API.pool_t list =
   Db.Pool.get_all_records ~__context |> List.map snd
@@ -95,6 +106,20 @@ let event =
 
 let test_rpc_of_event () = Event_types.rpc_of_event event
 
+let counter = Atomic.make 0
+
+let test_set_vm_nvram () : unit =
+  let c = Atomic.fetch_and_add counter 1 mod 0x7F in
+  (* use different value each iteration, otherwise it becomes a noop *)
+  Db.VM.set_NVRAM ~__context ~self:vm
+    ~value:[("test", String.make 32768 (Char.chr @@ c))]
+
+let test_db_pool_write () =
+  let c = Atomic.fetch_and_add counter 1 mod 0x7F in
+  Db.Pool.set_tags ~__context ~self:pool ~value:[String.make 16 (Char.chr @@ c)]
+
+let test_db_pool_read () = Db.Pool.get_tags ~__context ~self:pool
+
 let benchmarks =
   [
     Test.make ~name:"local_session_hook" (Staged.stage local_session_hook)
@@ -109,6 +134,9 @@ let benchmarks =
   ; Test.make ~name:"Db_lock.with_lock uncontended"
       (Staged.stage db_lock_uncontended)
   ; Test.make ~name:"rpc_of_event" (Staged.stage test_rpc_of_event)
+  ; Test.make ~name:"Db.Pool.set_tags" (Staged.stage test_db_pool_write)
+  ; Test.make ~name:"Db.Pool.get_tags" (Staged.stage test_db_pool_read)
+  ; Test.make ~name:"Db.VM.set_NVRAM" (Staged.stage test_set_vm_nvram)
   ]
 
 let () = Bechamel_simple_cli.cli benchmarks