commit 966ab733ef7e3a4d587ca63d246ec7125bc8aff7
Author: Jeremie Dimino <jdimino@janestreet.com>
Date:   Tue Mar 12 09:26:48 2013 +0000

    allow the user to provide a handler for uncaught exceptions

diff --git a/byterun/printexc.c b/byterun/printexc.c
index 7e3259a..c8204b8 100644
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -92,7 +92,14 @@ CAMLexport char * caml_format_exception(value exn)
 }


-void caml_fatal_uncaught_exception(value exn)
+#ifdef NATIVE_CODE
+#  define DEBUGGER_IN_USE 0
+#else
+#  define DEBUGGER_IN_USE caml_debugger_in_use
+#endif
+
+/* Default C implementation in case the OCaml one is not registered. */
+static void default_fatal_uncaught_exception(value exn)
 {
   char * msg;
   value * at_exit;
@@ -113,13 +120,20 @@ void caml_fatal_uncaught_exception(value exn)
   fprintf(stderr, "Fatal error: exception %s\n", msg);
   free(msg);
   /* Display the backtrace if available */
-  if (caml_backtrace_active
-#ifndef NATIVE_CODE
-      && !caml_debugger_in_use
-#endif
-      ) {
+  if (caml_backtrace_active && !DEBUGGER_IN_USE)
     caml_print_exception_backtrace();
-  }
+}
+
+void caml_fatal_uncaught_exception(value exn)
+{
+  value *handle_uncaught_exception;
+
+  handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception");
+  if (handle_uncaught_exception != NULL)
+    /* [Printexc.handle_uncaught_exception] does not raise exception. */
+    caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
+  else
+    default_fatal_uncaught_exception(exn);
   /* Terminate the process */
   exit(2);
 }
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index a36e2d4..4746319 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -165,3 +165,60 @@ external backtrace_status: unit -> bool = "caml_backtrace_status"

 let register_printer fn =
   printers := fn :: !printers
+
+let uncaught_exception_handler = ref None
+
+let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn
+
+let empty_backtrace : raw_backtrace = Obj.obj (Obj.new_block Obj.abstract_tag 0)
+
+let try_get_raw_backtrace () =
+  try
+    get_raw_backtrace ()
+  with _ (* Out_of_memory? *) ->
+    empty_backtrace
+
+let handle_uncaught_exception exn debugger_in_use =
+  try
+    (* Save the backtrace, in case one of the [at_exit] function destroys it. *)
+    let raw_backtrace =
+      if debugger_in_use then
+        empty_backtrace
+      else
+        try_get_raw_backtrace ()
+    in
+    let status = backtrace_status () in
+    record_backtrace false;
+    (try Pervasives.do_at_exit () with _ -> ());
+    match !uncaught_exception_handler with
+    | None ->
+        eprintf "Fatal error: exception %s\n" (to_string exn);
+        print_raw_backtrace stderr raw_backtrace;
+        flush stderr
+    | Some handler ->
+        try
+          record_backtrace status;
+          handler exn raw_backtrace
+        with exn' ->
+          let raw_backtrace' = try_get_raw_backtrace () in
+          eprintf "Fatal error: exception %s\n" (to_string exn);
+          print_raw_backtrace stderr raw_backtrace;
+          eprintf "Fatal error in uncaught exception handler: exception %s\n"
+            (to_string exn');
+          print_raw_backtrace stderr raw_backtrace';
+          flush stderr
+  with
+    | Out_of_memory ->
+        (try
+           prerr_endline
+             "Fatal error: out of memory in uncaught exception handler"
+         with _ -> ())
+    | _ ->
+        ()
+
+external register_named_value : string -> 'a -> unit
+  = "caml_register_named_value"
+
+let () =
+  register_named_value "Printexc.handle_uncaught_exception"
+    handle_uncaught_exception
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index b653265..72b4003 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -99,3 +99,12 @@ type raw_backtrace
 val get_raw_backtrace: unit -> raw_backtrace
 val print_raw_backtrace: out_channel -> raw_backtrace -> unit
 val raw_backtrace_to_string: raw_backtrace -> string
+
+(** {6 Uncaught exceptions} *)
+
+val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
+(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler for
+    uncaught exceptions.  The default handler prints the exception and backtrace on
+    standard error output.  Note that when [fn] is called all the functions registered
+    with {!Pervasives.at_exit} have already been called.  If [fn] raises an exception, it
+    is ignored. *)