[OCaml] Expose the LLVM diagnostic handler

Differential Revision: http://reviews.llvm.org/D18891

llvm-svn: 265897

bindings/ocaml/llvm/llvm.ml

@@ -283,6 +283,14 @@ module ValueKind = struct
   | Instruction of Opcode.t
 end
 
+module DiagnosticSeverity = struct
+  type t =
+  | Error
+  | Warning
+  | Remark
+  | Note
+end
+
 exception IoError of string
 
 let () = Callback.register_exception "Llvm.IoError" (IoError "")
@@ -304,6 +312,20 @@ type ('a, 'b) llrev_pos =
 | At_start of 'a
 | After of 'b
 
+
+(*===-- Context error handling --------------------------------------------===*)
+module Diagnostic = struct
+  type t
+
+  external description : t -> string = "llvm_get_diagnostic_description"
+  external severity : t -> DiagnosticSeverity.t
+                    = "llvm_get_diagnostic_severity"
+end
+
+external set_diagnostic_handler
+  : llcontext -> (Diagnostic.t -> unit) option -> unit
+  = "llvm_set_diagnostic_handler"
+
 (*===-- Contexts ----------------------------------------------------------===*)
 external create_context : unit -> llcontext = "llvm_create_context"
 external dispose_context : llcontext -> unit = "llvm_dispose_context"

bindings/ocaml/llvm/llvm.mli

@@ -15,7 +15,7 @@
 
 (** {6 Abstract types}
 
-    These abstract types correlate directly to the LLVM VMCore classes. *)
+    These abstract types correlate directly to the LLVMCore classes. *)
 
 (** The top-level container for all LLVM global data. See the
     [llvm::LLVMContext] class. *)
@@ -352,6 +352,16 @@ module ValueKind : sig
   | Instruction of Opcode.t
 end
 
+(** The kind of [Diagnostic], the result of [Diagnostic.severity d].
+    See [llvm::DiagnosticSeverity]. *)
+module DiagnosticSeverity : sig
+  type t =
+  | Error
+  | Warning
+  | Remark
+  | Note
+end
+
 
 (** {6 Iteration} *)
 
@@ -398,6 +408,22 @@ val reset_fatal_error_handler : unit -> unit
     See the function [llvm::cl::ParseCommandLineOptions()]. *)
 val parse_command_line_options : ?overview:string -> string array -> unit
 
+(** {6 Context error handling} *)
+
+module Diagnostic : sig
+  type t
+
+  (** [description d] returns a textual description of [d]. *)
+  val description : t -> string
+
+  (** [severity d] returns the severity of [d]. *)
+  val severity : t -> DiagnosticSeverity.t
+end
+
+(** [set_diagnostic_handler c h] set the diagnostic handler of [c] to [h].
+    See the method [llvm::LLVMContext::setDiagnosticHandler]. *)
+val set_diagnostic_handler : llcontext -> (Diagnostic.t -> unit) option -> unit
+
 (** {6 Contexts} *)
 
 (** [create_context ()] creates a context for storing the "global" state in

bindings/ocaml/llvm/llvm_ocaml.c

@@ -115,6 +115,49 @@ static value alloc_variant(int tag, void *Value) {
     return alloc_variant(0, pfun(Kid));                   \
   }
 
+/*===-- Context error handling --------------------------------------------===*/
+
+void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI,
+                                        void *DiagnosticContext) {
+  caml_callback(*((value *)DiagnosticContext), (value)DI);
+}
+
+/* Diagnostic.t -> string */
+CAMLprim value llvm_get_diagnostic_description(value Diagnostic) {
+  return llvm_string_of_message(
+      LLVMGetDiagInfoDescription((LLVMDiagnosticInfoRef)Diagnostic));
+}
+
+/* Diagnostic.t -> DiagnosticSeverity.t */
+CAMLprim value llvm_get_diagnostic_severity(value Diagnostic) {
+  return Val_int(LLVMGetDiagInfoSeverity((LLVMDiagnosticInfoRef)Diagnostic));
+}
+
+static void llvm_remove_diagnostic_handler(LLVMContextRef C) {
+  if (LLVMContextGetDiagnosticHandler(C) ==
+      llvm_diagnostic_handler_trampoline) {
+    value *Handler = (value *)LLVMContextGetDiagnosticContext(C);
+    remove_global_root(Handler);
+    free(Handler);
+  }
+}
+
+/* llcontext -> (Diagnostic.t -> unit) option -> unit */
+CAMLprim value llvm_set_diagnostic_handler(LLVMContextRef C, value Handler) {
+  llvm_remove_diagnostic_handler(C);
+  if (Handler == Val_int(0)) {
+    LLVMContextSetDiagnosticHandler(C, NULL, NULL);
+  } else {
+    value *DiagnosticContext = malloc(sizeof(value));
+    if (DiagnosticContext == NULL)
+      caml_raise_out_of_memory();
+    caml_register_global_root(DiagnosticContext);
+    *DiagnosticContext = Field(Handler, 0);
+    LLVMContextSetDiagnosticHandler(C, llvm_diagnostic_handler_trampoline,
+                                    DiagnosticContext);
+  }
+  return Val_unit;
+}
 
 /*===-- Contexts ----------------------------------------------------------===*/
 
