From a69773cead6dea09ade34342eafacf848ec41367 Mon Sep 17 00:00:00 2001
From: Peter Zotov <whitequark@whitequark.org>
Date: Thu, 14 Nov 2013 06:34:13 +0000
Subject: [OCaml] Expose LLVM's fatal error and stacktrace APIs

git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@194669 91177308-0d34-0410-b5e6-96231b3b80d8
---
 bindings/ocaml/llvm/llvm.ml      |  7 +++++++
 bindings/ocaml/llvm/llvm.mli     | 15 +++++++++++++++
 bindings/ocaml/llvm/llvm_ocaml.c | 25 +++++++++++++++++++++++++
 3 files changed, 47 insertions(+)

(limited to 'bindings/ocaml')

diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml
index 780e305e2f..d36f360bf6 100644
--- a/bindings/ocaml/llvm/llvm.ml
+++ b/bindings/ocaml/llvm/llvm.ml
@@ -280,6 +280,13 @@ exception IoError of string
 external register_exns : exn -> unit = "llvm_register_core_exns"
 let _ = register_exns (IoError "")
 
+external install_fatal_error_handler : (string -> unit) -> unit
+                                     = "llvm_install_fatal_error_handler"
+external reset_fatal_error_handler : unit -> unit
+                                   = "llvm_reset_fatal_error_handler"
+external enable_pretty_stacktrace : unit -> unit
+                                  = "llvm_enable_pretty_stacktrace"
+
 type ('a, 'b) llpos =
 | At_end of 'a
 | Before of 'b
diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli
index e965b7ee7e..e996121793 100644
--- a/bindings/ocaml/llvm/llvm.mli
+++ b/bindings/ocaml/llvm/llvm.mli
@@ -361,6 +361,21 @@ type ('a, 'b) llrev_pos =
 exception IoError of string
 
 
+(** {6 Global configuration} *)
+
+(** [enable_pretty_stacktraces ()] enables LLVM's built-in stack trace code.
+    This intercepts the OS's crash signals and prints which component of LLVM
+    you were in at the time of the crash. *)
+val enable_pretty_stacktrace : unit -> unit
+
+(** [install_fatal_error_handler f] installs [f] as LLVM's fatal error handler.
+    The handler will receive the reason for termination as a string. After
+    the handler has been executed, LLVM calls [exit(1)]. *)
+val install_fatal_error_handler : (string -> unit) -> unit
+
+(** [reset_fatal_error_handler ()] resets LLVM's fatal error handler. *)
+val reset_fatal_error_handler : unit -> unit
+
 (** {6 Contexts} *)
 
 (** [create_context ()] creates a context for storing the "global" state in
diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c
index 387f6605e8..d5ebdcd3e3 100644
--- a/bindings/ocaml/llvm/llvm_ocaml.c
+++ b/bindings/ocaml/llvm/llvm_ocaml.c
@@ -33,6 +33,7 @@ static value llvm_ioerror_exn;
 CAMLprim value llvm_register_core_exns(value IoError) {
   llvm_ioerror_exn = Field(IoError, 0);
   register_global_root(&llvm_ioerror_exn);
+
   return Val_unit;
 }
 
@@ -50,6 +51,30 @@ static void llvm_raise(value Prototype, char *Message) {
 #endif
 }
 
+static value llvm_fatal_error_handler;
+
+static void llvm_fatal_error_trampoline(const char *Reason) {
+  callback(llvm_fatal_error_handler, copy_string(Reason));
+}
+
+CAMLprim value llvm_install_fatal_error_handler(value Handler) {
+  LLVMInstallFatalErrorHandler(llvm_fatal_error_trampoline);
+  llvm_fatal_error_handler = Handler;
+  caml_register_global_root(&llvm_fatal_error_handler);
+  return Val_unit;
+}
+
+CAMLprim value llvm_reset_fatal_error_handler(value Unit) {
+  caml_remove_global_root(&llvm_fatal_error_handler);
+  LLVMResetFatalErrorHandler();
+  return Val_unit;
+}
+
+CAMLprim value llvm_enable_pretty_stacktrace(value Unit) {
+  LLVMEnablePrettyStackTrace();
+  return Val_unit;
+}
+
 static value alloc_variant(int tag, void *Value) {
   value Iter = alloc_small(1, tag);
   Field(Iter, 0) = Val_op(Value);
-- 
cgit v1.2.3