diff --git a/llvm/bindings/ocaml/debuginfo/debuginfo_ocaml.c b/llvm/bindings/ocaml/debuginfo/debuginfo_ocaml.c --- a/llvm/bindings/ocaml/debuginfo/debuginfo_ocaml.c +++ b/llvm/bindings/ocaml/debuginfo/debuginfo_ocaml.c @@ -845,7 +845,7 @@ } 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 @@ 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))); diff --git a/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.ml b/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.ml --- a/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.ml +++ b/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.ml @@ -192,7 +192,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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" diff --git a/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.mli b/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.mli --- a/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.mli +++ b/llvm/bindings/ocaml/debuginfo/llvm_debuginfo.mli @@ -202,7 +202,7 @@ 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 @@ (** [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 @@ (** [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 @@ 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 @@ (** [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 @@ 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. *) diff --git a/llvm/test/Bindings/OCaml/.ocamlformat b/llvm/test/Bindings/OCaml/.ocamlformat new file mode 100644 diff --git a/llvm/test/Bindings/OCaml/Utils/Testsuite.ml b/llvm/test/Bindings/OCaml/Utils/Testsuite.ml new file mode 100644 --- /dev/null +++ b/llvm/test/Bindings/OCaml/Utils/Testsuite.ml @@ -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 () diff --git a/llvm/test/Bindings/OCaml/Utils/lit.local.cfg b/llvm/test/Bindings/OCaml/Utils/lit.local.cfg new file mode 100644 --- /dev/null +++ b/llvm/test/Bindings/OCaml/Utils/lit.local.cfg @@ -0,0 +1,2 @@ +# This is a directory for utility functions. No test here. +config.suffixes = ['.dummy'] diff --git a/llvm/test/Bindings/OCaml/core.ml b/llvm/test/Bindings/OCaml/core.ml --- a/llvm/test/Bindings/OCaml/core.ml +++ b/llvm/test/Bindings/OCaml/core.ml @@ -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 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) diff --git a/llvm/test/Bindings/OCaml/debuginfo.ml b/llvm/test/Bindings/OCaml/debuginfo.ml new file mode 100644 --- /dev/null +++ b/llvm/test/Bindings/OCaml/debuginfo.ml @@ -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