@@ -125,6 +168,7 @@ CAMLprim LLVMContextRef llvm_create_context(value Unit) {
 
 /* llcontext -> unit */
 CAMLprim value llvm_dispose_context(LLVMContextRef C) {
+  llvm_remove_diagnostic_handler(C);
   LLVMContextDispose(C);
   return Val_unit;
 }

test/Bindings/OCaml/bitreader.ml

@@ -12,9 +12,13 @@
 
 let context = Llvm.global_context ()
 
+let diagnostic_handler _ = ()
+
 let test x = if not x then exit 1 else ()
 
 let _ =
+  Llvm.set_diagnostic_handler context (Some diagnostic_handler);
+
   let fn = Sys.argv.(1) in
   let m = Llvm.create_module context "ocaml_test_module" in
 

test/Bindings/OCaml/diagnostic_handler.ml

@@ -0,0 +1,48 @@
+(* RUN: cp %s %T/diagnostic_handler.ml
+ * RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
+ * RUN: %t %t.bc | FileCheck %s
+ * RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
+ * RUN: %t %t.bc | FileCheck %s
+ * XFAIL: vg_leak
+ *)
+
+let context = Llvm.global_context ()
+
+let diagnostic_handler d =
+  Printf.printf
+    "Diagnostic handler called: %s\n" (Llvm.Diagnostic.description d);
+  match Llvm.Diagnostic.severity d with
+  | Error -> Printf.printf "Diagnostic severity is Error\n"
+  | Warning -> Printf.printf "Diagnostic severity is Warning\n"
+  | Remark -> Printf.printf "Diagnostic severity is Remark\n"
+  | Note -> Printf.printf "Diagnostic severity is Note\n"
+
+let test x = if not x then exit 1 else ()
+
+let _ =
+  Llvm.set_diagnostic_handler context (Some diagnostic_handler);
+
+  (* corrupt the bitcode *)
+  let fn = Sys.argv.(1) ^ ".txt" in
+  begin let oc = open_out fn in
+    output_string oc "not a bitcode file\n";
+    close_out oc
+  end;
+
+  test begin
+    try
+      let mb = Llvm.MemoryBuffer.of_file fn in
+      let m = begin try
+        (* CHECK: Diagnostic handler called: Invalid bitcode signature
+         * CHECK: Diagnostic severity is Error
+         *)
+        Llvm_bitreader.get_module context mb
+      with x ->
+        Llvm.MemoryBuffer.dispose mb;
+        raise x
+      end in
+      Llvm.dispose_module m;
+      false
+    with Llvm_bitreader.Error _ ->
+      true
+  end

test/Bindings/OCaml/ext_exc.ml

@@ -8,9 +8,12 @@
 
 let context = Llvm.global_context ()
 
-(* this used to crash, we must not use 'external' in .mli files, but 'val' if we
+let diagnostic_handler _ = ()
+
+(* This used to crash, we must not use 'external' in .mli files, but 'val' if we
  * want the let _ bindings executed, see http://caml.inria.fr/mantis/view.php?id=4166 *)
 let _ =
+    Llvm.set_diagnostic_handler context (Some diagnostic_handler);
     try
         ignore (Llvm_bitreader.get_module context (Llvm.MemoryBuffer.of_stdin ()))
     with

test/Bindings/OCaml/linker.ml

@@ -16,6 +16,8 @@ open Llvm_linker
 let context = global_context ()
 let void_type = Llvm.void_type context
 
+let diagnostic_handler _ = ()
+
 (* Tiny unit test framework - really just to help find which line is busted *)
 let print_checkpoints = false
 
@@ -28,6 +30,8 @@ let suite name f =
 (*===-- Linker -----------------------------------------------------------===*)
 
 let test_linker () =
+  set_diagnostic_handler context (Some diagnostic_handler);
+
   let fty = function_type void_type [| |] in
 
   let make_module name =