llvm.org GIT mirror llvm / 8280149
[OCaml] Expose the LLVM diagnostic handler Differential Revision: http://reviews.llvm.org/D18891 git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@265897 91177308-0d34-0410-b5e6-96231b3b80d8 Jeroen Ketema 4 years ago
7 changed file(s) with 153 addition(s) and 2 deletion(s). Raw diff Collapse all Expand all
282282 | Instruction of Opcode.t
283283 end
284284
285 module DiagnosticSeverity = struct
286 type t =
287 | Error
288 | Warning
289 | Remark
290 | Note
291 end
292
285293 exception IoError of string
286294
287295 let () = Callback.register_exception "Llvm.IoError" (IoError "")
302310 type ('a, 'b) llrev_pos =
303311 | At_start of 'a
304312 | After of 'b
313
314
315 (*===-- Context error handling --------------------------------------------===*)
316 module Diagnostic = struct
317 type t
318
319 external description : t -> string = "llvm_get_diagnostic_description"
320 external severity : t -> DiagnosticSeverity.t
321 = "llvm_get_diagnostic_severity"
322 end
323
324 external set_diagnostic_handler
325 : llcontext -> (Diagnostic.t -> unit) option -> unit
326 = "llvm_set_diagnostic_handler"
305327
306328 (*===-- Contexts ----------------------------------------------------------===*)
307329 external create_context : unit -> llcontext = "llvm_create_context"
1414
1515 (** {6 Abstract types}
1616
17 These abstract types correlate directly to the LLVM VMCore classes. *)
17 These abstract types correlate directly to the LLVMCore classes. *)
1818
1919 (** The top-level container for all LLVM global data. See the
2020 [llvm::LLVMContext] class. *)
351351 | Instruction of Opcode.t
352352 end
353353
354 (** The kind of [Diagnostic], the result of [Diagnostic.severity d].
355 See [llvm::DiagnosticSeverity]. *)
356 module DiagnosticSeverity : sig
357 type t =
358 | Error
359 | Warning
360 | Remark
361 | Note
362 end
363
354364
355365 (** {6 Iteration} *)
356366
396406
397407 See the function [llvm::cl::ParseCommandLineOptions()]. *)
398408 val parse_command_line_options : ?overview:string -> string array -> unit
409
410 (** {6 Context error handling} *)
411
412 module Diagnostic : sig
413 type t
414
415 (** [description d] returns a textual description of [d]. *)
416 val description : t -> string
417
418 (** [severity d] returns the severity of [d]. *)
419 val severity : t -> DiagnosticSeverity.t
420 end
421
422 (** [set_diagnostic_handler c h] set the diagnostic handler of [c] to [h].
423 See the method [llvm::LLVMContext::setDiagnosticHandler]. *)
424 val set_diagnostic_handler : llcontext -> (Diagnostic.t -> unit) option -> unit
399425
400426 (** {6 Contexts} *)
401427
114114 return alloc_variant(0, pfun(Kid)); \
115115 }
116116
117 /*===-- Context error handling --------------------------------------------===*/
118
119 void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI,
120 void *DiagnosticContext) {
121 caml_callback(*((value *)DiagnosticContext), (value)DI);
122 }
123
124 /* Diagnostic.t -> string */
125 CAMLprim value llvm_get_diagnostic_description(value Diagnostic) {
126 return llvm_string_of_message(
127 LLVMGetDiagInfoDescription((LLVMDiagnosticInfoRef)Diagnostic));
128 }
129
130 /* Diagnostic.t -> DiagnosticSeverity.t */
131 CAMLprim value llvm_get_diagnostic_severity(value Diagnostic) {
132 return Val_int(LLVMGetDiagInfoSeverity((LLVMDiagnosticInfoRef)Diagnostic));
133 }
134
135 static void llvm_remove_diagnostic_handler(LLVMContextRef C) {
136 if (LLVMContextGetDiagnosticHandler(C) ==
137 llvm_diagnostic_handler_trampoline) {
138 value *Handler = (value *)LLVMContextGetDiagnosticContext(C);
139 remove_global_root(Handler);
140 free(Handler);
141 }
142 }
143
144 /* llcontext -> (Diagnostic.t -> unit) option -> unit */
145 CAMLprim value llvm_set_diagnostic_handler(LLVMContextRef C, value Handler) {
146 llvm_remove_diagnostic_handler(C);
147 if (Handler == Val_int(0)) {
148 LLVMContextSetDiagnosticHandler(C, NULL, NULL);
149 } else {
150 value *DiagnosticContext = malloc(sizeof(value));
151 if (DiagnosticContext == NULL)
152 caml_raise_out_of_memory();
153 caml_register_global_root(DiagnosticContext);
154 *DiagnosticContext = Field(Handler, 0);
155 LLVMContextSetDiagnosticHandler(C, llvm_diagnostic_handler_trampoline,
156 DiagnosticContext);
157 }
158 return Val_unit;
159 }
117160
118161 /*===-- Contexts ----------------------------------------------------------===*/
119162
124167
125168 /* llcontext -> unit */
126169 CAMLprim value llvm_dispose_context(LLVMContextRef C) {
170 llvm_remove_diagnostic_handler(C);
127171 LLVMContextDispose(C);
128172 return Val_unit;
129173 }
1111
1212 let context = Llvm.global_context ()
1313
14 let diagnostic_handler _ = ()
15
1416 let test x = if not x then exit 1 else ()
1517
1618 let _ =
19 Llvm.set_diagnostic_handler context (Some diagnostic_handler);
20
1721 let fn = Sys.argv.(1) in
1822 let m = Llvm.create_module context "ocaml_test_module" in
1923
0 (* RUN: cp %s %T/diagnostic_handler.ml
1 * RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
2 * RUN: %t %t.bc | FileCheck %s
3 * RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
4 * RUN: %t %t.bc | FileCheck %s
5 * XFAIL: vg_leak
6 *)
7
8 let context = Llvm.global_context ()
9
10 let diagnostic_handler d =
11 Printf.printf
12 "Diagnostic handler called: %s\n" (Llvm.Diagnostic.description d);
13 match Llvm.Diagnostic.severity d with
14 | Error -> Printf.printf "Diagnostic severity is Error\n"
15 | Warning -> Printf.printf "Diagnostic severity is Warning\n"
16 | Remark -> Printf.printf "Diagnostic severity is Remark\n"
17 | Note -> Printf.printf "Diagnostic severity is Note\n"
18
19 let test x = if not x then exit 1 else ()
20
21 let _ =
22 Llvm.set_diagnostic_handler context (Some diagnostic_handler);
23
24 (* corrupt the bitcode *)
25 let fn = Sys.argv.(1) ^ ".txt" in
26 begin let oc = open_out fn in
27 output_string oc "not a bitcode file\n";
28 close_out oc
29 end;
30
31 test begin
32 try
33 let mb = Llvm.MemoryBuffer.of_file fn in
34 let m = begin try
35 (* CHECK: Diagnostic handler called: Invalid bitcode signature
36 * CHECK: Diagnostic severity is Error
37 *)
38 Llvm_bitreader.get_module context mb
39 with x ->
40 Llvm.MemoryBuffer.dispose mb;
41 raise x
42 end in
43 Llvm.dispose_module m;
44 false
45 with Llvm_bitreader.Error _ ->
46 true
47 end
77
88 let context = Llvm.global_context ()
99
10 (* this used to crash, we must not use 'external' in .mli files, but 'val' if we
10 let diagnostic_handler _ = ()
11
12 (* This used to crash, we must not use 'external' in .mli files, but 'val' if we
1113 * want the let _ bindings executed, see http://caml.inria.fr/mantis/view.php?id=4166 *)
1214 let _ =
15 Llvm.set_diagnostic_handler context (Some diagnostic_handler);
1316 try
1417 ignore (Llvm_bitreader.get_module context (Llvm.MemoryBuffer.of_stdin ()))
1518 with
1515 let context = global_context ()
1616 let void_type = Llvm.void_type context
1717
18 let diagnostic_handler _ = ()
19
1820 (* Tiny unit test framework - really just to help find which line is busted *)
1921 let print_checkpoints = false
2022
2729 (*===-- Linker -----------------------------------------------------------===*)
2830
2931 let test_linker () =
32 set_diagnostic_handler context (Some diagnostic_handler);
33
3034 let fty = function_type void_type [| |] in
3135
3236 let make_module name =