Display Windows NTSTATUS exit codes in hex

On Windows, "negative" exit codes are probably NTSTATUS values. For
example, if a program accesses an invalid memory location, Unix sends
a SIGSEGV signal which, if unhandled, will terminate the
process (setting some kind of non-zero exit code - for example, Linux
sets the exit code to 128 + signal number to give a fairly memorable
139). In the equivalent scenario, Windows throws an
EXCEPTION_ACCESS_VIOLATION which, if handled by the default exception
handler, will terminate the process with exit code
STATUS_ACCESS_VIOLATION. These codes are large negative numbers, which
are not terribly memorable in decimal, so for negative exit codes we
instead display them in hexadecimal as 0xc0000005 is slightly more
memorable than -1073741819.

Co-authored-by: David Allsopp <david.allsopp@metastack.com>
Signed-off-by: Antonin Décimo <antonin@tarides.com>

Author: MisterDA

lib/os.ml

@@ -34,6 +34,12 @@ let pp_cmd f (cmd, argv) =
   let argv = if cmd = "" then argv else cmd :: argv in
   Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv
 
+let pp_exit_status f n =
+  if Sys.win32 && n < 0 then
+    Fmt.pf f "0x%08lx" (Int32.of_int n)
+  else
+    Fmt.int f n
+
 let redirection = function
   | `FD_move_safely x -> `FD_copy x.raw
   | `Dev_null -> `Dev_null
@@ -87,7 +93,7 @@ let process_result ~pp proc =
   | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x)
   >>= function
   | Ok 0 -> Lwt_result.return ()
-  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
+  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n
   | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
 
 (* Overridden in unit-tests *)
@@ -97,15 +103,15 @@ let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="")
   Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
   !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
   | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit
-  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
+  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n
   | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
 
 let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv =
   Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
   let pp f = pp_cmd f (cmd, argv) in
   !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
   | Ok n when is_success n -> Lwt.return_unit
-  | Ok n -> Fmt.failwith "%t failed with exit status %d" pp n
+  | Ok n -> Fmt.failwith "%t failed with exit status %a" pp pp_exit_status n
   | Error (`Msg m) -> failwith m
 
 let running_as_root = not (Sys.unix) || Unix.getuid () = 0