Index: llvm/trunk/bindings/ocaml/llvm/llvm.ml =================================================================== --- llvm/trunk/bindings/ocaml/llvm/llvm.ml +++ llvm/trunk/bindings/ocaml/llvm/llvm.ml @@ -283,6 +283,14 @@ | 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 @@ | 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" Index: llvm/trunk/bindings/ocaml/llvm/llvm.mli =================================================================== --- llvm/trunk/bindings/ocaml/llvm/llvm.mli +++ llvm/trunk/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 @@ | 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 @@ 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 Index: llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c =================================================================== --- llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c +++ llvm/trunk/bindings/ocaml/llvm/llvm_ocaml.c @@ -115,6 +115,49 @@ 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 @@ /* llcontext -> unit */ CAMLprim value llvm_dispose_context(LLVMContextRef C) { + llvm_remove_diagnostic_handler(C); LLVMContextDispose(C); return Val_unit; } Index: llvm/trunk/test/Bindings/OCaml/bitreader.ml =================================================================== --- llvm/trunk/test/Bindings/OCaml/bitreader.ml +++ llvm/trunk/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 Index: llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml =================================================================== --- llvm/trunk/test/Bindings/OCaml/diagnostic_handler.ml +++ llvm/trunk/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 Index: llvm/trunk/test/Bindings/OCaml/ext_exc.ml =================================================================== --- llvm/trunk/test/Bindings/OCaml/ext_exc.ml +++ llvm/trunk/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 Index: llvm/trunk/test/Bindings/OCaml/linker.ml =================================================================== --- llvm/trunk/test/Bindings/OCaml/linker.ml +++ llvm/trunk/test/Bindings/OCaml/linker.ml @@ -16,6 +16,8 @@ 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 @@ (*===-- Linker -----------------------------------------------------------===*) let test_linker () = + set_diagnostic_handler context (Some diagnostic_handler); + let fty = function_type void_type [| |] in let make_module name =