Update feature/perf with latest blocker fixes (#6237)

Author: edwintorok

.github/workflows/release.yml

@@ -20,13 +20,11 @@ jobs:
           python-version: "3.x"
 
       - name: Install build dependencies
-        run: |
-          pip install build
-          sudo apt-get install ocaml dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev
+        run: pip install build
 
       - name: Generate python package for XenAPI
         run: |
-          ./configure --xapi_version=${{ github.ref_name }}
+          echo "export XAPI_VERSION=${{ github.ref_name }}" > config.mk
           make python
 
       - name: Store python distribution artifacts

doc/content/design/coverage/index.md

@@ -8,7 +8,7 @@ revision: 2
 
 We would like to add optional coverage profiling to existing [OCaml]
 projects in the context of [XenServer] and [XenAPI]. This article
-presents how we do it. 
+presents how we do it.
 
 Binaries instrumented for coverage profiling in the XenServer project
 need to run in an environment where several services act together as
@@ -21,7 +21,7 @@ isolation.
 To build binaries with coverage profiling, do:
 
     ./configure --enable-coverage
-    make 
+    make
 
 Binaries will log coverage data to `/tmp/bisect*.out` from which a
 coverage report can be generated in `coverage/`:
@@ -38,7 +38,7 @@ and logs during execution data to in-memory data structures. Before an
 instrumented binary terminates, it writes the logged data to a file.
 This data can then be analysed with the `bisect-ppx-report` tool, to
 produce a summary of annotated code that highlights what part of a
-codebase was executed. 
+codebase was executed.
 
 [BisectPPX] has several desirable properties:
 
@@ -65,13 +65,13 @@ abstracted by OCamlfind (OCaml's library manager) and OCamlbuild
 
     # build it with instrumentation from bisect_ppx
     ocamlbuild -use-ocamlfind -pkg bisect_ppx -pkg unix example.native
-    
+
     # execute it - generates files ./bisect*.out
     ./example.native
-    
+
     # generate report
     bisect-ppx-report -I _build -html coverage bisect000*
-    
+
     # view coverage/index.html
 
     Summary:
@@ -86,7 +86,7 @@ will be instrumented during compilation. Behind the scenes `ocamlfind`
 makes sure that the compiler uses a preprocessing step that instruments
 the code.
 
-## Signal Handling 
+## Signal Handling
 
 During execution the code instrumentation leads to the collection of
 data. This code registers a function with `at_exit` that writes the data
@@ -98,7 +98,7 @@ terminated by receiving the `TERM` signal, a signal handler must be
 installed:
 
     let stop signal =
-      printf "caught signal %d\n" signal;
+      printf "caught signal %a\n" Debug.Pp.signal signal;
       exit 0
 
     Sys.set_signal Sys.sigterm (Sys.Signal_handle stop)
@@ -149,8 +149,8 @@ environment variable. This can happen on the command line:
 
     BISECT_FILE=/tmp/example ./example.native
 
-In the context of XenServer we could do this in startup scripts. 
-However, we added a bit of code 
+In the context of XenServer we could do this in startup scripts.
+However, we added a bit of code
 
     val Coverage.init: string -> unit
 
@@ -176,12 +176,12 @@ Goals for instrumentation are:
 
 * what files are instrumented should be obvious and easy to manage
 * instrumentation must be optional, yet easy to activate
-* avoid methods that require to keep several files in sync like multiple 
+* avoid methods that require to keep several files in sync like multiple
   `_oasis` files
 * avoid separate Git branches for instrumented and non-instrumented
   code
 
-In the ideal case, we could introduce a configuration switch 
+In the ideal case, we could introduce a configuration switch
 `./configure --enable-coverage` that would prepare compilation for
 coverage instrumentation. While [Oasis] supports the creation of such
 switches, they cannot be used to control build dependencies like
@@ -196,7 +196,7 @@ rules in file `_tags.coverage` that cause files to be instrumented:
 
 leads to the execution of this code during preparation:
 
-    coverage: _tags _tags.coverage 
+    coverage: _tags _tags.coverage
       test ! -f _tags.orig && mv _tags _tags.orig || true
       cat _tags.coverage _tags.orig > _tags
 
@@ -207,7 +207,7 @@ could be tweaked to instrument only some files:
     <**/*.native>:   pkg_bisect_ppx
 
 When `make coverage` is not called, these rules are not active and
-hence, code is not instrumented for coverage. We believe that this 
+hence, code is not instrumented for coverage. We believe that this
 solution to control instrumentation meets the goals from above. In
 particular, what files are instrumented and when is controlled by very
 few lines of declarative code that lives in the main repository of a
@@ -226,14 +226,14 @@ coverage analysis are:
 The `_oasis` file bundles the files under `profiling/` into an internal
 library which executables then depend on:
 
-		# Support files for profiling 
+		# Support files for profiling
 		Library profiling
 			CompiledObject:     best
 			Path:               profiling
 			Install:            false
 			Findlibname:        profiling
 			Modules:            Coverage
-			BuildDepends: 
+			BuildDepends:
 
 		Executable set_domain_uuid
 			CompiledObject:     best
@@ -243,16 +243,16 @@ library which executables then depend on:
 			MainIs:             set_domain_uuid.ml
 			Install:            false
 			BuildDepends:
-				xenctrl, 
-				uuidm, 
+				xenctrl,
+				uuidm,
 				cmdliner,
 				profiling			# <-- here
 
 The `Makefile` target `coverage` primes the project for a profiling build:
 
 		# make coverage - prepares for building with coverage analysis
 
-		coverage: _tags _tags.coverage 
+		coverage: _tags _tags.coverage
 			test ! -f _tags.orig && mv _tags _tags.orig || true
 			cat _tags.coverage _tags.orig > _tags
 

ocaml/forkexecd/lib/dune

@@ -4,7 +4,9 @@
  (wrapped false)
  (libraries
    astring
+   clock
    fd-send-recv
+   mtime
    rpclib.core
    rpclib.json
    rpclib.xml

ocaml/forkexecd/lib/forkhelpers.ml

@@ -315,8 +315,8 @@ let safe_close_and_exec ?tracing ?env stdin stdout stderr
     close_fds
 
 let execute_command_get_output_inner ?tracing ?env ?stdin
-    ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false)
-    ?(timeout = -1.0) cmd args =
+    ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) timeout
+    cmd args =
   let to_close = ref [] in
   let close fd =
     if List.mem fd !to_close then (
@@ -354,8 +354,13 @@ let execute_command_get_output_inner ?tracing ?env ?stdin
                     close wr
                   )
                   stdinandpipes ;
-                if timeout > 0. then
-                  Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout ;
+                ( match timeout with
+                | Some span ->
+                    let timeout = Clock.Timer.span_to_s span in
+                    Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout
+                | None ->
+                    ()
+                ) ;
                 with_tracing ~tracing ~name:"Forkhelpers.waitpid" @@ fun _ ->
                 try waitpid (sock, pid)
                 with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) ->
@@ -380,12 +385,12 @@ let execute_command_get_output_inner ?tracing ?env ?stdin
 let execute_command_get_output ?tracing ?env ?(syslog_stdout = NoSyslogging)
     ?(redirect_stderr_to_stdout = false) ?timeout cmd args =
   with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
-  execute_command_get_output_inner ?tracing ?env ?stdin:None ?timeout
-    ~syslog_stdout ~redirect_stderr_to_stdout cmd args
+  execute_command_get_output_inner ?tracing ?env ?stdin:None ~syslog_stdout
+    ~redirect_stderr_to_stdout timeout cmd args
 
 let execute_command_get_output_send_stdin ?tracing ?env
     ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false)
     ?timeout cmd args stdin =
   with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
   execute_command_get_output_inner ?tracing ?env ~stdin ~syslog_stdout
-    ~redirect_stderr_to_stdout ?timeout cmd args
+    ~redirect_stderr_to_stdout timeout cmd args

ocaml/forkexecd/lib/forkhelpers.mli

@@ -48,7 +48,7 @@ val execute_command_get_output :
   -> ?env:string array
   -> ?syslog_stdout:syslog_stdout
   -> ?redirect_stderr_to_stdout:bool
-  -> ?timeout:float
+  -> ?timeout:Mtime.Span.t
   -> string
   -> string list
   -> string * string
@@ -61,7 +61,7 @@ val execute_command_get_output_send_stdin :
   -> ?env:string array
   -> ?syslog_stdout:syslog_stdout
   -> ?redirect_stderr_to_stdout:bool
-  -> ?timeout:float
+  -> ?timeout:Mtime.Span.t
   -> string
   -> string list
   -> string

ocaml/forkexecd/src/child.ml

@@ -111,11 +111,11 @@ let report_child_exit comms_sock args child_pid status =
         Fe.WEXITED n
     | Unix.WSIGNALED n ->
         log_failure args child_pid
-          (Printf.sprintf "exited with signal: %s" (Unixext.string_of_signal n)) ;
+          (Printf.sprintf "exited with signal: %a" Debug.Pp.signal n) ;
         Fe.WSIGNALED n
     | Unix.WSTOPPED n ->
         log_failure args child_pid
-          (Printf.sprintf "stopped with signal: %s" (Unixext.string_of_signal n)) ;
+          (Printf.sprintf "stopped with signal: %a" Debug.Pp.signal n) ;
         Fe.WSTOPPED n
   in
   let result = Fe.Finished pr in

ocaml/forkexecd/test/dune

@@ -1,7 +1,7 @@
 (executable
  (modes exe)
  (name fe_test)
- (libraries forkexec uuid xapi-stdext-unix fd-send-recv))
+ (libraries fmt forkexec mtime clock mtime.clock.os uuid xapi-stdext-unix fd-send-recv))
 
 (rule
  (alias runtest)

ocaml/forkexecd/test/fe_test.ml

@@ -115,12 +115,6 @@ let one fds x =
     :: string_of_int (fds - (x.max_extra - number_of_extra))
     :: shuffle cmdline_names
   in
-  (* Printf.fprintf stderr "stdin = %s\n" (if x.stdin then "Some" else "None");
-     Printf.fprintf stderr "stdout = %s\n" (if x.stdout then "Some" else "None");
-     Printf.fprintf stderr "stderr = %s\n" (if x.stderr then "Some" else "None");
-     List.iter (fun (uuid, _) -> Printf.fprintf stderr "uuid %s -> stdin\n" uuid) table;
-     Printf.fprintf stderr "%s %s\n" exe (String.concat " " args);
-  *)
   Forkhelpers.waitpid_fail_if_bad_exit
     (Forkhelpers.safe_close_and_exec
        (if x.stdin then Some fd else None)
@@ -129,26 +123,43 @@ let one fds x =
        table exe args
     )
 
+type in_range = In_range | Longer | Shorter
+
+let in_range ~e:leeway ~around span =
+  let upper = Mtime.Span.add around leeway in
+  if Clock.Timer.span_is_shorter ~than:around span then
+    Shorter
+  else if Clock.Timer.span_is_longer ~than:upper span then
+    Longer
+  else
+    In_range
+
 let test_delay () =
-  let start = Unix.gettimeofday () in
+  let start = Mtime_clock.counter () in
   let args = ["sleep"] in
   (* Need to have fractional part because some internal usage split integer
      and fractional and do computation.
      Better to have a high fractional part (> 0.5) to more probably exceed
      the unit.
   *)
-  let timeout = 1.7 in
+  let timeout = Mtime.Span.(1700 * ms) in
   try
     Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ;
     fail "Failed to timeout"
   with
-  | Forkhelpers.Subprocess_timeout ->
-      let elapsed = Unix.gettimeofday () -. start in
-      Printf.printf "Caught timeout exception after %f seconds\n%!" elapsed ;
-      if elapsed < timeout then
-        failwith "Process exited too soon" ;
-      if elapsed > timeout +. 0.2 then
-        failwith "Excessive time elapsed"
+  | Forkhelpers.Subprocess_timeout -> (
+      let elapsed = Mtime_clock.count start in
+      Printf.printf "Caught timeout exception after %s seconds\n%!"
+        Fmt.(to_to_string Mtime.Span.pp elapsed) ;
+
+      match in_range ~e:Mtime.Span.(200 * ms) ~around:timeout elapsed with
+      | In_range ->
+          ()
+      | Shorter ->
+          failwith "Process exited too soon"
+      | Longer ->
+          failwith "Process took too long to exit"
+    )
   | e ->
       fail "Failed with unexpected exception: %s" (Printexc.to_string e)
 
@@ -289,9 +300,6 @@ let slave = function
         )
         fds ;
       (* Check that we have the expected number *)
-      (*
-		  Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1)
-		*)
       if total_fds <> List.length filtered then
         fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds
           (List.length filtered) ls