daily pastebin goal
24%
SHARE
TWEET

Untitled

a guest Feb 16th, 2019 78 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. commit 966ab733ef7e3a4d587ca63d246ec7125bc8aff7
  2. Author: Jeremie Dimino <jdimino@janestreet.com>
  3. Date:   Tue Mar 12 09:26:48 2013 +0000
  4.  
  5.     allow the user to provide a handler for uncaught exceptions
  6.  
  7. diff --git a/byterun/printexc.c b/byterun/printexc.c
  8. index 7e3259a..c8204b8 100644
  9. --- a/byterun/printexc.c
  10. +++ b/byterun/printexc.c
  11. @@ -92,7 +92,14 @@ CAMLexport char * caml_format_exception(value exn)
  12.  }
  13.  
  14.  
  15. -void caml_fatal_uncaught_exception(value exn)
  16. +#ifdef NATIVE_CODE
  17. +#  define DEBUGGER_IN_USE 0
  18. +#else
  19. +#  define DEBUGGER_IN_USE caml_debugger_in_use
  20. +#endif
  21. +
  22. +/* Default C implementation in case the OCaml one is not registered. */
  23. +static void default_fatal_uncaught_exception(value exn)
  24.  {
  25.    char * msg;
  26.    value * at_exit;
  27. @@ -113,13 +120,20 @@ void caml_fatal_uncaught_exception(value exn)
  28.    fprintf(stderr, "Fatal error: exception %s\n", msg);
  29.    free(msg);
  30.    /* Display the backtrace if available */
  31. -  if (caml_backtrace_active
  32. -#ifndef NATIVE_CODE
  33. -      && !caml_debugger_in_use
  34. -#endif
  35. -      ) {
  36. +  if (caml_backtrace_active && !DEBUGGER_IN_USE)
  37.      caml_print_exception_backtrace();
  38. -  }
  39. +}
  40. +
  41. +void caml_fatal_uncaught_exception(value exn)
  42. +{
  43. +  value *handle_uncaught_exception;
  44. +
  45. +  handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception");
  46. +  if (handle_uncaught_exception != NULL)
  47. +    /* [Printexc.handle_uncaught_exception] does not raise exception. */
  48. +    caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
  49. +  else
  50. +    default_fatal_uncaught_exception(exn);
  51.    /* Terminate the process */
  52.    exit(2);
  53.  }
  54. diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
  55. index a36e2d4..4746319 100644
  56. --- a/stdlib/printexc.ml
  57. +++ b/stdlib/printexc.ml
  58. @@ -165,3 +165,60 @@ external backtrace_status: unit -> bool = "caml_backtrace_status"
  59.  
  60.  let register_printer fn =
  61.    printers := fn :: !printers
  62. +
  63. +let uncaught_exception_handler = ref None
  64. +
  65. +let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn
  66. +
  67. +let empty_backtrace : raw_backtrace = Obj.obj (Obj.new_block Obj.abstract_tag 0)
  68. +
  69. +let try_get_raw_backtrace () =
  70. +  try
  71. +    get_raw_backtrace ()
  72. +  with _ (* Out_of_memory? *) ->
  73. +    empty_backtrace
  74. +
  75. +let handle_uncaught_exception exn debugger_in_use =
  76. +  try
  77. +    (* Save the backtrace, in case one of the [at_exit] function destroys it. *)
  78. +    let raw_backtrace =
  79. +      if debugger_in_use then
  80. +        empty_backtrace
  81. +      else
  82. +        try_get_raw_backtrace ()
  83. +    in
  84. +    let status = backtrace_status () in
  85. +    record_backtrace false;
  86. +    (try Pervasives.do_at_exit () with _ -> ());
  87. +    match !uncaught_exception_handler with
  88. +    | None ->
  89. +        eprintf "Fatal error: exception %s\n" (to_string exn);
  90. +        print_raw_backtrace stderr raw_backtrace;
  91. +        flush stderr
  92. +    | Some handler ->
  93. +        try
  94. +          record_backtrace status;
  95. +          handler exn raw_backtrace
  96. +        with exn' ->
  97. +          let raw_backtrace' = try_get_raw_backtrace () in
  98. +          eprintf "Fatal error: exception %s\n" (to_string exn);
  99. +          print_raw_backtrace stderr raw_backtrace;
  100. +          eprintf "Fatal error in uncaught exception handler: exception %s\n"
  101. +            (to_string exn');
  102. +          print_raw_backtrace stderr raw_backtrace';
  103. +          flush stderr
  104. +  with
  105. +    | Out_of_memory ->
  106. +        (try
  107. +           prerr_endline
  108. +             "Fatal error: out of memory in uncaught exception handler"
  109. +         with _ -> ())
  110. +    | _ ->
  111. +        ()
  112. +
  113. +external register_named_value : string -> 'a -> unit
  114. +  = "caml_register_named_value"
  115. +
  116. +let () =
  117. +  register_named_value "Printexc.handle_uncaught_exception"
  118. +    handle_uncaught_exception
  119. diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
  120. index b653265..72b4003 100644
  121. --- a/stdlib/printexc.mli
  122. +++ b/stdlib/printexc.mli
  123. @@ -99,3 +99,12 @@ type raw_backtrace
  124.  val get_raw_backtrace: unit -> raw_backtrace
  125.  val print_raw_backtrace: out_channel -> raw_backtrace -> unit
  126.  val raw_backtrace_to_string: raw_backtrace -> string
  127. +
  128. +(** {6 Uncaught exceptions} *)
  129. +
  130. +val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
  131. +(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler for
  132. +    uncaught exceptions.  The default handler prints the exception and backtrace on
  133. +    standard error output.  Note that when [fn] is called all the functions registered
  134. +    with {!Pervasives.at_exit} have already been called.  If [fn] raises an exception, it
  135. +    is ignored. *)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top