[llvm] r265897 - [OCaml] Expose the LLVM diagnostic handler
Jeroen Ketema via llvm-commits
llvm-commits at lists.llvm.org
Sun Apr 10 06:55:54 PDT 2016
Author: jketema
Date: Sun Apr 10 08:55:53 2016
New Revision: 265897
URL: http://llvm.org/viewvc/llvm-project?rev=265897&view=rev
Log:
[OCaml] Expose the LLVM diagnostic handler
Differential Revision: http://reviews.llvm.org/D18891
Added:
llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml
Modified:
llvm/trunk/bindings/ocaml/llvm/llvm.ml
llvm/trunk/bindings/ocaml/llvm/llvm.mli
llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c
llvm/trunk/test/Bindings/OCaml/bitreader.ml
llvm/trunk/test/Bindings/OCaml/ext_exc.ml
llvm/trunk/test/Bindings/OCaml/linker.ml
Modified: llvm/trunk/bindings/ocaml/llvm/llvm.ml
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/bindings/ocaml/llvm/llvm.ml?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/bindings/ocaml/llvm/llvm.ml (original)
+++ llvm/trunk/bindings/ocaml/llvm/llvm.ml Sun Apr 10 08:55:53 2016
@@ -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"
Modified: llvm/trunk/bindings/ocaml/llvm/llvm.mli
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/bindings/ocaml/llvm/llvm.mli?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/bindings/ocaml/llvm/llvm.mli (original)
+++ llvm/trunk/bindings/ocaml/llvm/llvm.mli Sun Apr 10 08:55:53 2016
@@ -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 ->
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
Modified: llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c (original)
+++ llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c Sun Apr 10 08:55:53 2016
@@ -115,6 +115,49 @@ static value alloc_variant(int tag, void
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_cont
/* llcontext -> unit */
CAMLprim value llvm_dispose_context(LLVMContextRef C) {
+ llvm_remove_diagnostic_handler(C);
LLVMContextDispose(C);
return Val_unit;
}
Modified: llvm/trunk/test/Bindings/OCaml/bitreader.ml
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/test/Bindings/OCaml/bitreader.ml?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/test/Bindings/OCaml/bitreader.ml (original)
+++ llvm/trunk/test/Bindings/OCaml/bitreader.ml Sun Apr 10 08:55:53 2016
@@ -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
Added: llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml?rev=265897&view=auto
==============================================================================
--- llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml (added)
+++ llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml Sun Apr 10 08:55:53 2016
@@ -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
Modified: llvm/trunk/test/Bindings/OCaml/ext_exc.ml
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/test/Bindings/OCaml/ext_exc.ml?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/test/Bindings/OCaml/ext_exc.ml (original)
+++ llvm/trunk/test/Bindings/OCaml/ext_exc.ml Sun Apr 10 08:55:53 2016
@@ -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
Modified: llvm/trunk/test/Bindings/OCaml/linker.ml
URL: http://llvm.org/viewvc/llvm-project/llvm/trunk/test/Bindings/OCaml/linker.ml?rev=265897&r1=265896&r2=265897&view=diff
==============================================================================
--- llvm/trunk/test/Bindings/OCaml/linker.ml (original)
+++ llvm/trunk/test/Bindings/OCaml/linker.ml Sun Apr 10 08:55:53 2016
@@ -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 =
More information about the llvm-commits
mailing list