[OCaml] Expose the LLVM diagnostic handler

[jketema]

Summary

This might need some iteration and more than the accidental test cases it has now, but I'd like to know if I'm on the right path.

[whitequark]

bindings/ocaml/llvm/llvm.ml

320

Just description and severity.

bindings/ocaml/llvm/llvm.mli

427

There is no need to have an 'a here since OCaml already has closures; the context argument in C is closure emulation in essence.

430

Accept an option in set_diagnostic_handler instead of using two functions.

bindings/ocaml/llvm/llvm_ocaml.c

187

There is caml_raise_out_of_memory and I think we should use it.

test/Bindings/OCaml/linker.ml

21

Is this (and elsewhere in test/) actually used in tests?

[jketema]

Thanks for the feedback so far!

bindings/ocaml/llvm/llvm.mli

427

I had that originally, just wasn't quite sure whether that was desired in this case. I'll remove the 'a

bindings/ocaml/llvm/llvm_ocaml.c

187

I looked for something like that but couldn't find it. Thanks for the pointer.

test/Bindings/OCaml/linker.ml

21

It's used in the sense that currently the test crashes, because it tries to read invalid bitcode but no handler is installed. Having diagnostic handlers actually fixes the tests updated in this patch.

It's not used in the sense that there's no FileCheck for the printed text. I could make the handler just be empty instead?

[whitequark]

test/Bindings/OCaml/linker.ml

21

Why not add the check?

[jketema]

Updated patch based on @whitequark 's feedback. I've also added a separate test to test the diagnostic handler functionality.

[whitequark]

bindings/ocaml/llvm/llvm.ml

317

Just module Diagnostic, I think.

bindings/ocaml/llvm/llvm_ocaml.c

135

You don't need all this ceremony. LLVMDiagnosticInfoRef is a void* and so is a value and OCaml's runtime is defined to not do anything special with pointers that it doesn't control. So just cast LLVMDiagnosticInfoRef to value.

178

I would merge these two functions into just llvm_set_diagnostic_handler; there are a few examples of how to handle incoming option values in this codebase.

test/Bindings/OCaml/diagnostic_handler.ml

32

No check for the proper message and severity? This can hide a bug where the severity or message are mishandled.

[jketema]

Addressed new comments.

[whitequark]

LGTM, thanks!

[jketema]

Thanks for reviewing. Note that this doesn't re-enable the binding tests, as one test is still broken after these fixes: the core.ml test tries to build old-style debug information, and the new style is not even exposed in llvm-c. Maybe that part of core.ml should be disabled (or even removed?).

[whitequark]

Yes, please remove those parts and re-enable the tests.

bindings/ocaml/llvm/llvm.ml

module ValueKind = struct
   | ConstantVector
   | Function
   | GlobalAlias
   | GlobalVariable
   | UndefValue
   | 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 "")
 
 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"
 external parse_command_line_options : ?overview:string -> string array -> unit
                                     = "llvm_parse_command_line_options"
 
 type ('a, 'b) llpos =
 | At_end of 'a
 | Before of 'b
 
 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"
 external global_context : unit -> llcontext = "llvm_global_context"
 external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
 
 (*===-- Modules -----------------------------------------------------------===*)
 external create_module : llcontext -> string -> llmodule = "llvm_create_module"

bindings/ocaml/llvm/llvm.mli

 (** Core API.
 
     This interface provides an OCaml API for the LLVM intermediate
     representation, the classes in the VMCore library. *)
 
 
 (** {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. *)
 type llcontext
 
 (** The top-level container for all other LLVM Intermediate Representation (IR)
     objects. See the [llvm::Module] class. *)
 type llmodule
module ValueKind : sig
   | ConstantVector
   | Function
   | GlobalAlias
   | GlobalVariable
   | UndefValue
   | Instruction of Opcode.t
 end
 
+(** The kind of [Diagnostic], the result of [Diagnostic.severity di].
+    See [llvm::DiagnosticSeverity]. *)
+module DiagnosticSeverity : sig
+  type t =
+  | Error
+  | Warning
+  | Remark
+  | Note
+end
+
 
 (** {6 Iteration} *)
 
 (** [Before b] and [At_end a] specify positions from the start of the ['b] list
     of [a]. [llpos] is used to specify positions in and for forward iteration
     through the various value lists maintained by the LLVM IR. *)
 type ('a, 'b) llpos =
 | At_end of 'a

 (** [parse_command_line_options ?overview args] parses [args] using
     the LLVM command line parser. Note that the only stable thing about this
     function is its signature; you cannot rely on any particular set of command
     line arguments being interpreted the same way across LLVM versions.
 
     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 di] returns a textual description of [di]. *)
+  val description : t -> string
+
+  (** [severity di] returns the severity of [di]. *)
+  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
     LLVM. See the constructor [llvm::LLVMContext]. *)
 val create_context : unit -> llcontext
 
 (** [destroy_context ()] destroys a context. See the destructor
     [llvm::LLVMContext::~LLVMContext]. *)
 val dispose_context : llcontext -> unit
 
 (** See the function [llvm::getGlobalContext]. *)
 val global_context : unit -> llcontext

