[OCaml][DebugInfo] Add tests for debug info API

In the process of adding the tests, several bugs were
found in the implementation and interface of the API
and they were fixed.

Some utilities from the core tests (core.ml) were moved
into a separate file for reuse.

The following new functions have been added:
`dibuild_create_global_variable_expression`,
`dibuild_create_constant_value_expression` and
`llmetadata_null`. The third one already existed but
is now exposed publicly.

Differential Revision: https://reviews.llvm.org/D99403
This commit is contained in:
Vaivaswatha Nagaraj 2021-03-26 22:06:48 +05:30
parent 64d851e46c
commit 3a5a816a59
8 changed files with 553 additions and 60 deletions

View File

@ -845,7 +845,7 @@ CAMLprim value llvm_set_subprogram(LLVMValueRef Func, LLVMMetadataRef SP) {
}
CAMLprim value llvm_di_subprogram_get_line(LLVMMetadataRef Subprogram) {
return Int_val(LLVMDISubprogramGetLine(Subprogram));
return Val_int(LLVMDISubprogramGetLine(Subprogram));
}
CAMLprim value llvm_instr_get_debug_loc(LLVMValueRef Inst) {
@ -858,6 +858,40 @@ CAMLprim value llvm_instr_set_debug_loc(LLVMValueRef Inst,
return Val_unit;
}
CAMLprim LLVMMetadataRef
llvm_dibuild_create_constant_value_expression(value Builder, value Value) {
return LLVMDIBuilderCreateConstantValueExpression(DIBuilder_val(Builder),
(int64_t)Int_val(Value));
}
CAMLprim LLVMMetadataRef llvm_dibuild_create_global_variable_expression_native(
value Builder, LLVMMetadataRef Scope, value Name, value Linkage,
LLVMMetadataRef File, value Line, LLVMMetadataRef Ty, value LocalToUnit,
LLVMMetadataRef Expr, LLVMMetadataRef Decl, value AlignInBits) {
return LLVMDIBuilderCreateGlobalVariableExpression(
DIBuilder_val(Builder), Scope, String_val(Name), caml_string_length(Name),
String_val(Linkage), caml_string_length(Linkage), File, Int_val(Line), Ty,
Bool_val(LocalToUnit), Expr, Decl, Int_val(AlignInBits));
}
CAMLprim LLVMMetadataRef
llvm_dibuild_create_global_variable_expression_bytecode(value *argv, int arg) {
return llvm_dibuild_create_global_variable_expression_native(
argv[0], // Builder
(LLVMMetadataRef)argv[1], // Scope
argv[2], // Name
argv[3], // Linkage
(LLVMMetadataRef)argv[4], // File
argv[5], // Line
(LLVMMetadataRef)argv[6], // Ty
argv[7], // LocalToUnit
(LLVMMetadataRef)argv[8], // Expr
(LLVMMetadataRef)argv[9], // Decl
argv[10] // AlignInBits
);
}
CAMLprim value
llvm_di_global_variable_expression_get_variable(LLVMMetadataRef GVE) {
return (ptr_to_option(LLVMDIGlobalVariableExpressionGetVariable(GVE)));

View File

@ -192,7 +192,7 @@ external dibuild_create_namespace :
lldibuilder ->
parent_ref:Llvm.llmetadata ->
name:string ->
bool:string ->
export_symbols:bool ->
Llvm.llmetadata = "llvm_dibuild_create_namespace"
external dibuild_create_function :
@ -228,9 +228,6 @@ external dibuild_create_debug_location_helper :
Llvm.llmetadata = "llvm_dibuild_create_debug_location"
external llmetadata_null : unit -> Llvm.llmetadata = "llvm_metadata_null"
(** [llmetadata_null ()] llmetadata is a wrapper around "llvm::Metadata *".
This function returns a nullptr valued llmetadata. For example,
it can be useful to pass NULL to LLVMInstructionSetDebugLoc. *)
let dibuild_create_debug_location ?(inlined_at = llmetadata_null ()) llctx ~line
~column ~scope =
@ -287,7 +284,7 @@ external dibuild_create_enumeration_type :
elements:Llvm.llmetadata array ->
class_ty:Llvm.llmetadata ->
Llvm.llmetadata
= "llvm_dibuild_create_enumeration_type_native" "llvm_dibuild_create_enumeration_type_bytecode"
= "llvm_dibuild_create_enumeration_type_bytecode" "llvm_dibuild_create_enumeration_type_native"
external dibuild_create_union_type :
lldibuilder ->
@ -302,7 +299,7 @@ external dibuild_create_union_type :
run_time_language:int ->
unique_id:string ->
Llvm.llmetadata
= "llvm_dibuild_create_union_type_native" "llvm_dibuild_create_union_type_bytecode"
= "llvm_dibuild_create_union_type_bytecode" "llvm_dibuild_create_union_type_native"
external dibuild_create_array_type :
lldibuilder ->
@ -340,7 +337,7 @@ external dibuild_create_pointer_type :
address_space:int ->
name:string ->
Llvm.llmetadata
= "llvm_dibuild_create_pointer_type_native" "llvm_dibuild_create_pointer_type_bytecode"
= "llvm_dibuild_create_pointer_type_bytecode" "llvm_dibuild_create_pointer_type_native"
external dibuild_create_struct_type :
lldibuilder ->
@ -353,11 +350,11 @@ external dibuild_create_struct_type :
lldiflags ->
derived_from:Llvm.llmetadata ->
elements:Llvm.llmetadata array ->
run_time_lang:int ->
DWARFSourceLanguageKind.t ->
vtable_holder:Llvm.llmetadata ->
unique_id:string ->
Llvm.llmetadata
= "llvm_dibuild_create_struct_type_native" "llvm_dibuild_create_struct_type_bytecode"
= "llvm_dibuild_create_struct_type_bytecode" "llvm_dibuild_create_struct_type_native"
external dibuild_create_member_type :
lldibuilder ->
@ -371,7 +368,7 @@ external dibuild_create_member_type :
lldiflags ->
ty:Llvm.llmetadata ->
Llvm.llmetadata
= "llvm_dibuild_create_member_type_native" "llvm_dibuild_create_member_type_bytecode"
= "llvm_dibuild_create_member_type_bytecode" "llvm_dibuild_create_member_type_native"
external dibuild_create_static_member_type :
lldibuilder ->
@ -384,7 +381,7 @@ external dibuild_create_static_member_type :
const_val:Llvm.llvalue ->
align_in_bits:int ->
Llvm.llmetadata
= "llvm_dibuild_create_static_member_type_native" "llvm_dibuild_create_static_member_type_bytecode"
= "llvm_dibuild_create_static_member_type_bytecode" "llvm_dibuild_create_static_member_type_native"
external dibuild_create_member_pointer_type :
lldibuilder ->
@ -394,7 +391,7 @@ external dibuild_create_member_pointer_type :
align_in_bits:int ->
lldiflags ->
Llvm.llmetadata
= "llvm_dibuild_create_member_pointer_type_native" "llvm_dibuild_create_member_pointer_type_bytecode"
= "llvm_dibuild_create_member_pointer_type_bytecode" "llvm_dibuild_create_member_pointer_type_native"
external dibuild_create_object_pointer_type :
lldibuilder -> Llvm.llmetadata -> Llvm.llmetadata
@ -420,9 +417,9 @@ external dibuild_create_typedef :
scope:Llvm.llmetadata ->
align_in_bits:int ->
Llvm.llmetadata
= "llvm_dibuild_create_typedef_native" "llvm_dibuild_create_typedef_bytecode"
= "llvm_dibuild_create_typedef_bytecode" "llvm_dibuild_create_typedef_native"
external dibuild_create_inheritance_native :
external dibuild_create_inheritance :
lldibuilder ->
ty:Llvm.llmetadata ->
base_ty:Llvm.llmetadata ->
@ -430,7 +427,7 @@ external dibuild_create_inheritance_native :
vb_ptr_offset:int ->
lldiflags ->
Llvm.llmetadata
= "llvm_dibuild_create_inheritance_native" "llvm_dibuild_create_inheritance_bytecode"
= "llvm_dibuild_create_inheritance_bytecode" "llvm_dibuild_create_inheritance_native"
external dibuild_create_forward_decl :
lldibuilder ->
@ -444,7 +441,7 @@ external dibuild_create_forward_decl :
align_in_bits:int ->
unique_identifier:string ->
Llvm.llmetadata
= "llvm_dibuild_create_forward_decl_native" "llvm_dibuild_create_forward_decl_bytecode"
= "llvm_dibuild_create_forward_decl_bytecode" "llvm_dibuild_create_forward_decl_native"
external dibuild_create_replaceable_composite_type :
lldibuilder ->
@ -459,7 +456,7 @@ external dibuild_create_replaceable_composite_type :
lldiflags ->
unique_identifier:string ->
Llvm.llmetadata
= "llvm_dibuild_create_replaceable_composite_type_native" "llvm_dibuild_create_replaceable_composite_type_bytecode"
= "llvm_dibuild_create_replaceable_composite_type_bytecode" "llvm_dibuild_create_replaceable_composite_type_native"
external dibuild_create_bit_field_member_type :
lldibuilder ->
@ -473,7 +470,7 @@ external dibuild_create_bit_field_member_type :
lldiflags ->
ty:Llvm.llmetadata ->
Llvm.llmetadata
= "llvm_dibuild_create_bit_field_member_type_native" "llvm_dibuild_create_bit_field_member_type_bytecode"
= "llvm_dibuild_create_bit_field_member_type_bytecode" "llvm_dibuild_create_bit_field_member_type_native"
external dibuild_create_class_type :
lldibuilder ->
@ -491,7 +488,7 @@ external dibuild_create_class_type :
template_params_node:Llvm.llmetadata ->
unique_identifier:string ->
Llvm.llmetadata
= "llvm_dibuild_create_class_type_native" "llvm_dibuild_create_class_type_bytecode"
= "llvm_dibuild_create_class_type_bytecode" "llvm_dibuild_create_class_type_native"
external dibuild_create_artificial_type :
lldibuilder -> ty:Llvm.llmetadata -> Llvm.llmetadata
@ -533,6 +530,25 @@ let instr_set_debug_loc i mopt =
| None -> instr_set_debug_loc_helper i (llmetadata_null ())
| Some m -> instr_set_debug_loc_helper i m
external dibuild_create_constant_value_expression :
lldibuilder -> int -> Llvm.llmetadata
= "llvm_dibuild_create_constant_value_expression"
external dibuild_create_global_variable_expression :
lldibuilder ->
scope:Llvm.llmetadata ->
name:string ->
linkage:string ->
file:Llvm.llmetadata ->
line:int ->
ty:Llvm.llmetadata ->
is_local_to_unit:bool ->
expr:Llvm.llmetadata ->
decl:Llvm.llmetadata ->
align_in_bits:int ->
Llvm.llmetadata
= "llvm_dibuild_create_global_variable_expression_bytecode" "llvm_dibuild_create_global_variable_expression_native"
external di_global_variable_expression_get_variable :
Llvm.llmetadata -> Llvm.llmetadata option
= "llvm_di_global_variable_expression_get_variable"

View File

@ -202,7 +202,7 @@ val dibuild_create_namespace :
lldibuilder ->
parent_ref:Llvm.llmetadata ->
name:string ->
bool:string ->
export_symbols:bool ->
Llvm.llmetadata
(** [dibuild_create_namespace] Create a new descriptor for a namespace with
the specified parent scope. See LLVMDIBuilderCreateNameSpace *)
@ -234,6 +234,11 @@ val dibuild_create_lexical_block :
(** [dibuild_create_lexical_block] Create a descriptor for a lexical block with
the specified parent context. See LLVMDIBuilderCreateLexicalBlock *)
val llmetadata_null : unit -> Llvm.llmetadata
(** [llmetadata_null ()] llmetadata is a wrapper around "llvm::Metadata *".
This function returns a nullptr valued llmetadata. For example, it
can be used to convey an llmetadata for "void" type. *)
val dibuild_create_debug_location :
?inlined_at:Llvm.llmetadata ->
Llvm.llcontext ->
@ -277,6 +282,28 @@ val dibuild_get_or_create_type_array :
(** [dibuild_get_or_create_type_array] Create a type array.
See LLVMDIBuilderGetOrCreateTypeArray. *)
val dibuild_create_constant_value_expression :
lldibuilder -> int -> Llvm.llmetadata
(** [dibuild_create_constant_value_expression] Create a new descriptor for
the specified variable that does not have an address, but does have
a constant value. See LLVMDIBuilderCreateConstantValueExpression. *)
val dibuild_create_global_variable_expression :
lldibuilder ->
scope:Llvm.llmetadata ->
name:string ->
linkage:string ->
file:Llvm.llmetadata ->
line:int ->
ty:Llvm.llmetadata ->
is_local_to_unit:bool ->
expr:Llvm.llmetadata ->
decl:Llvm.llmetadata ->
align_in_bits:int ->
Llvm.llmetadata
(** [dibuild_create_global_variable_expression] Create a new descriptor for
the specified variable. See LLVMDIBuilderCreateGlobalVariableExpression. *)
val di_global_variable_expression_get_variable :
Llvm.llmetadata -> Llvm.llmetadata option
(** [di_global_variable_expression_get_variable gve] returns the debug variable
@ -391,7 +418,7 @@ val dibuild_create_struct_type :
lldiflags ->
derived_from:Llvm.llmetadata ->
elements:Llvm.llmetadata array ->
run_time_lang:int ->
DWARFSourceLanguageKind.t ->
vtable_holder:Llvm.llmetadata ->
unique_id:string ->
Llvm.llmetadata
@ -471,7 +498,7 @@ val dibuild_create_typedef :
(** [dibuild_create_typedef] Create debugging information entry for a typedef.
See LLVMDIBuilderCreateTypedef. *)
val dibuild_create_inheritance_native :
val dibuild_create_inheritance :
lldibuilder ->
ty:Llvm.llmetadata ->
base_ty:Llvm.llmetadata ->
@ -479,7 +506,7 @@ val dibuild_create_inheritance_native :
vb_ptr_offset:int ->
lldiflags ->
Llvm.llmetadata
(** [dibuild_create_inheritance_native] Create debugging information entry
(** [dibuild_create_inheritance] Create debugging information entry
to establish inheritance relationship between two types.
See LLVMDIBuilderCreateInheritance. *)

View File

View File

@ -0,0 +1,33 @@
(* Tiny unit test framework - really just to help find which line is busted *)
let exit_status = ref 0
let suite_name = ref ""
let group_name = ref ""
let case_num = ref 0
let print_checkpoints = false
let group name =
group_name := !suite_name ^ "/" ^ name;
case_num := 0;
if print_checkpoints then prerr_endline (" " ^ name ^ "...")
let insist ?(exit_on_fail = false) cond =
incr case_num;
if not cond then exit_status := 10;
( match (print_checkpoints, cond) with
| false, true -> ()
| false, false ->
prerr_endline
( "FAILED: " ^ !suite_name ^ "/" ^ !group_name ^ " #"
^ string_of_int !case_num )
| true, true -> prerr_endline (" " ^ string_of_int !case_num)
| true, false -> prerr_endline (" " ^ string_of_int !case_num ^ " FAIL") );
if exit_on_fail && not cond then exit !exit_status else ()
let suite name f =
suite_name := name;
if print_checkpoints then prerr_endline (name ^ ":");
f ()

View File

@ -0,0 +1,2 @@
# This is a directory for utility functions. No test here.
config.suffixes = ['.dummy']

View File

@ -1,7 +1,7 @@
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/core.ml
* RUN: %ocamlc -g -w +A -package llvm.analysis -package llvm.bitwriter -linkpkg %t/core.ml -o %t/executable
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/core.ml && cp %S/Utils/Testsuite.ml %t/Testsuite.ml
* RUN: %ocamlc -g -w +A -package llvm.analysis -package llvm.bitwriter -I %t/ -linkpkg %t/Testsuite.ml %t/core.ml -o %t/executable
* RUN: %t/executable %t/bitcode.bc
* RUN: %ocamlopt -g -w +A -package llvm.analysis -package llvm.bitwriter -linkpkg %t/core.ml -o %t/executable
* RUN: %ocamlopt -g -w +A -package llvm.analysis -package llvm.bitwriter -I %t/ -linkpkg %t/Testsuite.ml %t/core.ml -o %t/executable
* RUN: %t/executable %t/bitcode.bc
* RUN: llvm-dis < %t/bitcode.bc > %t/dis.ll
* RUN: FileCheck %s < %t/dis.ll
@ -17,13 +17,7 @@
open Llvm
open Llvm_bitwriter
(* Tiny unit test framework - really just to help find which line is busted *)
let exit_status = ref 0
let suite_name = ref ""
let group_name = ref ""
let case_num = ref 0
let print_checkpoints = false
open Testsuite
let context = global_context ()
let i1_type = Llvm.i1_type context
let i8_type = Llvm.i8_type context
@ -35,32 +29,6 @@ let float_type = Llvm.float_type context
let double_type = Llvm.double_type context
let fp128_type = Llvm.fp128_type context
let group name =
group_name := !suite_name ^ "/" ^ name;
case_num := 0;
if print_checkpoints then
prerr_endline (" " ^ name ^ "...")
let insist cond =
incr case_num;
if not cond then
exit_status := 10;
match print_checkpoints, cond with
| false, true -> ()
| false, false ->
prerr_endline ("FAILED: " ^ !suite_name ^ "/" ^ !group_name ^ " #" ^ (string_of_int !case_num))
| true, true ->
prerr_endline (" " ^ (string_of_int !case_num))
| true, false ->
prerr_endline (" " ^ (string_of_int !case_num) ^ " FAIL")
let suite name f =
suite_name := name;
if print_checkpoints then
prerr_endline (name ^ ":");
f ()
(*===-- Fixture -----------------------------------------------------------===*)
let filename = Sys.argv.(1)

View File

@ -0,0 +1,413 @@
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/debuginfo.ml && cp %S/Utils/Testsuite.ml %t/Testsuite.ml
* RUN: %ocamlc -g -w +A -package llvm.all_backends -package llvm.target -package llvm.analysis -package llvm.debuginfo -I %t/ -linkpkg %t/Testsuite.ml %t/debuginfo.ml -o %t/executable
* RUN: %t/executable | FileCheck %s
* RUN: %ocamlopt -g -w +A -package llvm.all_backends -package llvm.target -package llvm.analysis -package llvm.debuginfo -I %t/ -linkpkg %t/Testsuite.ml %t/debuginfo.ml -o %t/executable
* RUN: %t/executable | FileCheck %s
* XFAIL: vg_leak
*)
open Testsuite
let context = Llvm.global_context ()
let filename = "di_test_file"
let directory = "di_test_dir"
let module_name = "di_test_module"
let null_metadata = Llvm_debuginfo.llmetadata_null ()
let string_of_metadata md =
Llvm.string_of_llvalue (Llvm.metadata_as_value context md)
let stdout_metadata md = Printf.printf "%s\n" (string_of_metadata md)
let prepare_target llmod =
Llvm_all_backends.initialize ();
let triple = Llvm_target.Target.default_triple () in
let lltarget = Llvm_target.Target.by_triple triple in
let llmachine = Llvm_target.TargetMachine.create ~triple lltarget in
let lldly =
Llvm_target.DataLayout.as_string
(Llvm_target.TargetMachine.data_layout llmachine)
in
let _ = Llvm.set_target_triple triple llmod in
let _ = Llvm.set_data_layout lldly llmod in
()
let new_module () =
let m = Llvm.create_module context module_name in
let () = prepare_target m in
m
let test_get_module () =
group "module_level_tests";
let m = new_module () in
let cur_ver = Llvm_debuginfo.debug_metadata_version () in
insist (cur_ver > 0);
let m_ver = Llvm_debuginfo.get_module_debug_metadata_version m in
(* We haven't added any debug info to the module *)
insist (m_ver = 0);
let dibuilder = Llvm_debuginfo.dibuilder m in
let di_version_key = "Debug Info Version" in
let ver =
Llvm.value_as_metadata @@ Llvm.const_int (Llvm.i32_type context) cur_ver
in
let () =
Llvm.add_module_flag m Llvm.ModuleFlagBehavior.Warning di_version_key ver
in
let file_di =
Llvm_debuginfo.dibuild_create_file dibuilder ~filename ~directory
in
stdout_metadata file_di;
(* CHECK: [[FILE_PTR:<0x[0-9a-f]*>]] = !DIFile(filename: "di_test_file", directory: "di_test_dir")
*)
insist
( Llvm_debuginfo.di_file_get_filename ~file:file_di = filename
&& Llvm_debuginfo.di_file_get_directory ~file:file_di = directory );
insist
( Llvm_debuginfo.get_metadata_kind file_di
= Llvm_debuginfo.MetadataKind.DIFileMetadataKind );
let cu_di =
Llvm_debuginfo.dibuild_create_compile_unit dibuilder
Llvm_debuginfo.DWARFSourceLanguageKind.C89 ~file_ref:file_di
~producer:"TestGen" ~is_optimized:false ~flags:"" ~runtime_ver:0
~split_name:"" Llvm_debuginfo.DWARFEmissionKind.LineTablesOnly ~dwoid:0
~di_inlining:false ~di_profiling:false ~sys_root:"" ~sdk:""
in
stdout_metadata cu_di;
(* CHECK: [[CMPUNIT_PTR:<0x[0-9a-f]*>]] = distinct !DICompileUnit(language: DW_LANG_C89, file: [[FILE_PTR]], producer: "TestGen", isOptimized: false, runtimeVersion: 0, emissionKind: LineTablesOnly, splitDebugInlining: false)
*)
insist
( Llvm_debuginfo.get_metadata_kind cu_di
= Llvm_debuginfo.MetadataKind.DICompileUnitMetadataKind );
let m_di =
Llvm_debuginfo.dibuild_create_module dibuilder ~parent_ref:cu_di
~name:module_name ~config_macros:"" ~include_path:"" ~sys_root:""
in
insist
( Llvm_debuginfo.get_metadata_kind m_di
= Llvm_debuginfo.MetadataKind.DIModuleMetadataKind );
insist (Llvm_debuginfo.get_module_debug_metadata_version m = cur_ver);
stdout_metadata m_di;
(* CHECK: [[MODULE_PTR:<0x[0-9a-f]*>]] = !DIModule(scope: null, name: "di_test_module")
*)
(m, dibuilder, file_di, m_di)
let flags_zero = Llvm_debuginfo.diflags_get Llvm_debuginfo.DIFlag.Zero
let int_ty_di bits dibuilder =
Llvm_debuginfo.dibuild_create_basic_type dibuilder ~name:"int"
~size_in_bits:bits ~encoding:0x05
(* llvm::dwarf::DW_ATE_signed *) flags_zero
let test_get_function m dibuilder file_di m_di =
group "function_level_tests";
(* Create a function of type "void foo (int)". *)
let int_ty_di = int_ty_di 32 dibuilder in
stdout_metadata int_ty_di;
(* CHECK: [[INT32_PTR:<0x[0-9a-f]*>]] = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)
*)
let param_types = [| null_metadata; int_ty_di |] in
let fty_di =
Llvm_debuginfo.dibuild_create_subroutine_type dibuilder ~file:file_di
~param_types flags_zero
in
insist
( Llvm_debuginfo.get_metadata_kind fty_di
= Llvm_debuginfo.MetadataKind.DISubroutineTypeMetadataKind );
(* To be able to print and verify the type array of the subroutine type,
* since we have no way to access it from fty_di, we build it again. *)
let fty_di_args =
Llvm_debuginfo.dibuild_get_or_create_type_array dibuilder ~data:param_types
in
stdout_metadata fty_di_args;
(* CHECK: [[FARGS_PTR:<0x[0-9a-f]*>]] = !{null, [[INT32_PTR]]}
*)
stdout_metadata fty_di;
(* CHECK: [[SBRTNTY_PTR:<0x[0-9a-f]*>]] = !DISubroutineType(types: [[FARGS_PTR]])
*)
(* Let's create the LLVM-IR function now. *)
let name = "tfun" in
let fty =
Llvm.function_type (Llvm.void_type context) [| Llvm.i32_type context |]
in
let f = Llvm.define_function name fty m in
let f_di =
Llvm_debuginfo.dibuild_create_function dibuilder ~scope:m_di ~name
~linkage_name:name ~file:file_di ~line_no:10 ~ty:fty_di
~is_local_to_unit:false ~is_definition:true ~scope_line:10
~flags:flags_zero ~is_optimized:false
in
stdout_metadata f_di;
(* CHECK: [[SBPRG_PTR:<0x[0-9a-f]*>]] = distinct !DISubprogram(name: "tfun", linkageName: "tfun", scope: [[MODULE_PTR]], file: [[FILE_PTR]], line: 10, type: [[SBRTNTY_PTR]], scopeLine: 10, spFlags: DISPFlagDefinition, unit: [[CMPUNIT_PTR]], retainedNodes: {{<0x[0-9a-f]*>}})
*)
Llvm_debuginfo.set_subprogram f f_di;
( match Llvm_debuginfo.get_subprogram f with
| Some f_di' -> insist (f_di = f_di')
| None -> insist false );
insist
( Llvm_debuginfo.get_metadata_kind f_di
= Llvm_debuginfo.MetadataKind.DISubprogramMetadataKind );
insist (Llvm_debuginfo.di_subprogram_get_line f_di = 10);
(f, f_di)
let test_bbinstr f f_di file_di dibuilder =
group "basic_block and instructions tests";
(* Create this pattern:
* if (arg0 != 0) {
* foo(arg0);
* }
* return;
*)
let arg0 = (Llvm.params f).(0) in
let builder = Llvm.builder_at_end context (Llvm.entry_block f) in
let zero = Llvm.const_int (Llvm.i32_type context) 0 in
let cmpi = Llvm.build_icmp Llvm.Icmp.Ne zero arg0 "cmpi" builder in
let truebb = Llvm.append_block context "truebb" f in
let falsebb = Llvm.append_block context "falsebb" f in
let _ = Llvm.build_cond_br cmpi truebb falsebb builder in
let foodecl =
Llvm.declare_function "foo"
(Llvm.element_type (Llvm.type_of f))
(Llvm.global_parent f)
in
let _ =
Llvm.position_at_end truebb builder;
let scope =
Llvm_debuginfo.dibuild_create_lexical_block dibuilder ~scope:f_di
~file:file_di ~line:9 ~column:4
in
let file_of_f_di = Llvm_debuginfo.di_scope_get_file ~scope:f_di in
let file_of_scope = Llvm_debuginfo.di_scope_get_file ~scope in
insist
( Option.is_some file_of_f_di
&& Option.get file_of_f_di = file_di
&& Option.is_some file_of_scope
&& Option.get file_of_f_di = file_di );
let foocall = Llvm.build_call foodecl [| arg0 |] "" builder in
let foocall_loc =
Llvm_debuginfo.dibuild_create_debug_location context ~line:10 ~column:12
~scope
in
Llvm_debuginfo.instr_set_debug_loc foocall (Some foocall_loc);
insist
( match Llvm_debuginfo.instr_get_debug_loc foocall with
| Some foocall_loc' -> foocall_loc' = foocall_loc
| None -> false );
stdout_metadata scope;
(* CHECK: [[BLOCK_PTR:<0x[0-9a-f]*>]] = distinct !DILexicalBlock(scope: [[SBPRG_PTR]], file: [[FILE_PTR]], line: 9, column: 4)
*)
stdout_metadata foocall_loc;
(* CHECK: !DILocation(line: 10, column: 12, scope: [[BLOCK_PTR]])
*)
insist
( Llvm_debuginfo.di_location_get_scope ~location:foocall_loc = scope
&& Llvm_debuginfo.di_location_get_line ~location:foocall_loc = 10
&& Llvm_debuginfo.di_location_get_column ~location:foocall_loc = 12 );
insist
( Llvm_debuginfo.get_metadata_kind foocall_loc
= Llvm_debuginfo.MetadataKind.DILocationMetadataKind
&& Llvm_debuginfo.get_metadata_kind scope
= Llvm_debuginfo.MetadataKind.DILexicalBlockMetadataKind );
Llvm.build_br falsebb builder
in
let _ =
Llvm.position_at_end falsebb builder;
Llvm.build_ret_void builder
in
(* Printf.printf "%s\n" (Llvm.string_of_llmodule (Llvm.global_parent f)); *)
()
let test_global_variable_expression dibuilder f_di m_di =
group "global variable expression tests";
let cexpr_di =
Llvm_debuginfo.dibuild_create_constant_value_expression dibuilder 0
in
stdout_metadata cexpr_di;
(* CHECK: [[DICEXPR:!DIExpression\(DW_OP_constu, 0, DW_OP_stack_value\)]]
*)
insist
( Llvm_debuginfo.get_metadata_kind cexpr_di
= Llvm_debuginfo.MetadataKind.DIExpressionMetadataKind );
let ty = int_ty_di 64 dibuilder in
stdout_metadata ty;
(* CHECK: [[INT64TY_PTR:<0x[0-9a-f]*>]] = !DIBasicType(name: "int", size: 64, encoding: DW_ATE_signed)
*)
let gvexpr_di =
Llvm_debuginfo.dibuild_create_global_variable_expression dibuilder
~scope:m_di ~name:"my_global" ~linkage:"" ~file:f_di ~line:5 ~ty
~is_local_to_unit:true ~expr:cexpr_di ~decl:null_metadata ~align_in_bits:0
in
insist
( Llvm_debuginfo.get_metadata_kind gvexpr_di
= Llvm_debuginfo.MetadataKind.DIGlobalVariableExpressionMetadataKind );
( match
Llvm_debuginfo.di_global_variable_expression_get_variable gvexpr_di
with
| Some gvexpr_var_di ->
insist
( Llvm_debuginfo.get_metadata_kind gvexpr_var_di
= Llvm_debuginfo.MetadataKind.DIGlobalVariableMetadataKind );
stdout_metadata gvexpr_var_di
(* CHECK: [[GV_PTR:<0x[0-9a-f]*>]] = distinct !DIGlobalVariable(name: "my_global", scope: [[MODULE_PTR]], file: [[FILE_PTR]], line: 5, type: [[INT64TY_PTR]], isLocal: true, isDefinition: true)
*)
| None -> insist false );
stdout_metadata gvexpr_di;
(* CHECK: [[GVEXP_PTR:<0x[0-9a-f]*>]] = !DIGlobalVariableExpression(var: [[GV_PTR]], expr: [[DICEXPR]])
*)
()
let test_types dibuilder file_di m_di =
group "type tests";
let namespace_di =
Llvm_debuginfo.dibuild_create_namespace dibuilder ~parent_ref:m_di
~name:"NameSpace1" ~export_symbols:false
in
stdout_metadata namespace_di;
(* CHECK: [[NAMESPACE_PTR:<0x[0-9a-f]*>]] = !DINamespace(name: "NameSpace1", scope: [[MODULE_PTR]])
*)
let int64_ty_di = int_ty_di 64 dibuilder in
let structty_args = [| int64_ty_di; int64_ty_di; int64_ty_di |] in
let struct_ty_di =
Llvm_debuginfo.dibuild_create_struct_type dibuilder ~scope:namespace_di
~name:"StructType1" ~file:file_di ~line_number:20 ~size_in_bits:192
~align_in_bits:0 flags_zero ~derived_from:null_metadata
~elements:structty_args Llvm_debuginfo.DWARFSourceLanguageKind.C89
~vtable_holder:null_metadata ~unique_id:"StructType1"
in
(* Since there's no way to fetch the element types which is now
* a type array, we build that again for checking. *)
let structty_di_eltypes =
Llvm_debuginfo.dibuild_get_or_create_type_array dibuilder
~data:structty_args
in
stdout_metadata structty_di_eltypes;
(* CHECK: [[STRUCTELT_PTR:<0x[0-9a-f]*>]] = !{[[INT64TY_PTR]], [[INT64TY_PTR]], [[INT64TY_PTR]]}
*)
stdout_metadata struct_ty_di;
(* CHECK: [[STRUCT_PTR:<0x[0-9a-f]*>]] = !DICompositeType(tag: DW_TAG_structure_type, name: "StructType1", scope: [[NAMESPACE_PTR]], file: [[FILE_PTR]], line: 20, size: 192, elements: [[STRUCTELT_PTR]], identifier: "StructType1")
*)
insist
( Llvm_debuginfo.get_metadata_kind struct_ty_di
= Llvm_debuginfo.MetadataKind.DICompositeTypeMetadataKind );
let structptr_di =
Llvm_debuginfo.dibuild_create_pointer_type dibuilder
~pointee_ty:struct_ty_di ~size_in_bits:192 ~align_in_bits:0
~address_space:0 ~name:""
in
stdout_metadata structptr_di;
(* CHECK: [[STRUCTPTR_PTR:<0x[0-9a-f]*>]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: [[STRUCT_PTR]], size: 192, dwarfAddressSpace: 0)
*)
insist
( Llvm_debuginfo.get_metadata_kind structptr_di
= Llvm_debuginfo.MetadataKind.DIDerivedTypeMetadataKind );
let enumerator1 =
Llvm_debuginfo.dibuild_create_enumerator dibuilder ~name:"Test_A" ~value:0
~is_unsigned:true
in
stdout_metadata enumerator1;
(* CHECK: [[ENUMERATOR1_PTR:<0x[0-9a-f]*>]] = !DIEnumerator(name: "Test_A", value: 0, isUnsigned: true)
*)
let enumerator2 =
Llvm_debuginfo.dibuild_create_enumerator dibuilder ~name:"Test_B" ~value:1
~is_unsigned:true
in
stdout_metadata enumerator2;
(* CHECK: [[ENUMERATOR2_PTR:<0x[0-9a-f]*>]] = !DIEnumerator(name: "Test_B", value: 1, isUnsigned: true)
*)
let enumerator3 =
Llvm_debuginfo.dibuild_create_enumerator dibuilder ~name:"Test_C" ~value:2
~is_unsigned:true
in
insist
( Llvm_debuginfo.get_metadata_kind enumerator1
= Llvm_debuginfo.MetadataKind.DIEnumeratorMetadataKind
&& Llvm_debuginfo.get_metadata_kind enumerator2
= Llvm_debuginfo.MetadataKind.DIEnumeratorMetadataKind
&& Llvm_debuginfo.get_metadata_kind enumerator3
= Llvm_debuginfo.MetadataKind.DIEnumeratorMetadataKind );
stdout_metadata enumerator3;
(* CHECK: [[ENUMERATOR3_PTR:<0x[0-9a-f]*>]] = !DIEnumerator(name: "Test_C", value: 2, isUnsigned: true)
*)
let elements = [| enumerator1; enumerator2; enumerator3 |] in
let enumeration_ty_di =
Llvm_debuginfo.dibuild_create_enumeration_type dibuilder ~scope:namespace_di
~name:"EnumTest" ~file:file_di ~line_number:1 ~size_in_bits:64
~align_in_bits:0 ~elements ~class_ty:int64_ty_di
in
let elements_arr =
Llvm_debuginfo.dibuild_get_or_create_type_array dibuilder ~data:elements
in
stdout_metadata elements_arr;
(* CHECK: [[ELEMENTS_PTR:<0x[0-9a-f]*>]] = !{[[ENUMERATOR1_PTR]], [[ENUMERATOR2_PTR]], [[ENUMERATOR3_PTR]]}
*)
stdout_metadata enumeration_ty_di;
(* CHECK: [[ENUMERATION_PTR:<0x[0-9a-f]*>]] = !DICompositeType(tag: DW_TAG_enumeration_type, name: "EnumTest", scope: [[NAMESPACE_PTR]], file: [[FILE_PTR]], line: 1, baseType: [[INT64TY_PTR]], size: 64, elements: [[ELEMENTS_PTR]])
*)
insist
( Llvm_debuginfo.get_metadata_kind enumeration_ty_di
= Llvm_debuginfo.MetadataKind.DICompositeTypeMetadataKind );
let int32_ty_di = int_ty_di 32 dibuilder in
let class_mem1 =
Llvm_debuginfo.dibuild_create_member_type dibuilder ~scope:namespace_di
~name:"Field1" ~file:file_di ~line_number:3 ~size_in_bits:32
~align_in_bits:0 ~offset_in_bits:0 flags_zero ~ty:int32_ty_di
in
stdout_metadata class_mem1;
(* CHECK: [[MEMB1_PTR:<0x[0-9a-f]*>]] = !DIDerivedType(tag: DW_TAG_member, name: "Field1", scope: [[NAMESPACE_PTR]], file: [[FILE_PTR]], line: 3, baseType: [[INT32_PTR]], size: 32)
*)
insist (Llvm_debuginfo.di_type_get_name class_mem1 = "Field1");
insist (Llvm_debuginfo.di_type_get_line class_mem1 = 3);
let class_mem2 =
Llvm_debuginfo.dibuild_create_member_type dibuilder ~scope:namespace_di
~name:"Field2" ~file:file_di ~line_number:4 ~size_in_bits:64
~align_in_bits:8 ~offset_in_bits:32 flags_zero ~ty:int64_ty_di
in
stdout_metadata class_mem2;
(* CHECK: [[MEMB2_PTR:<0x[0-9a-f]*>]] = !DIDerivedType(tag: DW_TAG_member, name: "Field2", scope: [[NAMESPACE_PTR]], file: [[FILE_PTR]], line: 4, baseType: [[INT64TY_PTR]], size: 64, align: 8, offset: 32)
*)
insist (Llvm_debuginfo.di_type_get_offset_in_bits class_mem2 = 32);
insist (Llvm_debuginfo.di_type_get_size_in_bits class_mem2 = 64);
insist (Llvm_debuginfo.di_type_get_align_in_bits class_mem2 = 8);
let class_elements = [| class_mem1; class_mem2 |] in
insist
( Llvm_debuginfo.get_metadata_kind class_mem1
= Llvm_debuginfo.MetadataKind.DIDerivedTypeMetadataKind
&& Llvm_debuginfo.get_metadata_kind class_mem2
= Llvm_debuginfo.MetadataKind.DIDerivedTypeMetadataKind );
stdout_metadata
(Llvm_debuginfo.dibuild_get_or_create_type_array dibuilder
~data:class_elements);
(* CHECK: [[CLASSMEM_PTRS:<0x[0-9a-f]*>]] = !{[[MEMB1_PTR]], [[MEMB2_PTR]]}
*)
let classty_di =
Llvm_debuginfo.dibuild_create_class_type dibuilder ~scope:namespace_di
~name:"MyClass" ~file:file_di ~line_number:1 ~size_in_bits:96
~align_in_bits:0 ~offset_in_bits:0 flags_zero ~derived_from:null_metadata
~elements:class_elements ~vtable_holder:null_metadata
~template_params_node:null_metadata ~unique_identifier:"MyClass"
in
stdout_metadata classty_di;
(* [[CLASS_PTR:<0x[0-9a-f]*>]] = !DICompositeType(tag: DW_TAG_structure_type, name: "MyClass", scope: [[NAMESPACE_PTR]], file: [[FILE_PTR]], line: 1, size: 96, elements: [[CLASSMEM_PTRS]], identifier: "MyClass")
*)
insist
( Llvm_debuginfo.get_metadata_kind classty_di
= Llvm_debuginfo.MetadataKind.DICompositeTypeMetadataKind );
()
let () =
let m, dibuilder, file_di, m_di = test_get_module () in
let f, fun_di = test_get_function m dibuilder file_di m_di in
let () = test_bbinstr f fun_di file_di dibuilder in
let () = test_global_variable_expression dibuilder file_di m_di in
let () = test_types dibuilder file_di m_di in
Llvm_debuginfo.dibuild_finalize dibuilder;
( match Llvm_analysis.verify_module m with
| Some err ->
prerr_endline ("Verification of module failed: " ^ err);
exit_status := 1
| None -> () );
exit !exit_status