TEST COMMIT FOR MEGA MERGE WORKFLOW

Parent for all active dev branches.
To check for conflicts, for easy testing, etc.
Autorebased by jj.

dune-project

@@ -320,6 +320,7 @@
   (synopsis "The toolstack daemon which implements the XenAPI")
   (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.")
   (depends
+    (ocaml (>= 4.09))
     (alcotest :with-test)
     angstrom
     astring

ocaml/database/db_cache_impl.ml

@@ -256,7 +256,7 @@ let read_refs t tblname =
   Table.fold (fun r _ _ acc -> r :: acc) tbl []
 
 (* Return a list of all the refs for which the expression returns true. *)
-let find_refs_with_filter_internal db (tblname : string)
+let find_refs_with_filter_internal db (tblname : Db_interface.table)
     (expr : Db_filter_types.expr) =
   let tbl = TableSet.find tblname (Database.tableset db) in
   let eval_val row = function

ocaml/database/db_cache_types.ml

@@ -175,7 +175,8 @@ module Row = struct
         else
           t
       )
-      t schema.Schema.Table.columns
+      t
+      (Schema.ColumnMap.to_list schema.Schema.Table.columns)
 end
 
 module Table = struct

ocaml/database/db_interface.ml

@@ -23,74 +23,87 @@ module type RPC = sig
   (** [rpc request] transmits [request] and receives a response *)
 end
 
+type table = string
+
+type field_name = string
+
+type field = string
+
+type db_ref = string
+
+type uuid = string
+
+type regular_fields = (field_name * field) list
+
+type associated_fields = (field_name * db_ref list) list
+
 (** dictionary of regular fields x dictionary of associated set_ref values *)
-type db_record = (string * string) list * (string * string list) list
+type db_record = regular_fields * associated_fields
 
 (** The client interface to the database *)
 module type DB_ACCESS = sig
   val initialise : unit -> unit
   (** [initialise ()] must be called before any other function in this
       		interface *)
 
-  val get_table_from_ref : Db_ref.t -> string -> string option
-  (** [get_table_from_ref ref] returns [Some tbl] if [ref] is a
+  val get_table_from_ref : Db_ref.t -> db_ref -> table option
+  (** [get_table_from_ref ref tbl] returns [Some tbl] if [ref] is a
       		valid reference; None otherwise *)
 
-  val is_valid_ref : Db_ref.t -> string -> bool
+  val is_valid_ref : Db_ref.t -> db_ref -> bool
   (** [is_valid_ref ref] returns true if [ref] is valid; false otherwise *)
 
-  val read_refs : Db_ref.t -> string -> string list
+  val read_refs : Db_ref.t -> table -> db_ref list
   (** [read_refs tbl] returns a list of all references in table [tbl] *)
 
   val find_refs_with_filter :
-    Db_ref.t -> string -> Db_filter_types.expr -> string list
+    Db_ref.t -> table -> Db_filter_types.expr -> db_ref list
   (** [find_refs_with_filter tbl expr] returns a list of all references
       		to rows which match [expr] *)
 
-  val read_field_where : Db_ref.t -> Db_cache_types.where_record -> string list
+  val read_field_where : Db_ref.t -> Db_cache_types.where_record -> field list
   (** [read_field_where {tbl,return,where_field,where_value}] returns a
       		list of the [return] fields in table [tbl] where the [where_field]
       		equals [where_value] *)
 
-  val db_get_by_uuid : Db_ref.t -> string -> string -> string
+  val db_get_by_uuid : Db_ref.t -> table -> uuid -> db_ref
   (** [db_get_by_uuid tbl uuid] returns the single object reference
       		associated with [uuid] *)
 
-  val db_get_by_name_label : Db_ref.t -> string -> string -> string list
+  val db_get_by_name_label : Db_ref.t -> table -> string -> db_ref list
   (** [db_get_by_name_label tbl label] returns the list of object references
       		associated with [label] *)
 
-  val create_row :
-    Db_ref.t -> string -> (string * string) list -> string -> unit
+  val create_row : Db_ref.t -> table -> regular_fields -> db_ref -> unit
   (** [create_row tbl kvpairs ref] create a new row in [tbl] with
       		key [ref] and contents [kvpairs] *)
 
-  val delete_row : Db_ref.t -> string -> string -> unit
+  val delete_row : Db_ref.t -> db_ref -> table -> unit
   (** [delete_row context tbl ref] deletes row [ref] from table [tbl] *)
 
-  val write_field : Db_ref.t -> string -> string -> string -> string -> unit
+  val write_field : Db_ref.t -> table -> db_ref -> field_name -> field -> unit
   (** [write_field context tbl ref fld val] changes field [fld] to [val] in
       		row [ref] in table [tbl] *)
 
-  val read_field : Db_ref.t -> string -> string -> string -> string
+  val read_field : Db_ref.t -> table -> db_ref -> field_name -> field
   (** [read_field context tbl ref fld] returns the value of field [fld]
       		in row [ref] in table [tbl] *)
 
-  val read_record : Db_ref.t -> string -> string -> db_record
+  val read_record : Db_ref.t -> table -> db_ref -> db_record
   (** [read_record tbl ref] returns
       		[ (field, value) ] * [ (set_ref fieldname * [ ref ]) ] *)
 
   val read_records_where :
-    Db_ref.t -> string -> Db_filter_types.expr -> (string * db_record) list
+    Db_ref.t -> table -> Db_filter_types.expr -> (db_ref * db_record) list
   (** [read_records_where tbl expr] returns a list of the values returned
       		by read_record that match the expression *)
 
   val process_structured_field :
        Db_ref.t
-    -> string * string
-    -> string
-    -> string
-    -> string
+    -> field_name * field
+    -> table
+    -> field_name
+    -> db_ref
     -> Db_cache_types.structured_op_t
     -> unit
   (** [process_structured_field context kv tbl fld ref op] modifies the

ocaml/database/db_lock.ml

@@ -79,9 +79,9 @@ module ReentrantLock : REENTRANT_LOCK = struct
 
   let current_tid () = Thread.(self () |> id)
 
-  let [@inline never][@specialize never] lock_acquired () = ()
+  let [@inline never][@specialize never] lock_acquired () = Xapi_timeslice.Timeslice.lock_acquired ()
 
-  let [@inline never][@specialize never] lock_released () = ()
+  let [@inline never][@specialize never] lock_released () = Xapi_timeslice.Timeslice.lock_released ()
 
   let lock l =
     let me = current_tid () in

ocaml/database/dune

@@ -48,6 +48,7 @@
     xapi-stdext-std
     xapi-stdext-threads
     xapi-stdext-unix
+    xapi_timeslice
     xml-light2
     xmlm
   )

ocaml/database/schema.ml

@@ -16,7 +16,7 @@ open Sexplib0.Sexp_conv
 
 module Type = struct
   type t = String | Set  (** of strings *) | Pairs  (** of strings *)
-  [@@deriving sexp]
+  [@@deriving sexp_of]
 
   exception Error of t * t
 
@@ -38,7 +38,7 @@ module Value = struct
     | String of string
     | Set of string list
     | Pairs of (string * string) list
-  [@@deriving sexp]
+  [@@deriving sexp_of]
 
   let marshal = function
     | String x ->
@@ -95,24 +95,45 @@ module Column = struct
     ; issetref: bool
           (** only so we can special case set refs in the interface *)
   }
-  [@@deriving sexp]
+  [@@deriving sexp_of]
+end
+
+module ColumnMap = struct
+  module M = Map.Make (String)
+
+  type t = Column.t M.t * Column.t list
+
+  type compat = Column.t list [@@deriving sexp_of]
+
+  let of_list columns =
+    ( columns |> List.fold_left (fun acc c -> M.add c.Column.name c acc) M.empty
+    , columns
+    )
+
+  let to_list (_, lst) = lst
+
+  let sexp_of_t (_, compat) = sexp_of_compat compat
+
+  let find_opt name (t, _) = M.find_opt name t
 end
 
 module Table = struct
-  type t = {name: string; columns: Column.t list; persistent: bool}
-  [@@deriving sexp]
+  type t = {name: string; columns: ColumnMap.t; persistent: bool}
+  [@@deriving sexp_of]
 
   let find name t =
-    try List.find (fun col -> col.Column.name = name) t.columns
-    with Not_found ->
-      raise (Db_exn.DBCache_NotFound ("missing column", t.name, name))
+    match ColumnMap.find_opt name t.columns with
+    | Some result ->
+        result
+    | None ->
+        raise (Db_exn.DBCache_NotFound ("missing column", t.name, name))
 end
 
 type relationship = OneToMany of string * string * string * string
-[@@deriving sexp]
+[@@deriving sexp_of]
 
 module Database = struct
-  type t = {tables: Table.t list} [@@deriving sexp]
+  type t = {tables: Table.t list} [@@deriving sexp_of]
 
   let find name t =
     try List.find (fun tbl -> tbl.Table.name = name) t.tables
@@ -121,7 +142,7 @@ module Database = struct
 end
 
 (** indexed by table name, a list of (this field, foreign table, foreign field) *)
-type foreign = (string * string * string) list [@@deriving sexp]
+type foreign = (string * string * string) list [@@deriving sexp_of]
 
 module ForeignMap = struct
   include Map.Make (struct
@@ -130,17 +151,13 @@ module ForeignMap = struct
     let compare = Stdlib.compare
   end)
 
-  type t' = (string * foreign) list [@@deriving sexp]
+  type t' = (string * foreign) list [@@deriving sexp_of]
 
   type m = foreign t
 
   let sexp_of_m t : Sexp.t =
     let t' = fold (fun key foreign acc -> (key, foreign) :: acc) t [] in
     sexp_of_t' t'
-
-  let m_of_sexp sexp : m =
-    let t' = t'_of_sexp sexp in
-    List.fold_left (fun acc (key, foreign) -> add key foreign acc) empty t'
 end
 
 type t = {
@@ -151,7 +168,7 @@ type t = {
   ; one_to_many: ForeignMap.m
   ; many_to_many: ForeignMap.m
 }
-[@@deriving sexp]
+[@@deriving sexp_of]
 
 let database x = x.database
 

ocaml/database/test_schemas.ml

@@ -103,14 +103,24 @@ let schema =
     {
       Schema.Table.name= "VM"
     ; columns=
-        [_ref; uuid; name_label; vbds; pp; name_description; tags; other_config]
+        Schema.ColumnMap.of_list
+          [
+            _ref
+          ; uuid
+          ; name_label
+          ; vbds
+          ; pp
+          ; name_description
+          ; tags
+          ; other_config
+          ]
     ; persistent= true
     }
   in
   let vbd_table =
     {
       Schema.Table.name= "VBD"
-    ; columns= [_ref; uuid; vm; type']
+    ; columns= Schema.ColumnMap.of_list [_ref; uuid; vm; type']
     ; persistent= true
     }
   in
@@ -140,10 +150,18 @@ let many_to_many =
   in
   let foo_column = {bar_column with Schema.Column.name= "foos"} in
   let foo_table =
-    {Schema.Table.name= "foo"; columns= [bar_column]; persistent= true}
+    {
+      Schema.Table.name= "foo"
+    ; columns= Schema.ColumnMap.of_list [bar_column]
+    ; persistent= true
+    }
   in
   let bar_table =
-    {Schema.Table.name= "bar"; columns= [foo_column]; persistent= true}
+    {
+      Schema.Table.name= "bar"
+    ; columns= Schema.ColumnMap.of_list [foo_column]
+    ; persistent= true
+    }
   in
   let database = {Schema.Database.tables= [foo_table; bar_table]} in
   let many_to_many =

ocaml/hwtune/dune

@@ -0,0 +1,5 @@
+(executable
+	(public_name xshwtune)
+	(libraries xapi_timeslice unix xapi-log)
+	(package xapi)
+)

ocaml/hwtune/xshwtune.ml

@@ -0,0 +1,44 @@
+(* Tunes parameters for the hardware and kernel that we are currently running on. *)
+
+module D = Debug.Make (struct let name = "xshwtune" end)
+
+let () =
+  Debug.log_to_stdout () ;
+  let recommended = Xapi_timeslice.Recommended.measure () in
+  D.debug "Recommended OCaml timeslice: %.6fs" recommended ;
+
+  let itimer_min =
+    Sys.set_signal Sys.sigvtalrm Sys.Signal_ignore ;
+    let _ =
+      Unix.setitimer Unix.ITIMER_VIRTUAL
+        Unix.{it_value= 1e-6; it_interval= 1e-6}
+    in
+    let actual = Unix.getitimer Unix.ITIMER_VIRTUAL in
+    actual.Unix.it_value
+  in
+
+  D.debug "POSIX itimer granularity: %.6fs" itimer_min ;
+  let recommended = Float.max itimer_min recommended in
+
+  (* just in case something goes very wrong, ensure it is not too small or big *)
+  let recommended = recommended |> Float.max 0.001 |> Float.min 0.050 in
+  D.debug "Adjusted timeslice: %.6fs" recommended ;
+
+  (* Use consistent rounding in debug messages and conf file,
+     by converting to string in a single place.
+  *)
+  let recommended = Printf.sprintf "%.3f" recommended in
+
+  D.info "OCaml timeslice: %s" recommended ;
+
+  let write_conf path =
+    Out_channel.with_open_text path @@ fun ch ->
+    Printf.fprintf ch "timeslice=%s" recommended
+  in
+
+  Array.iteri
+    (fun i arg ->
+      if i > 0 then
+        write_conf arg
+    )
+    Sys.argv

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 785
+let schema_minor_vsn = 786
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_lifecycle.ml

@@ -52,7 +52,7 @@ let prototyped_of_field = function
   | "VTPM", "persistence_backend" ->
       Some "22.26.0"
   | "SM", "host_pending_features" ->
-      Some "24.36.0-next"
+      Some "24.37.0"
   | "host", "last_update_hash" ->
       Some "24.10.0"
   | "host", "pending_guidances_full" ->