[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

324

Just description and severity.

bindings/ocaml/llvm/llvm.mli

428

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

431

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

428

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

321

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

31 ↗

(On Diff #53171)

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 "")
 
+exception MemoryError of string
+
+let () = Callback.register_exception "Llvm.MemoryError" (MemoryError "")
+
 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 DiagnosticInfo = struct
+  type t
+
+  external get_description : t -> string = "llvm_get_diagnostic_description"
+  external get_severity : t -> DiagnosticSeverity.t
+                        = "llvm_get_diagnostic_severity"
+end
+
+external set_diagnostic_handler
+  : llcontext -> (DiagnosticInfo.t -> 'a -> unit) -> 'a -> unit
+  = "llvm_set_diagnostic_handler"
+external unset_diagnostic_handler : llcontext -> unit
+                                  = "llvm_unset_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 [DiagnosticInfo], the result of [get_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
 | Before of 'b
 
 (** [After b] and [At_start a] specify positions from the end of the ['b] list
     of [a]. [llrev_pos] is used for reverse iteration through the various value
     lists maintained by the LLVM IR. *)
 type ('a, 'b) llrev_pos =
 | At_start of 'a
 | After of 'b
 
 
 (** {6 Exceptions} *)
 
 exception IoError of string
 
+exception MemoryError 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
 
 (** [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 DiagnosticInfo : sig
+  type t
+
+  (** [get_description di] returns a textual description of [di]. *)
+  val get_description : t -> string
+
+  (** [get_severity di] returns the severity of [di]. *)
+  val get_severity : t -> DiagnosticSeverity.t
+end
+
+(** [set_diagnostic_handler c h dc] set the diagnostic handler of [c] to [h],
+    and set the diagnostic context to [dc].
+    See the method [llvm::LLVMContext::setDiagnosticHandler]. *)
+val set_diagnostic_handler
+  : llcontext -> (DiagnosticInfo.t -> 'a -> unit) -> 'a -> unit
+
+(** [unset_diagnostic_handler c] unsets the diagnostic handler of [c]. *)
+val unset_diagnostic_handler : llcontext -> 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]. *)

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 --------------------------------------------===*/
+
+#define DiagnosticInfo_val(v)  (*(LLVMDiagnosticInfoRef *)(Data_custom_val(v)))
+
+static struct custom_operations llvm_diagnostic_info_ops = {
+  (char *) "Llvm.DiagnosticInfo.t",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+value llvm_alloc_diagnostic_info(LLVMDiagnosticInfoRef DI) {
+  value V = alloc_custom(&llvm_diagnostic_info_ops,
+                         sizeof(LLVMDiagnosticInfoRef), 0, 1);
+  DiagnosticInfo_val(V) = DI;
+  return V;
+}
+
+typedef struct {
+  value Handler;
+  value Context;
+} diagnostic_context_wrapper;
+
+void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI,
+                                        void *DiagnosticContext) {
+  CAMLparam0();
+  CAMLlocal1(di);
+
+  diagnostic_context_wrapper *wrapper =
+      (diagnostic_context_wrapper *)DiagnosticContext;
+  di = llvm_alloc_diagnostic_info(DI);
+
+  caml_callback2(wrapper->Handler, di, wrapper->Context);
+
+  CAMLreturn0;
+}
+
+/* DiagnosticInfo.t -> string */
+CAMLprim value llvm_get_diagnostic_description(value DiagnosticInfo) {
+  return llvm_string_of_message(
+      LLVMGetDiagInfoDescription(DiagnosticInfo_val(DiagnosticInfo)));
+}
+
+/* DiagnosticInfo.t -> DiagnosticSeverity.t */
+CAMLprim value llvm_get_diagnostic_severity(value DiagnosticInfo) {
+  return Val_int(LLVMGetDiagInfoSeverity(DiagnosticInfo_val(DiagnosticInfo)));
+}
+
+static void llvm_remove_diagnostic_handler(LLVMContextRef C) {
+  if (LLVMContextGetDiagnosticHandler(C) ==
+      llvm_diagnostic_handler_trampoline) {
+    diagnostic_context_wrapper *wrapper =
+        (diagnostic_context_wrapper *)LLVMContextGetDiagnosticContext(C);
+    remove_global_root(&wrapper->Handler);
+    remove_global_root(&wrapper->Context);
+    free(wrapper);
+  }
+}
+
+/* llcontext -> (DiagnosticInfo.t -> 'a -> unit) -> 'a -> unit */
+CAMLprim value llvm_set_diagnostic_handler(LLVMContextRef C, value Handler,
+                                           value Context) {
+  llvm_remove_diagnostic_handler(C);
+  diagnostic_context_wrapper *wrapper =
+      malloc(sizeof(diagnostic_context_wrapper));
+  if (wrapper == NULL) {
+    llvm_raise(*caml_named_value("Llvm.MemoryError"),
+               LLVMCreateMessage(
+                   "Could not allocate memory for setting diagnostic handler"));
+  }
+  caml_register_global_root(&wrapper->Handler);
+  wrapper->Handler = Handler;
+  caml_register_global_root(&wrapper->Context);
+  wrapper->Context = Context;
+  LLVMContextSetDiagnosticHandler(C, llvm_diagnostic_handler_trampoline,
+                                  wrapper);
+  return Val_unit;
+}
+
+/* llcontext -> unit */
+CAMLprim value llvm_unset_diagnostic_handler(LLVMContextRef C) {
+  llvm_remove_diagnostic_handler(C);
+  LLVMContextSetDiagnosticHandler(C, NULL, NULL);
+  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();
 }

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 di _ =
+  Printf.printf
+    "Diagnostic handler called: %s\n" (Llvm.DiagnosticInfo.get_description di)
+
 let test x = if not x then exit 1 else ()
 
 let _ =
+  Llvm.set_diagnostic_handler context 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/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 di _ =
+  Printf.printf
+    "Diagnostic handler called: %s\n" (Llvm.DiagnosticInfo.get_description di)
+
+(* 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 diagnostic_handler ();
     try
         ignore (Llvm_bitreader.get_module context (Llvm.MemoryBuffer.of_stdin ()))
     with
     Llvm_bitreader.Error _ -> ();;
 let _ =
+    Llvm.set_diagnostic_handler context diagnostic_handler ();
     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 di _ =
+  Printf.printf
+    "Diagnostic handler called: %s\n" (Llvm.DiagnosticInfo.get_description di)
+
 (* 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 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