CP-49135: speed up UUID generation

ocaml/forkexecd/test/fe_test.ml

@@ -292,7 +292,7 @@ let slave = function
       (*
 		  Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1)
 		*)
-      if total_fds <> List.length filtered then
+      if total_fds + 1 (* Uuid.dev_urandom *) <> List.length filtered then
         fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds
           (List.length filtered) ls
 

ocaml/idl/ocaml_backend/gen_api.ml

@@ -400,15 +400,7 @@ let gen_client_types highapi =
          ; "  Rpc.failure (rpc_of_failure ([\"Fault\"; code]))"
          ]
        ; ["include Rpc"; "type string_list = string list [@@deriving rpc]"]
-       ; [
-           "module Ref = struct"
-         ; "  include Ref"
-         ; "  let rpc_of_t (_:'a -> Rpc.t) (x: 'a Ref.t) = rpc_of_string \
-            (Ref.string_of x)"
-         ; "  let t_of_rpc (_:Rpc.t -> 'a) x : 'a t = of_string (string_of_rpc \
-            x);"
-         ; "end"
-         ]
+       ; ["module Ref = Ref"]
        ; [
            "module Date = struct"
          ; "  open Xapi_stdext_date"

ocaml/libs/uuid/uuidx.ml

@@ -38,34 +38,28 @@ let is_uuid str = match of_string str with None -> false | Some _ -> true
 
 let dev_urandom = "/dev/urandom"
 
+let dev_urandom_fd = Unix.openfile dev_urandom [Unix.O_RDONLY] 0o640
+(* we can't close this in at_exit, because Crowbar runs at_exit, and
+   it'll fail because this FD will then be closed
+*)
+
 let read_bytes dev n =
-  let fd = Unix.openfile dev [Unix.O_RDONLY] 0o640 in
-  let finally body_f clean_f =
-    try
-      let ret = body_f () in
-      clean_f () ; ret
-    with e -> clean_f () ; raise e
-  in
-  finally
-    (fun () ->
-      let buf = Bytes.create n in
-      let read = Unix.read fd buf 0 n in
-      if read <> n then
-        raise End_of_file
-      else
-        Bytes.to_string buf
-    )
-    (fun () -> Unix.close fd)
-
-let make_uuid_urnd () = of_bytes (read_bytes dev_urandom 16) |> Option.get
+  let buf = Bytes.create n in
+  let read = Unix.read dev buf 0 n in
+  if read <> n then
+    raise End_of_file
+  else
+    Bytes.to_string buf
+
+let make_uuid_urnd () = of_bytes (read_bytes dev_urandom_fd 16) |> Option.get
 
 (* Use the CSPRNG-backed urandom *)
 let make = make_uuid_urnd
 
 type cookie = string
 
 let make_cookie () =
-  read_bytes dev_urandom 64
+  read_bytes dev_urandom_fd 64
   |> String.to_seq
   |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c))
   |> List.of_seq

ocaml/tests/bench/bench_uuid.ml

@@ -0,0 +1,10 @@
+open Bechamel
+
+let benchmarks =
+  Test.make_grouped ~name:"uuidx creation"
+    [
+      Test.make ~name:"Uuidx.make_uuid_urnd" (Staged.stage Uuidx.make_uuid_urnd)
+    ; Test.make ~name:"Uuidx.make" (Staged.stage Uuidx.make)
+    ]
+
+let () = Bechamel_simple_cli.cli benchmarks

ocaml/tests/bench/dune

@@ -1,4 +1,4 @@
-(executable
-	(name bench_tracing)
-	(libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty)
+(executables
+	(names bench_tracing bench_uuid)
+	(libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty uuid)
 )

ocaml/xapi-types/ref.ml

@@ -138,3 +138,7 @@ let really_pretty_and_small x =
       "NULL"
 
 let pp ppf x = Format.fprintf ppf "%s" (string_of x)
+
+let rpc_of_t _ x = Rpc.rpc_of_string (string_of x)
+
+let t_of_rpc _ x = of_string (Rpc.string_of_rpc x)

ocaml/xapi-types/ref.mli

@@ -14,6 +14,10 @@
 
 type 'a t
 
+val rpc_of_t : ('a -> Rpc.t) -> 'a t -> Rpc.t
+
+val t_of_rpc : (Rpc.t -> 'a) -> Rpc.t -> 'a t
+
 val ref_prefix : string
 
 val make : unit -> 'a t