(* 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;
- prerr_endline (" " ^ name ^ "...")
+ if print_checkpoints then
+ prerr_endline (" " ^ name ^ "...")
let insist cond =
incr case_num;
- if not cond then exit_status := 10;
- prerr_endline (" " ^ (string_of_int !case_num) ^ if cond then ""
- else " FAIL")
+ 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 =
- prerr_endline (name ^ ":");
+ suite_name := name;
+ if print_checkpoints then
+ prerr_endline (name ^ ":");
f ()
let filename = Sys.argv.(1)
let m = create_module filename
+let mp = ModuleProvider.create m
(*===-- Target ------------------------------------------------------------===*)
ignore (define_global "Const05" c m);
insist ((array_type i8_type 9) = type_of c);
- (* RUN: grep {Const06.*3.1459} < %t.ll
+ (* RUN: grep {ConstSingle.*2.75} < %t.ll
+ * RUN: grep {ConstDouble.*3.1459} < %t.ll
*)
- group "real";
- let c = const_float double_type 3.1459 in
- ignore (define_global "Const06" c m);
- insist (double_type = type_of c);
+ begin group "real";
+ let cs = const_float float_type 2.75 in
+ ignore (define_global "ConstSingle" cs m);
+ insist (float_type = type_of cs);
+
+ let cd = const_float double_type 3.1459 in
+ ignore (define_global "ConstDouble" cd m);
+ insist (double_type = type_of cd)
+ end;
let one = const_int i16_type 1 in
let two = const_int i16_type 2 in
ignore (define_global "Const08" c m);
insist ((vector_type i16_type 8) = (type_of c));
- (* RUN: grep {Const09.*\{ i16, i16, i32, i32 \} \{} < %t.ll
+ (* RUN: grep {Const09.*. i16, i16, i32, i32 . .} < %t.ll
*)
group "structure";
let c = const_struct [| one; two; three; four |] in
let g = define_global "ConstGlobalVar" fourty_two32 m in
insist (not (is_global_constant g));
set_global_constant true g;
- insist (is_global_constant g)
+ insist (is_global_constant g);
+
+ begin group "iteration";
+ let m = create_module "temp" in
+
+ insist (At_end m = global_begin m);
+ insist (At_start m = global_end m);
+
+ let g1 = declare_global i32_type "One" m in
+ let g2 = declare_global i32_type "Two" m in
+
+ insist (Before g1 = global_begin m);
+ insist (Before g2 = global_succ g1);
+ insist (At_end m = global_succ g2);
+
+ insist (After g2 = global_end m);
+ insist (After g1 = global_pred g2);
+ insist (At_start m = global_pred g1);
+
+ let lf s x = s ^ "->" ^ value_name x in
+ insist ("->One->Two" = fold_left_globals lf "" m);
+
+ let rf x s = value_name x ^ "<-" ^ s in
+ insist ("One<-Two<-" = fold_right_globals rf m "");
+
+ dispose_module m
+ end
(*===-- Functions ---------------------------------------------------------===*)
(* RUN: grep {declare i32 @Fn1\(i32, i64\)} < %t.ll
*)
- group "declare";
- insist (None = lookup_function "Fn1" m);
- let fn = declare_function "Fn1" ty m in
- insist (pointer_type ty = type_of fn);
- insist (is_declaration fn);
- insist (0 = Array.length (basic_blocks fn));
- insist (pointer_type ty2 == type_of (declare_function "Fn1" ty2 m));
- insist (fn == declare_function "Fn1" ty m);
- insist (None <> lookup_function "Fn1" m);
- insist (match lookup_function "Fn1" m with Some x -> x = fn
- | None -> false);
+ begin group "declare";
+ insist (None = lookup_function "Fn1" m);
+ let fn = declare_function "Fn1" ty m in
+ insist (pointer_type ty = type_of fn);
+ insist (is_declaration fn);
+ insist (0 = Array.length (basic_blocks fn));
+ insist (pointer_type ty2 == type_of (declare_function "Fn1" ty2 m));
+ insist (fn == declare_function "Fn1" ty m);
+ insist (None <> lookup_function "Fn1" m);
+ insist (match lookup_function "Fn1" m with Some x -> x = fn
+ | None -> false);
+ insist (m == global_parent fn)
+ end;
(* RUN: grep -v {Fn2} < %t.ll
*)
insist (CallConv.fast = function_call_conv fn);
ignore (build_unreachable (builder_at_end (entry_block fn)));
- begin group "collector";
+ begin group "gc";
(* RUN: grep {Fn6.*gc.*shadowstack} < %t.ll
*)
let fn = define_function "Fn6" ty m in
- insist (None = collector fn);
- set_collector (Some "ocaml") fn;
- insist (Some "ocaml" = collector fn);
- set_collector None fn;
- insist (None = collector fn);
- set_collector (Some "shadowstack") fn;
+ insist (None = gc fn);
+ set_gc (Some "ocaml") fn;
+ insist (Some "ocaml" = gc fn);
+ set_gc None fn;
+ insist (None = gc fn);
+ set_gc (Some "shadowstack") fn;
ignore (build_unreachable (builder_at_end (entry_block fn)));
+ end;
+
+ begin group "iteration";
+ let m = create_module "temp" in
+
+ insist (At_end m = function_begin m);
+ insist (At_start m = function_end m);
+
+ let f1 = define_function "One" ty m in
+ let f2 = define_function "Two" ty m in
+
+ insist (Before f1 = function_begin m);
+ insist (Before f2 = function_succ f1);
+ insist (At_end m = function_succ f2);
+
+ insist (After f2 = function_end m);
+ insist (After f1 = function_pred f2);
+ insist (At_start m = function_pred f1);
+
+ let lf s x = s ^ "->" ^ value_name x in
+ insist ("->One->Two" = fold_left_functions lf "" m);
+
+ let rf x s = value_name x ^ "<-" ^ s in
+ insist ("One<-Two<-" = fold_right_functions rf m "");
+
+ dispose_module m
+ end
+
+
+(*===-- Params ------------------------------------------------------------===*)
+
+let test_params () =
+ begin group "iteration";
+ let m = create_module "temp" in
+
+ let vf = define_function "void" (function_type void_type [| |]) m in
+
+ insist (At_end vf = param_begin vf);
+ insist (At_start vf = param_end vf);
+
+ let ty = function_type void_type [| i32_type; i32_type |] in
+ let f = define_function "f" ty m in
+ let p1 = param f 0 in
+ let p2 = param f 1 in
+ set_value_name "One" p1;
+ set_value_name "Two" p2;
+
+ insist (Before p1 = param_begin f);
+ insist (Before p2 = param_succ p1);
+ insist (At_end f = param_succ p2);
+
+ insist (After p2 = param_end f);
+ insist (After p1 = param_pred p2);
+ insist (At_start f = param_pred p1);
+
+ let lf s x = s ^ "->" ^ value_name x in
+ insist ("->One->Two" = fold_left_params lf "" f);
+
+ let rf x s = value_name x ^ "<-" ^ s in
+ insist ("One<-Two<-" = fold_right_params rf f "");
+
+ dispose_module m
end
ignore (build_unreachable (builder_at_end bb));
insist (bb = block_of_value (value_of_block bb));
insist (value_is_block (value_of_block bb));
- insist (not (value_is_block (const_null i32_type)))
+ insist (not (value_is_block (const_null i32_type)));
+
+ begin group "iteration";
+ let m = create_module "temp" in
+ let f = declare_function "Temp" (function_type i32_type [| |]) m in
+
+ insist (At_end f = block_begin f);
+ insist (At_start f = block_end f);
+
+ let b1 = append_block "One" f in
+ let b2 = append_block "Two" f in
+
+ insist (Before b1 = block_begin f);
+ insist (Before b2 = block_succ b1);
+ insist (At_end f = block_succ b2);
+
+ insist (After b2 = block_end f);
+ insist (After b1 = block_pred b2);
+ insist (At_start f = block_pred b1);
+
+ let lf s x = s ^ "->" ^ value_name (value_of_block x) in
+ insist ("->One->Two" = fold_left_blocks lf "" f);
+
+ let rf x s = value_name (value_of_block x) ^ "<-" ^ s in
+ insist ("One<-Two<-" = fold_right_blocks rf f "");
+
+ dispose_module m
+ end
+
+
+(*===-- Instructions ------------------------------------------------------===*)
+
+let test_instructions () =
+ begin group "iteration";
+ let m = create_module "temp" in
+ let fty = function_type void_type [| i32_type; i32_type |] in
+ let f = define_function "f" fty m in
+ let bb = entry_block f in
+ let b = builder_at (At_end bb) in
+
+ insist (At_end bb = instr_begin bb);
+ insist (At_start bb = instr_end bb);
+
+ let i1 = build_add (param f 0) (param f 1) "One" b in
+ let i2 = build_sub (param f 0) (param f 1) "Two" b in
+
+ insist (Before i1 = instr_begin bb);
+ insist (Before i2 = instr_succ i1);
+ insist (At_end bb = instr_succ i2);
+
+ insist (After i2 = instr_end bb);
+ insist (After i1 = instr_pred i2);
+ insist (At_start bb = instr_pred i1);
+
+ let lf s x = s ^ "->" ^ value_name x in
+ insist ("->One->Two" = fold_left_instrs lf "" bb);
+
+ let rf x s = value_name x ^ "<-" ^ s in
+ insist ("One<-Two<-" = fold_right_instrs rf bb "");
+
+ dispose_module m
+ end
(*===-- Builder -----------------------------------------------------------===*)
let test_builder () =
let (++) x f = f x; x in
+ begin group "parent";
+ insist (try
+ ignore (insertion_block (builder ()));
+ false
+ with Not_found ->
+ true);
+
+ let fty = function_type void_type [| i32_type |] in
+ let fn = define_function "BuilderParent" fty m in
+ let bb = entry_block fn in
+ let b = builder_at_end bb in
+ let p = param fn 0 in
+ let sum = build_add p p "sum" b in
+ ignore (build_ret_void b);
+
+ insist (fn = block_parent bb);
+ insist (fn = param_parent p);
+ insist (bb = instr_parent sum);
+ insist (bb = insertion_block b)
+ end;
+
group "ret void";
begin
(* RUN: grep {ret void} < %t.ll
ignore (build_cond_br cond bb03 bb00 b)
end;
- (* TODO: Switch *)
+ group "switch"; begin
+ (* RUN: grep {switch.*P1.*SwiBlock3} < %t.ll
+ * RUN: grep {2,.*SwiBlock2} < %t.ll
+ *)
+ let bb1 = append_block "SwiBlock1" fn in
+ let bb2 = append_block "SwiBlock2" fn in
+ ignore (build_unreachable (builder_at_end bb2));
+ let bb3 = append_block "SwiBlock3" fn in
+ ignore (build_unreachable (builder_at_end bb3));
+ let si = build_switch p1 bb3 1 (builder_at_end bb1) in
+ ignore (add_case si (const_int i32_type 2) bb2)
+ end;
group "invoke"; begin
(* RUN: grep {Inst02.*invoke.*P1.*P2} < %t.ll
* RUN: grep {Inst49.*extractelement.*Vec1.*P2} < %t.ll
* RUN: grep {Inst50.*insertelement.*Vec1.*P1.*P2} < %t.ll
* RUN: grep {Inst51.*shufflevector.*Vec1.*Vec2.*1.*1.*0.*0} < %t.ll
+ * RUN: grep {CallInst.*tail call} < %t.ll
*)
let ci = build_call fn [| p2; p1 |] "CallInst" atentry in
insist (CallConv.c = instruction_call_conv ci);
set_instruction_call_conv 63 ci;
insist (63 = instruction_call_conv ci);
+ insist (not (is_tail_call ci));
+ set_tail_call true ci;
+ insist (is_tail_call ci);
let inst46 = build_icmp Icmp.Eq p1 p2 "Inst46" atentry in
ignore (build_select inst46 p1 p2 "Inst47" atentry);
ModuleProvider.dispose mp
+(*===-- Pass Managers -----------------------------------------------------===*)
+
+let test_pass_manager () =
+ let (++) x f = ignore (f x); x in
+
+ begin group "module pass manager";
+ ignore (PassManager.create ()
+ ++ PassManager.run_module m
+ ++ PassManager.dispose)
+ end;
+
+ begin group "function pass manager";
+ let fty = function_type void_type [| |] in
+ let fn = define_function "FunctionPassManager" fty m in
+ ignore (build_ret_void (builder_at_end (entry_block fn)));
+
+ ignore (PassManager.create_function mp
+ ++ PassManager.initialize
+ ++ PassManager.run_function fn
+ ++ PassManager.finalize
+ ++ PassManager.dispose)
+ end
+
+
(*===-- Writer ------------------------------------------------------------===*)
let test_writer () =
group "writer";
insist (write_bitcode_file m filename);
- dispose_module m
+ ModuleProvider.dispose mp
(*===-- Driver ------------------------------------------------------------===*)
suite "global values" test_global_values;
suite "global variables" test_global_variables;
suite "functions" test_functions;
+ suite "params" test_params;
suite "basic blocks" test_basic_blocks;
+ suite "instructions" test_instructions;
suite "builder" test_builder;
suite "module provider" test_module_provider;
- suite "writer" test_writer;
+ suite "pass manager" test_pass_manager;
+ suite "writer" test_writer; (* Keep this last; it disposes m. *)
exit !exit_status
projects / oota-llvm.git / blobdiff