From 562380a33117f78a1a7396ee1ede32aa1d84493d Mon Sep 17 00:00:00 2001 From: Jeroen Ketema Date: Sun, 10 Apr 2016 13:55:53 +0000 Subject: [PATCH] [OCaml] Expose the LLVM diagnostic handler Differential Revision: http://reviews.llvm.org/D18891 llvm-svn: 265897 --- llvm/bindings/ocaml/llvm/llvm.ml | 22 ++++++++++++ llvm/bindings/ocaml/llvm/llvm.mli | 28 ++++++++++++++- llvm/bindings/ocaml/llvm/llvm_ocaml.c | 44 +++++++++++++++++++++++ llvm/test/Bindings/OCaml/bitreader.ml | 4 +++ llvm/test/Bindings/OCaml/diagnostic_handler.ml | 48 ++++++++++++++++++++++++++ llvm/test/Bindings/OCaml/ext_exc.ml | 5 ++- llvm/test/Bindings/OCaml/linker.ml | 4 +++ 7 files changed, 153 insertions(+), 2 deletions(-) create mode 100644 llvm/test/Bindings/OCaml/diagnostic_handler.ml diff --git a/llvm/bindings/ocaml/llvm/llvm.ml b/llvm/bindings/ocaml/llvm/llvm.ml index 259d57b..5e149d4 100644 --- a/llvm/bindings/ocaml/llvm/llvm.ml +++ b/llvm/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" diff --git a/llvm/bindings/ocaml/llvm/llvm.mli b/llvm/bindings/ocaml/llvm/llvm.mli index 541c35a..5d3ce95 100644 --- a/llvm/bindings/ocaml/llvm/llvm.mli +++ b/llvm/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 diff --git a/llvm/bindings/ocaml/llvm/llvm_ocaml.c b/llvm/bindings/ocaml/llvm/llvm_ocaml.c index 925f3bd..665842d 100644 --- a/llvm/bindings/ocaml/llvm/llvm_ocaml.c +++ b/llvm/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; } diff --git a/llvm/test/Bindings/OCaml/bitreader.ml b/llvm/test/Bindings/OCaml/bitreader.ml index 3fda34a..87a165c 100644 --- a/llvm/test/Bindings/OCaml/bitreader.ml +++ b/llvm/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 diff --git a/llvm/test/Bindings/OCaml/diagnostic_handler.ml b/llvm/test/Bindings/OCaml/diagnostic_handler.ml new file mode 100644 index 0000000..a94ff22 --- /dev/null +++ b/llvm/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 diff --git a/llvm/test/Bindings/OCaml/ext_exc.ml b/llvm/test/Bindings/OCaml/ext_exc.ml index a24a28b..5c9c847 100644 --- a/llvm/test/Bindings/OCaml/ext_exc.ml +++ b/llvm/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 diff --git a/llvm/test/Bindings/OCaml/linker.ml b/llvm/test/Bindings/OCaml/linker.ml index 423905e..119ca4c 100644 --- a/llvm/test/Bindings/OCaml/linker.ml +++ b/llvm/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 = -- 2.7.4