Log proper names for POSIX signals (#6228)

The integer values that OCaml uses for signals should never be printed
as integers. They can cause confusion because they don't match the C
POSIX values.

Change the unixext function that converts them to string to stop
building a list and finding a value in the list to instead use
pattern-matching. Also added some more values that got introduced in
OCaml 4.03, and return a more compact value for unknown signals,
following the same format as Fmt.Dump.signal.

Typically, engineers see signal -11 and assume it's SIGSEGV, when it's
SIGTERM.

Fixes #6225

Author: psafont

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/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/libs/log/debug.ml

@@ -353,4 +353,8 @@ functor
       with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e ()
   end
 
-module Pp = struct let mtime_span () = Fmt.str "%a" Mtime.Span.pp end
+module Pp = struct
+  let mtime_span () = Fmt.to_to_string Mtime.Span.pp
+
+  let signal () = Fmt.(to_to_string Dump.signal)
+end

ocaml/libs/log/debug.mli

@@ -91,4 +91,8 @@ val is_disabled : string -> Syslog.level -> bool
 
 module Pp : sig
   val mtime_span : unit -> Mtime.Span.t -> string
+
+  val signal : unit -> int -> string
+  (** signal pretty-prints an ocaml signal number as its POSIX name, see
+      {Fmt.Dump.signal} *)
 end

ocaml/libs/xapi-compression/xapi_compression.ml

@@ -123,22 +123,17 @@ module Make (Algorithm : ALGORITHM) = struct
           error "%s" msg ; failwith msg
         in
         Unixfd.safe_close close_later ;
-        let open Xapi_stdext_unix in
         match snd (Forkhelpers.waitpid pid) with
         | Unix.WEXITED 0 ->
             ()
         | Unix.WEXITED i ->
             failwith_error (Printf.sprintf "exit code %d" i)
         | Unix.WSIGNALED i ->
             failwith_error
-              (Printf.sprintf "killed by signal: %s"
-                 (Unixext.string_of_signal i)
-              )
+              (Printf.sprintf "killed by signal: %a" Debug.Pp.signal i)
         | Unix.WSTOPPED i ->
             failwith_error
-              (Printf.sprintf "stopped by signal: %s"
-                 (Unixext.string_of_signal i)
-              )
+              (Printf.sprintf "stopped by signal: %a" Debug.Pp.signal i)
       )
 
   let compress fd f = go Compress Active fd f

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml

@@ -371,36 +371,6 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid =
       raise Process_still_alive
   )
 
-let string_of_signal x =
-  let table =
-    [
-      (Sys.sigabrt, "SIGABRT")
-    ; (Sys.sigalrm, "SIGALRM")
-    ; (Sys.sigfpe, "SIGFPE")
-    ; (Sys.sighup, "SIGHUP")
-    ; (Sys.sigill, "SIGILL")
-    ; (Sys.sigint, "SIGINT")
-    ; (Sys.sigkill, "SIGKILL")
-    ; (Sys.sigpipe, "SIGPIPE")
-    ; (Sys.sigquit, "SIGQUIT")
-    ; (Sys.sigsegv, "SIGSEGV")
-    ; (Sys.sigterm, "SIGTERM")
-    ; (Sys.sigusr1, "SIGUSR1")
-    ; (Sys.sigusr2, "SIGUSR2")
-    ; (Sys.sigchld, "SIGCHLD")
-    ; (Sys.sigcont, "SIGCONT")
-    ; (Sys.sigstop, "SIGSTOP")
-    ; (Sys.sigttin, "SIGTTIN")
-    ; (Sys.sigttou, "SIGTTOU")
-    ; (Sys.sigvtalrm, "SIGVTALRM")
-    ; (Sys.sigprof, "SIGPROF")
-    ]
-  in
-  if List.mem_assoc x table then
-    List.assoc x table
-  else
-    Printf.sprintf "(ocaml signal %d with an unknown name)" x
-
 let with_polly f =
   let polly = Polly.create () in
   let finally () = Polly.close polly in

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli

@@ -122,10 +122,6 @@ exception Process_still_alive
 
 val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit
 
-val string_of_signal : int -> string
-(** [string_of_signal x] translates an ocaml signal number into
- *  a string suitable for logging. *)
-
 val proxy : Unix.file_descr -> Unix.file_descr -> unit
 
 val really_read : Unix.file_descr -> bytes -> int -> int -> unit

ocaml/nbd/src/cleanup.ml

@@ -218,15 +218,21 @@ module Runtime = struct
         Printf.eprintf "SIGINT received - exiting" ;
         flush stderr ;
         exit 0
+    | Signal n ->
+        Printf.eprintf "unexpected signal %s in signal handler - exiting"
+          Fmt.(to_to_string Dump.signal n) ;
+        flush stderr ;
+        exit 1
     | e ->
         Printf.eprintf "unexpected exception %s in signal handler - exiting"
           (Printexc.to_string e) ;
         flush stderr ;
         exit 1
 
   let cleanup_resources signal =
+    let name = Fmt.(to_to_string Dump.signal signal) in
     let cleanup () =
-      Lwt_log.warning_f "Caught signal %d, cleaning up" signal >>= fun () ->
+      Lwt_log.warning_f "Caught signal %s, cleaning up" name >>= fun () ->
       (* First we have to close the open file descriptors corresponding to the
          VDIs we plugged to dom0. Otherwise the VDI.unplug call would hang. *)
       ignore_exn_log_error "Caught exception while closing open block devices"

ocaml/nbd/src/dune

@@ -4,7 +4,7 @@
  (libraries
   cmdliner
   consts
-  
+  fmt
   local_xapi_session
   lwt
   lwt.unix

ocaml/networkd/bin/network_server.ml

@@ -53,7 +53,8 @@ let on_shutdown signal =
   let dbg = "shutdown" in
   Debug.with_thread_associated dbg
     (fun () ->
-      debug "xcp-networkd caught signal %d; performing cleanup actions." signal ;
+      debug "xcp-networkd caught signal %a; performing cleanup actions."
+        Debug.Pp.signal signal ;
       write_config ()
     )
     ()