bindings/ocaml/llvm/llvm_ocaml.c

#define DEFINE_ITERATORS(camlname, cname, pty, cty, pfun) \
   /* llvalue -> ('a, 'b) llrev_pos */                     \
   CAMLprim value llvm_##camlname##_pred(cty Kid) {        \
     cty Prev = LLVMGetPrevious##cname(Kid);               \
     if (Prev)                                             \
       return alloc_variant(1, Prev);                      \
     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 ----------------------------------------------------------===*/
 
 /* unit -> llcontext */
 CAMLprim LLVMContextRef llvm_create_context(value Unit) {
   return LLVMContextCreate();
 }
 
 /* llcontext -> unit */
 CAMLprim value llvm_dispose_context(LLVMContextRef C) {
+  llvm_remove_diagnostic_handler(C);
   LLVMContextDispose(C);
   return Val_unit;
 }
 
 /* unit -> llcontext */
 CAMLprim LLVMContextRef llvm_global_context(value Unit) {
   return LLVMGetGlobalContext();
 }
 
 /* llcontext -> string -> int */
 CAMLprim value llvm_mdkind_id(LLVMContextRef C, value Name) {
   unsigned MDKindID = LLVMGetMDKindIDInContext(C, String_val(Name),
                                                caml_string_length(Name));
   return Val_int(MDKindID);
 }
 
 /*===-- Modules -----------------------------------------------------------===*/
 
 /* llcontext -> string -> llmodule */
 CAMLprim LLVMModuleRef llvm_create_module(LLVMContextRef C, value ModuleID) {
   return LLVMModuleCreateWithNameInContext(String_val(ModuleID), C);
 }
 
 /* llmodule -> unit */

test/Bindings/OCaml/bitreader.ml

 (* RUN: cp %s %T/bitreader.ml
  * RUN: %ocamlc -g -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %T/bitreader.ml -o %t
  * RUN: %t %t.bc
  * RUN: %ocamlopt -g -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %T/bitreader.ml -o %t
  * RUN: %t %t.bc
  * RUN: llvm-dis < %t.bc
  * XFAIL: vg_leak
  *)
 
 (* Note that this takes a moment to link, so it's best to keep the number of
    individual tests low. *)
 
 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 (Llvm_bitwriter.write_bitcode_file m fn);
 
   Llvm.dispose_module m;
 
   (* parse_bitcode *)

test/Bindings/OCaml/diagnostic_handler.ml

+(* 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

 (* RUN: cp %s %T/ext_exc.ml
  * RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %T/ext_exc.ml -o %t
  * RUN: %t
  * RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %T/ext_exc.ml -o %t
  * RUN: %t
  * XFAIL: vg_leak
  *)
 
 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
     Llvm_bitreader.Error _ -> ();;
 let _ =
     try
         ignore (Llvm.MemoryBuffer.of_file "/path/to/nonexistent/file")
     with
     Llvm.IoError _ -> ();;

test/Bindings/OCaml/linker.ml

(* Note: It takes several seconds for ocamlopt to link an executable with
          little ones. *)
 
 open Llvm
 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
 
 let suite name f =
   if print_checkpoints then
     prerr_endline (name ^ ":");
   f ()
 
 
 (*===-- Linker -----------------------------------------------------------===*)
 
 let test_linker () =
+  set_diagnostic_handler context (Some diagnostic_handler);
+
   let fty = function_type void_type [| |] in
 
   let make_module name =
     let m = create_module context name in
     let fn = define_function ("fn_" ^ name) fty m in
     ignore (build_ret_void (builder_at_end context (entry_block fn)));
     m
   in