Add set_uncaught_exception_handler to systhreads (#10469)

Changes

@@ -33,6 +33,10 @@ Working version
   to emulate Unix.socketpair (only available on Windows 1803+)
   (Antonin Décimo, review by David Allsopp)
 
+- #10469: Add Thread.set_uncaught_exception_handler and
+  Thread.default_uncaught_exception_handler.
+  (Enguerrand Decorne, review by David Allsopp)
+
 ### Tools:
 
 - #3959, #7202, #10476: ocaml, in script mode, directive errors

otherlibs/systhreads/thread.ml

@@ -34,15 +34,33 @@ external exit_stub : unit -> unit = "caml_thread_exit"
 
 let[@inline never] check_memprof_cb () = ref ()
 
+let default_uncaught_exception_handler = thread_uncaught_exception
+
+let uncaught_exception_handler = ref default_uncaught_exception_handler
+
+let set_uncaught_exception_handler fn = uncaught_exception_handler := fn
+
 let create fn arg =
   thread_new
     (fun () ->
       try
         fn arg;
         ignore (Sys.opaque_identity (check_memprof_cb ()))
       with exn ->
-             flush stdout; flush stderr;
-             thread_uncaught_exception exn)
+        let raw_backtrace = Printexc.get_raw_backtrace () in
+        flush stdout; flush stderr;
+        try
+          !uncaught_exception_handler exn
+        with exn' ->
+          Printf.eprintf
+            "Thread %d killed on uncaught exception %s\n"
+            (id (self ())) (Printexc.to_string exn);
+          Printexc.print_raw_backtrace stderr raw_backtrace;
+          Printf.eprintf
+            "Thread %d uncaught exception handler raised %s\n"
+            (id (self ())) (Printexc.to_string exn');
+          Printexc.print_backtrace stdout;
+          flush stderr)
 
 let exit () =
   ignore (Sys.opaque_identity (check_memprof_cb ()));

otherlibs/systhreads/thread.mli

@@ -145,3 +145,16 @@ val wait_signal : int list -> int
    Signal handlers attached to the signals in [sigs] will not
    be invoked.  The signals [sigs] are expected to be blocked before
    calling [wait_signal]. *)
+
+(** {1 Uncaught exceptions} *)
+
+val default_uncaught_exception_handler : exn -> unit
+(** [Thread.default_uncaught_exception_handler] will print the thread's id,
+    exception and backtrace (if available). *)
+
+val set_uncaught_exception_handler : (exn -> unit) -> unit
+(** [Thread.set_uncaught_exception_handler fn] registers [fn] as the handler
+    for uncaught exceptions.
+
+    If the newly set uncaught exception handler raise an exception,
+    {!default_uncaught_exception_handler} will be called. *)

testsuite/tests/backtrace/callstack.reference

@@ -12,4 +12,4 @@ Raised by primitive operation at Callstack.f0 in file "callstack.ml", line 11, c
 Called from Callstack.f1 in file "callstack.ml", line 12, characters 27-32
 Called from Callstack.f2 in file "callstack.ml", line 13, characters 27-32
 Called from Callstack.f3 in file "callstack.ml", line 14, characters 27-32
-Called from Thread.create.(fun) in file "thread.ml", line 41, characters 8-14
+Called from Thread.create.(fun) in file "thread.ml", line 47, characters 8-14

testsuite/tests/lib-threads/uncaught_exception_handler.ml

@@ -0,0 +1,37 @@
+(* TEST
+
+flags = "-g"
+ocamlrunparam += ",b=1"
+
+* hassysthreads
+include systhreads
+** bytecode
+** native
+
+*)
+
+(* Testing if uncaught exception handlers are behaving properly  *)
+
+let () = Printexc.record_backtrace true
+
+exception UncaughtHandlerExn
+exception CallbackExn
+
+let handler exn =
+  let id = Thread.self () |> Thread.id in
+  let msg = Printexc.to_string exn in
+  Printf.eprintf "[thread %d] caught %s\n" id msg;
+  Printexc.print_backtrace stderr;
+  flush stderr;
+  raise UncaughtHandlerExn
+
+let fn () = Printexc.raise_with_backtrace
+              CallbackExn
+              (Printexc.get_raw_backtrace ())
+
+let _ =
+  let th = Thread.create fn () in
+  Thread.join th;
+  Thread.set_uncaught_exception_handler handler;
+  let th = Thread.create fn () in
+  Thread.join th

testsuite/tests/lib-threads/uncaught_exception_handler.reference

@@ -0,0 +1,12 @@
+Thread 1 killed on uncaught exception Uncaught_exception_handler.CallbackExn
+Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113
+Called from Thread.create.(fun) in file "thread.ml", line 47, characters 8-14
+[thread 2] caught Uncaught_exception_handler.CallbackExn
+Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113
+Called from Thread.create.(fun) in file "thread.ml", line 47, characters 8-14
+Thread 2 killed on uncaught exception Uncaught_exception_handler.CallbackExn
+Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113
+Called from Thread.create.(fun) in file "thread.ml", line 47, characters 8-14
+Thread 2 uncaught exception handler raised Uncaught_exception_handler.UncaughtHandlerExn
+Raised at Uncaught_exception_handler.handler in file "uncaught_exception_handler.ml", line 26, characters 2-26
+Called from Thread.create.(fun) in file "thread.ml", line 53, characters 10-41