mirror of
https://github.com/LLVMParty/llvm-nanobind
synced 2026-06-21 13:43:38 +00:00
Removed unused ocaml bindings
This commit is contained in:
Duncan Ogilvie
@@ -1,33 +0,0 @@
|
||||
(* 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 ()
|
||||
@@ -1,2 +0,0 @@
|
||||
# This is a directory for utility functions. No test here.
|
||||
config.suffixes = [".dummy"]
|
||||
@@ -1,54 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/analysis.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.analysis -linkpkg %t/analysis.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.analysis -linkpkg %t/analysis.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
open Llvm
|
||||
open Llvm_analysis
|
||||
|
||||
(* Note that this takes a moment to link, so it's best to keep the number of
|
||||
individual tests low. *)
|
||||
|
||||
let context = global_context ()
|
||||
|
||||
let test x = if not x then exit 1 else ()
|
||||
|
||||
let bomb msg =
|
||||
prerr_endline msg;
|
||||
exit 2
|
||||
|
||||
let _ =
|
||||
let fty = function_type (void_type context) [| |] in
|
||||
let m = create_module context "valid_m" in
|
||||
let fn = define_function "valid_fn" fty m in
|
||||
let at_entry = builder_at_end context (entry_block fn) in
|
||||
ignore (build_ret_void at_entry);
|
||||
|
||||
|
||||
(* Test that valid constructs verify. *)
|
||||
begin match verify_module m with
|
||||
Some msg -> bomb "valid module failed verification!"
|
||||
| None -> ()
|
||||
end;
|
||||
|
||||
if not (verify_function fn) then bomb "valid function failed verification!";
|
||||
|
||||
|
||||
(* Test that invalid constructs do not verify.
|
||||
A basic block can contain only one terminator instruction. *)
|
||||
ignore (build_ret_void at_entry);
|
||||
|
||||
begin match verify_module m with
|
||||
Some msg -> ()
|
||||
| None -> bomb "invalid module passed verification!"
|
||||
end;
|
||||
|
||||
if verify_function fn then bomb "invalid function passed verification!";
|
||||
|
||||
|
||||
dispose_module m
|
||||
|
||||
(* Don't bother to test assert_valid_{module,function}. *)
|
||||
@@ -1,83 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/bitreader.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %t/bitreader.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %t/bitreader.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc
|
||||
* RUN: llvm-dis < %t/bitcode.bc
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
(* Note that this takes a moment to link, so it's best to keep the number of
|
||||
individual tests low. *)
|
||||
|
||||
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
|
||||
|
||||
test (Llvm_bitwriter.write_bitcode_file m fn);
|
||||
|
||||
Llvm.dispose_module m;
|
||||
|
||||
(* parse_bitcode *)
|
||||
begin
|
||||
let mb = Llvm.MemoryBuffer.of_file fn in
|
||||
begin try
|
||||
let m = Llvm_bitreader.parse_bitcode context mb in
|
||||
Llvm.dispose_module m
|
||||
with x ->
|
||||
Llvm.MemoryBuffer.dispose mb;
|
||||
raise x
|
||||
end
|
||||
end;
|
||||
|
||||
(* MemoryBuffer.of_file *)
|
||||
test begin try
|
||||
let mb = Llvm.MemoryBuffer.of_file (fn ^ ".bogus") in
|
||||
Llvm.MemoryBuffer.dispose mb;
|
||||
false
|
||||
with Llvm.IoError _ ->
|
||||
true
|
||||
end;
|
||||
|
||||
(* get_module *)
|
||||
begin
|
||||
let mb = Llvm.MemoryBuffer.of_file fn in
|
||||
let m = begin try
|
||||
Llvm_bitreader.get_module context mb
|
||||
with x ->
|
||||
Llvm.MemoryBuffer.dispose mb;
|
||||
raise x
|
||||
end in
|
||||
Llvm.dispose_module m
|
||||
end;
|
||||
|
||||
(* corrupt the bitcode *)
|
||||
let fn = fn ^ ".txt" in
|
||||
begin let oc = open_out fn in
|
||||
output_string oc "not a bitcode file\n";
|
||||
close_out oc
|
||||
end;
|
||||
|
||||
(* test get_module exceptions *)
|
||||
test begin
|
||||
try
|
||||
let mb = Llvm.MemoryBuffer.of_file fn in
|
||||
let m = begin try
|
||||
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
|
||||
@@ -1,49 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/bitwriter.ml
|
||||
* RUN: %ocamlc -g -w -3 -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %t/bitwriter.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc
|
||||
* RUN: %ocamlopt -g -w -3 -w +A -package llvm.bitreader -package llvm.bitwriter -linkpkg %t/bitwriter.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc
|
||||
* RUN: llvm-dis < %t/bitcode.bc
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
(* Note that this takes a moment to link, so it's best to keep the number of
|
||||
individual tests low. *)
|
||||
|
||||
let context = Llvm.global_context ()
|
||||
|
||||
let test x = if not x then exit 1 else ()
|
||||
|
||||
let read_file name =
|
||||
let ic = open_in_bin name in
|
||||
let len = in_channel_length ic in
|
||||
let buf = Bytes.create len in
|
||||
|
||||
test ((input ic buf 0 len) = len);
|
||||
|
||||
close_in ic;
|
||||
|
||||
buf
|
||||
|
||||
let temp_bitcode ?unbuffered m =
|
||||
let temp_name, temp_oc = Filename.open_temp_file ~mode:[Open_binary] "" "" in
|
||||
|
||||
test (Llvm_bitwriter.output_bitcode ?unbuffered temp_oc m);
|
||||
flush temp_oc;
|
||||
|
||||
let temp_buf = read_file temp_name in
|
||||
|
||||
close_out temp_oc;
|
||||
|
||||
temp_buf
|
||||
|
||||
let _ =
|
||||
let m = Llvm.create_module context "ocaml_test_module" in
|
||||
|
||||
test (Llvm_bitwriter.write_bitcode_file m Sys.argv.(1));
|
||||
let file_buf = read_file Sys.argv.(1) in
|
||||
|
||||
test (file_buf = temp_bitcode m);
|
||||
test (file_buf = temp_bitcode ~unbuffered:false m);
|
||||
test (file_buf = temp_bitcode ~unbuffered:true m);
|
||||
test (file_buf = Bytes.of_string (Llvm.MemoryBuffer.as_string (Llvm_bitwriter.write_bitcode_to_memory_buffer m)))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,471 +0,0 @@
|
||||
(* 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
|
||||
let () = Llvm_debuginfo.set_is_new_dbg_info_format m true in
|
||||
insist (Llvm_debuginfo.is_new_dbg_info_format m);
|
||||
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 int_ptr_ty_di =
|
||||
Llvm_debuginfo.dibuild_create_pointer_type dibuilder
|
||||
~pointee_ty:int_ty_di
|
||||
~size_in_bits:32
|
||||
~align_in_bits:32
|
||||
~address_space:0
|
||||
~name:"ptrint"
|
||||
in
|
||||
stdout_metadata int_ptr_ty_di;
|
||||
(* CHECK: [[PTRINT32_PTR:<0x[0-9a-f]*>]] = !DIDerivedType(tag: DW_TAG_pointer_type, name: "ptrint", baseType: [[INT32_PTR]], size: 32, align: 32, dwarfAddressSpace: 0)
|
||||
*)
|
||||
let param_types = [| null_metadata; int_ty_di; int_ptr_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]], [[PTRINT32_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; Llvm.pointer_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]])
|
||||
*)
|
||||
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);
|
||||
(fty, f, f_di)
|
||||
|
||||
let test_bbinstr fty f f_di file_di dibuilder =
|
||||
group "basic_block and instructions tests";
|
||||
(* Create this pattern:
|
||||
* if (arg0 != 0) {
|
||||
* foo(arg0, arg1);
|
||||
* }
|
||||
* return;
|
||||
*)
|
||||
let arg0 = (Llvm.params f).(0) in
|
||||
let arg1 = (Llvm.params f).(1) 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" fty (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
|
||||
( match (file_of_f_di, file_of_scope) with
|
||||
| Some file_of_f_di', Some file_of_scope' ->
|
||||
file_of_f_di' = file_di && file_of_scope' = file_di
|
||||
| _ -> false );
|
||||
let foocall = Llvm.build_call fty foodecl [| arg0; arg1 |] "" 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_variables f dibuilder file_di fun_di =
|
||||
let entry_term = Option.get @@ (Llvm.block_terminator (Llvm.entry_block f)) in
|
||||
group "Local and parameter variable tests";
|
||||
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 auto_var =
|
||||
Llvm_debuginfo.dibuild_create_auto_variable dibuilder ~scope:fun_di
|
||||
~name:"my_local" ~file:file_di ~line:10 ~ty
|
||||
~always_preserve:false flags_zero ~align_in_bits:0
|
||||
in
|
||||
stdout_metadata auto_var;
|
||||
(* CHECK: [[LOCAL_VAR_PTR:<0x[0-9a-f]*>]] = !DILocalVariable(name: "my_local", scope: <{{0x[0-9a-f]*}}>, file: <{{0x[0-9a-f]*}}>, line: 10, type: [[INT64TY_PTR]])
|
||||
*)
|
||||
let builder = Llvm.builder_before context entry_term in
|
||||
let all = Llvm.build_alloca (Llvm.i64_type context) "my_alloca" builder in
|
||||
let scope =
|
||||
Llvm_debuginfo.dibuild_create_lexical_block dibuilder ~scope:fun_di
|
||||
~file:file_di ~line:9 ~column:4
|
||||
in
|
||||
let location =
|
||||
Llvm_debuginfo.dibuild_create_debug_location
|
||||
context ~line:10 ~column:12 ~scope
|
||||
in
|
||||
let vdi = Llvm_debuginfo.dibuild_insert_declare_before dibuilder ~storage:all
|
||||
~var_info:auto_var ~expr:(Llvm_debuginfo.dibuild_expression dibuilder [||])
|
||||
~location ~instr:entry_term
|
||||
in
|
||||
let () = Printf.printf "%s\n" (Llvm.string_of_lldbgrecord vdi) in
|
||||
(* CHECK: dbg_declare(ptr %my_alloca, ![[#]], !DIExpression(), ![[#]])
|
||||
*)
|
||||
let arg1 = (Llvm.params f).(1) in
|
||||
let arg_var = Llvm_debuginfo.dibuild_create_parameter_variable dibuilder ~scope:fun_di
|
||||
~name:"my_arg" ~argno:1 ~file:file_di ~line:10 ~ty
|
||||
~always_preserve:false flags_zero
|
||||
in
|
||||
let argdi = Llvm_debuginfo.dibuild_insert_declare_before dibuilder ~storage:arg1
|
||||
~var_info:arg_var ~expr:(Llvm_debuginfo.dibuild_expression dibuilder [||])
|
||||
~location ~instr:entry_term
|
||||
in
|
||||
let () = Printf.printf "%s\n" (Llvm.string_of_lldbgrecord argdi) in
|
||||
(* CHECK: dbg_declare(ptr %1, ![[#]], !DIExpression(), ![[#]])
|
||||
*)
|
||||
()
|
||||
|
||||
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_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 fty, f, fun_di = test_get_function m dibuilder file_di m_di in
|
||||
let () = test_bbinstr fty f fun_di file_di dibuilder in
|
||||
let () = test_global_variable_expression dibuilder file_di m_di in
|
||||
let () = test_variables f dibuilder file_di fun_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
|
||||
@@ -1,48 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/diagnostic_handler.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %t/diagnostic_handler.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc | FileCheck %s
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %t/diagnostic_handler.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.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
|
||||
@@ -1,113 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/executionengine.ml
|
||||
* RUN: %ocamlc -g -w +A -thread -package ctypes.foreign,llvm.executionengine -linkpkg %t/executionengine.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -thread -package ctypes.foreign,llvm.executionengine -linkpkg %t/executionengine.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* REQUIRES: native
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
open Llvm
|
||||
open Llvm_executionengine
|
||||
open Llvm_target
|
||||
|
||||
(* Note that this takes a moment to link, so it's best to keep the number of
|
||||
individual tests low. *)
|
||||
|
||||
let context = global_context ()
|
||||
let i8_type = Llvm.i8_type context
|
||||
let i32_type = Llvm.i32_type context
|
||||
let i64_type = Llvm.i64_type context
|
||||
let double_type = Llvm.double_type context
|
||||
|
||||
let () =
|
||||
assert (Llvm_executionengine.initialize ())
|
||||
|
||||
let bomb msg =
|
||||
prerr_endline msg;
|
||||
exit 2
|
||||
|
||||
let define_getglobal m pg =
|
||||
let fty = function_type i32_type [||] in
|
||||
let fn = define_function "getglobal" fty m in
|
||||
let b = builder_at_end (global_context ()) (entry_block fn) in
|
||||
let g = build_call fty pg [||] "" b in
|
||||
ignore (build_ret g b);
|
||||
fn
|
||||
|
||||
let define_plus m =
|
||||
let fn = define_function "plus" (function_type i32_type [| i32_type;
|
||||
i32_type |]) m in
|
||||
let b = builder_at_end (global_context ()) (entry_block fn) in
|
||||
let add = build_add (param fn 0) (param fn 1) "sum" b in
|
||||
ignore (build_ret add b);
|
||||
fn
|
||||
|
||||
let test_executionengine () =
|
||||
let open Ctypes in
|
||||
|
||||
(* create *)
|
||||
let m = create_module (global_context ()) "test_module" in
|
||||
let ee = create m in
|
||||
|
||||
(* add plus *)
|
||||
ignore (define_plus m);
|
||||
|
||||
(* declare global variable *)
|
||||
ignore (define_global "globvar" (const_int i32_type 23) m);
|
||||
|
||||
(* add module *)
|
||||
let m2 = create_module (global_context ()) "test_module2" in
|
||||
add_module m2 ee;
|
||||
|
||||
(* add global mapping *)
|
||||
(* BROKEN: see PR20656 *)
|
||||
(* let g = declare_function "g" (function_type i32_type [||]) m2 in
|
||||
let cg = coerce (Foreign.funptr (void @-> returning int32_t)) (ptr void)
|
||||
(fun () -> 42l) in
|
||||
add_global_mapping g cg ee;
|
||||
|
||||
(* check g *)
|
||||
let cg' = get_pointer_to_global g (ptr void) ee in
|
||||
if 0 <> ptr_compare cg cg' then bomb "int pointers to g differ";
|
||||
|
||||
(* add getglobal *)
|
||||
let getglobal = define_getglobal m2 g in*)
|
||||
|
||||
(* run_static_ctors *)
|
||||
run_static_ctors ee;
|
||||
|
||||
(* get a handle on globvar *)
|
||||
let varh = get_global_value_address "globvar" int32_t ee in
|
||||
if 23l <> varh then bomb "get_global_value_address didn't work";
|
||||
|
||||
(* call plus *)
|
||||
let cplusty = Foreign.funptr (int32_t @-> int32_t @-> returning int32_t) in
|
||||
let cplus = get_function_address "plus" cplusty ee in
|
||||
if 4l <> cplus 2l 2l then bomb "plus didn't work";
|
||||
|
||||
(* call getglobal *)
|
||||
(* let cgetglobalty = Foreign.funptr (void @-> returning int32_t) in
|
||||
let cgetglobal = get_pointer_to_global getglobal cgetglobalty ee in
|
||||
if 42l <> cgetglobal () then bomb "getglobal didn't work"; *)
|
||||
|
||||
(* remove_module *)
|
||||
remove_module m2 ee;
|
||||
dispose_module m2;
|
||||
|
||||
(* run_static_dtors *)
|
||||
run_static_dtors ee;
|
||||
|
||||
(* Show that the data layout binding links and runs.*)
|
||||
let dl = data_layout ee in
|
||||
|
||||
(* Demonstrate that a garbage pointer wasn't returned. *)
|
||||
let ty = DataLayout.intptr_type context dl in
|
||||
if ty != i32_type && ty != i64_type then bomb "target_data did not work";
|
||||
|
||||
(* dispose *)
|
||||
dispose ee
|
||||
|
||||
let () =
|
||||
test_executionengine ();
|
||||
Gc.compact ()
|
||||
@@ -1,25 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/ext_exc.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %t/ext_exc.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %t/ext_exc.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
let context = Llvm.global_context ()
|
||||
|
||||
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
|
||||
Llvm_bitreader.Error _ -> ();;
|
||||
let _ =
|
||||
try
|
||||
ignore (Llvm.MemoryBuffer.of_file "/path/to/nonexistent/file")
|
||||
with
|
||||
Llvm.IoError _ -> ();;
|
||||
@@ -1,59 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/irreader.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.irreader -linkpkg %t/irreader.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.irreader -linkpkg %t/irreader.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
(* Note: It takes several seconds for ocamlopt to link an executable with
|
||||
libLLVMCore.a, so it's better to write a big test than a bunch of
|
||||
little ones. *)
|
||||
|
||||
open Llvm
|
||||
open Llvm_irreader
|
||||
|
||||
let context = global_context ()
|
||||
|
||||
(* Tiny unit test framework - really just to help find which line is busted *)
|
||||
let print_checkpoints = false
|
||||
|
||||
let suite name f =
|
||||
if print_checkpoints then
|
||||
prerr_endline (name ^ ":");
|
||||
f ()
|
||||
|
||||
let _ =
|
||||
Printexc.record_backtrace true
|
||||
|
||||
let insist cond =
|
||||
if not cond then failwith "insist"
|
||||
|
||||
|
||||
(*===-- IR Reader ---------------------------------------------------------===*)
|
||||
|
||||
let test_irreader () =
|
||||
begin
|
||||
let buf = MemoryBuffer.of_string "@foo = global i32 42" in
|
||||
let m = parse_ir context buf in
|
||||
match lookup_global "foo" m with
|
||||
| Some foo ->
|
||||
insist ((global_initializer foo) = (Some (const_int (i32_type context) 42)))
|
||||
| None ->
|
||||
failwith "global"
|
||||
end;
|
||||
|
||||
begin
|
||||
let buf = MemoryBuffer.of_string "@foo = global garble" in
|
||||
try
|
||||
ignore (parse_ir context buf);
|
||||
failwith "parsed"
|
||||
with Llvm_irreader.Error _ ->
|
||||
()
|
||||
end
|
||||
|
||||
|
||||
(*===-- Driver ------------------------------------------------------------===*)
|
||||
|
||||
let _ =
|
||||
suite "irreader" test_irreader
|
||||
@@ -1,65 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/linker.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.linker -linkpkg %t/linker.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.linker -linkpkg %t/linker.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
(* Note: It takes several seconds for ocamlopt to link an executable with
|
||||
libLLVMCore.a, so it's better to write a big test than a bunch of
|
||||
little ones. *)
|
||||
|
||||
open Llvm
|
||||
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
|
||||
|
||||
let suite name f =
|
||||
if print_checkpoints then
|
||||
prerr_endline (name ^ ":");
|
||||
f ()
|
||||
|
||||
|
||||
(*===-- Linker -----------------------------------------------------------===*)
|
||||
|
||||
let test_linker () =
|
||||
set_diagnostic_handler context (Some diagnostic_handler);
|
||||
|
||||
let fty = function_type void_type [| |] in
|
||||
|
||||
let make_module name =
|
||||
let m = create_module context name in
|
||||
let fn = define_function ("fn_" ^ name) fty m in
|
||||
ignore (build_ret_void (builder_at_end context (entry_block fn)));
|
||||
m
|
||||
in
|
||||
|
||||
let m1 = make_module "one"
|
||||
and m2 = make_module "two" in
|
||||
link_modules m1 m2;
|
||||
dispose_module m1;
|
||||
|
||||
let m1 = make_module "one"
|
||||
and m2 = make_module "two" in
|
||||
link_modules m1 m2;
|
||||
dispose_module m1;
|
||||
|
||||
let m1 = make_module "one"
|
||||
and m2 = make_module "one" in
|
||||
try
|
||||
link_modules m1 m2;
|
||||
failwith "must raise"
|
||||
with Error _ ->
|
||||
dispose_module m1
|
||||
|
||||
(*===-- Driver ------------------------------------------------------------===*)
|
||||
|
||||
let _ =
|
||||
suite "linker" test_linker
|
||||
@@ -1,4 +0,0 @@
|
||||
config.suffixes = [".ml"]
|
||||
|
||||
if not "ocaml" in config.root.llvm_bindings:
|
||||
config.unsupported = True
|
||||
@@ -1,74 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/passbuilder.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.passbuilder -package llvm.all_backends -linkpkg %t/passbuilder.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.passbuilder -package llvm.all_backends -linkpkg %t/passbuilder.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
let () = Llvm_all_backends.initialize ()
|
||||
|
||||
(*===-- Fixture -----------------------------------------------------------===*)
|
||||
|
||||
let context = Llvm.global_context ()
|
||||
|
||||
let m = Llvm.create_module context "mymodule"
|
||||
|
||||
let () =
|
||||
let ty =
|
||||
Llvm.function_type (Llvm.void_type context)
|
||||
[| Llvm.i1_type context;
|
||||
Llvm.pointer_type context;
|
||||
Llvm.pointer_type context |]
|
||||
in
|
||||
let foo = Llvm.define_function "foo" ty m in
|
||||
let entry = Llvm.entry_block foo in
|
||||
let builder = Llvm.builder_at_end context entry in
|
||||
ignore
|
||||
(Llvm.build_store
|
||||
(Llvm.const_int (Llvm.i8_type context) 42) (Llvm.param foo 1) builder);
|
||||
let loop = Llvm.append_block context "loop" foo in
|
||||
Llvm.position_at_end loop builder;
|
||||
ignore
|
||||
(Llvm.build_load (Llvm.i8_type context) (Llvm.param foo 2) "tmp1" builder);
|
||||
ignore (Llvm.build_br loop builder);
|
||||
let exit = Llvm.append_block context "exit" foo in
|
||||
Llvm.position_at_end exit builder;
|
||||
ignore (Llvm.build_ret_void builder);
|
||||
Llvm.position_at_end entry builder;
|
||||
ignore (Llvm.build_cond_br (Llvm.param foo 0) loop exit builder)
|
||||
|
||||
let target =
|
||||
Llvm_target.Target.by_triple (Llvm_target.Target.default_triple ())
|
||||
|
||||
let machine =
|
||||
Llvm_target.TargetMachine.create
|
||||
~triple:(Llvm_target.Target.default_triple ()) target
|
||||
|
||||
let options = Llvm_passbuilder.create_passbuilder_options ()
|
||||
|
||||
(*===-- PassBuilder -------------------------------------------------------===*)
|
||||
let () =
|
||||
Llvm_passbuilder.passbuilder_options_set_verify_each options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_debug_logging options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_loop_interleaving options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_loop_vectorization options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_slp_vectorization options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_loop_unrolling options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_forget_all_scev_in_loop_unroll
|
||||
options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_licm_mssa_opt_cap options 2;
|
||||
Llvm_passbuilder.passbuilder_options_set_licm_mssa_no_acc_for_promotion_cap
|
||||
options 2;
|
||||
Llvm_passbuilder.passbuilder_options_set_call_graph_profile options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_merge_functions options true;
|
||||
Llvm_passbuilder.passbuilder_options_set_inliner_threshold options 2;
|
||||
match Llvm_passbuilder.run_passes m "no-op-module" machine options with
|
||||
| Error e ->
|
||||
prerr_endline e;
|
||||
assert false
|
||||
| Ok () -> ()
|
||||
|
||||
let () =
|
||||
Llvm_passbuilder.dispose_passbuilder_options options;
|
||||
Llvm.dispose_module m
|
||||
@@ -1,111 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/target.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.target -package llvm.all_backends -linkpkg %t/target.ml -o %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.target -package llvm.all_backends -linkpkg %t/target.ml -o %t/executable
|
||||
* RUN: %t/executable %t/bitcode.bc
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
(* Note: It takes several seconds for ocamlopt to link an executable with
|
||||
libLLVMCore.a, so it's better to write a big test than a bunch of
|
||||
little ones. *)
|
||||
|
||||
open Llvm
|
||||
open Llvm_target
|
||||
|
||||
let () = Llvm_all_backends.initialize ()
|
||||
|
||||
let context = global_context ()
|
||||
let i32_type = Llvm.i32_type context
|
||||
let i64_type = Llvm.i64_type context
|
||||
|
||||
(* Tiny unit test framework - really just to help find which line is busted *)
|
||||
let print_checkpoints = false
|
||||
|
||||
let _ =
|
||||
Printexc.record_backtrace true
|
||||
|
||||
let assert_equal a b =
|
||||
if a <> b then failwith "assert_equal"
|
||||
|
||||
|
||||
(*===-- Fixture -----------------------------------------------------------===*)
|
||||
|
||||
let filename = Sys.argv.(1)
|
||||
let m = create_module context filename
|
||||
|
||||
let target = Target.by_triple (Target.default_triple ())
|
||||
|
||||
let machine = TargetMachine.create (Target.default_triple ()) target
|
||||
|
||||
(*===-- Data Layout -------------------------------------------------------===*)
|
||||
|
||||
let test_target_data () =
|
||||
let module DL = DataLayout in
|
||||
let layout = "e-p:32:32-f64:32:64-v64:32:64-v128:32:128-n32-S32" in
|
||||
let dl = DL.of_string layout in
|
||||
let sty = struct_type context [| i32_type; i64_type |] in
|
||||
|
||||
assert_equal (DL.as_string dl) layout;
|
||||
assert_equal (DL.byte_order dl) Endian.Little;
|
||||
assert_equal (DL.pointer_size dl) 4;
|
||||
assert_equal (DL.intptr_type context dl) i32_type;
|
||||
assert_equal (DL.qualified_pointer_size 0 dl) 4;
|
||||
assert_equal (DL.qualified_intptr_type context 0 dl) i32_type;
|
||||
assert_equal (DL.size_in_bits sty dl) (Int64.of_int 96);
|
||||
assert_equal (DL.store_size sty dl) (Int64.of_int 12);
|
||||
assert_equal (DL.abi_size sty dl) (Int64.of_int 12);
|
||||
assert_equal (DL.stack_align sty dl) 4;
|
||||
assert_equal (DL.preferred_align sty dl) 8;
|
||||
assert_equal (DL.preferred_align_of_global (declare_global sty "g" m) dl) 8;
|
||||
assert_equal (DL.element_at_offset sty (Int64.of_int 1) dl) 0;
|
||||
assert_equal (DL.offset_of_element sty 1 dl) (Int64.of_int 4)
|
||||
|
||||
|
||||
(*===-- Target ------------------------------------------------------------===*)
|
||||
|
||||
let test_target () =
|
||||
let module T = Target in
|
||||
ignore (T.succ target);
|
||||
ignore (T.name target);
|
||||
ignore (T.description target);
|
||||
ignore (T.has_jit target);
|
||||
ignore (T.has_target_machine target);
|
||||
ignore (T.has_asm_backend target)
|
||||
|
||||
|
||||
(*===-- Target Machine ----------------------------------------------------===*)
|
||||
|
||||
let test_target_machine () =
|
||||
let module TM = TargetMachine in
|
||||
assert_equal (TM.target machine) target;
|
||||
assert_equal (TM.triple machine) (Target.default_triple ());
|
||||
assert_equal (TM.cpu machine) "";
|
||||
assert_equal (TM.features machine) "";
|
||||
ignore (TM.data_layout machine);
|
||||
TM.set_verbose_asm true machine
|
||||
|
||||
|
||||
(*===-- Code Emission -----------------------------------------------------===*)
|
||||
|
||||
let test_code_emission () =
|
||||
TargetMachine.emit_to_file m CodeGenFileType.ObjectFile filename machine;
|
||||
try
|
||||
TargetMachine.emit_to_file m CodeGenFileType.ObjectFile
|
||||
"/nonexistent/file" machine;
|
||||
failwith "must raise"
|
||||
with Llvm_target.Error _ ->
|
||||
();
|
||||
|
||||
let buf = TargetMachine.emit_to_memory_buffer m CodeGenFileType.ObjectFile
|
||||
machine in
|
||||
Llvm.MemoryBuffer.dispose buf
|
||||
|
||||
|
||||
(*===-- Driver ------------------------------------------------------------===*)
|
||||
|
||||
let _ =
|
||||
test_target_data ();
|
||||
test_target ();
|
||||
test_target_machine ();
|
||||
test_code_emission ();
|
||||
dispose_module m
|
||||
@@ -1,21 +0,0 @@
|
||||
(* RUN: rm -rf %t && mkdir -p %t && cp %s %t/transform_utils.ml
|
||||
* RUN: %ocamlc -g -w +A -package llvm.transform_utils -linkpkg %t/transform_utils.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* RUN: %ocamlopt -g -w +A -package llvm.transform_utils -linkpkg %t/transform_utils.ml -o %t/executable
|
||||
* RUN: %t/executable
|
||||
* XFAIL: vg_leak
|
||||
*)
|
||||
|
||||
open Llvm
|
||||
open Llvm_transform_utils
|
||||
|
||||
let context = global_context ()
|
||||
|
||||
let test_clone_module () =
|
||||
let m = create_module context "mod" in
|
||||
let m' = clone_module m in
|
||||
if m == m' then failwith "m == m'";
|
||||
if string_of_llmodule m <> string_of_llmodule m' then failwith "string_of m <> m'"
|
||||
|
||||
let () =
|
||||
test_clone_module ()
|
||||
Reference in New Issue
Block a user