X-Git-Url: http://plrg.eecs.uci.edu/git/?p=oota-llvm.git;a=blobdiff_plain;f=test%2FBindings%2FOcaml%2Fvmcore.ml;h=694590885de29699e5e56672be44dc7750f27855;hp=65d8a316e9ca51ddca73e126e5137aea1f1f14f7;hb=07cabf6102800aa701bc4d1bd282fafb63b8a416;hpb=57cebeec7ba08b55f29f5bf98ad0a3a17e9d0c71 diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml index 65d8a316e9c..694590885de 100644 --- a/test/Bindings/Ocaml/vmcore.ml +++ b/test/Bindings/Ocaml/vmcore.ml @@ -1,4 +1,4 @@ -(* RUN: %ocamlc llvm.cma llvm_analysis.cma llvm_bitwriter.cma %s -o %t +(* RUN: %ocamlc -warn-error A llvm.cma llvm_analysis.cma llvm_bitwriter.cma %s -o %t * RUN: ./%t %t.bc * RUN: llvm-dis < %t.bc > %t.ll *) @@ -13,23 +13,34 @@ 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 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; - let msg = if cond then " pass " else begin + if not cond then exit_status := 10; - " FAIL " - end in - prerr_endline (" " ^ (string_of_int !case_num) ^ if cond then "" - else " FAIL") + 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 () @@ -37,8 +48,28 @@ let suite name f = let filename = Sys.argv.(1) let m = create_module filename +let mp = ModuleProvider.create m +(*===-- Target ------------------------------------------------------------===*) + +let test_target () = + begin group "triple"; + (* RUN: grep "i686-apple-darwin8" < %t.ll + *) + let trip = "i686-apple-darwin8" in + set_target_triple trip m; + insist (trip = target_triple m) + end; + + begin group "layout"; + (* RUN: grep "bogus" < %t.ll + *) + let layout = "bogus" in + set_data_layout layout m; + insist (layout = data_layout m) + end + (*===-- Types -------------------------------------------------------------===*) let test_types () = @@ -46,13 +77,13 @@ let test_types () = *) group "void"; insist (define_type_name "Ty01" void_type m); - insist (Void_type == classify_type void_type); + insist (TypeKind.Void == classify_type void_type); (* RUN: grep {Ty02.*i1} < %t.ll *) group "i1"; insist (define_type_name "Ty02" i1_type m); - insist (Integer_type == classify_type i1_type); + insist (TypeKind.Integer == classify_type i1_type); (* RUN: grep {Ty03.*i32} < %t.ll *) @@ -69,20 +100,20 @@ let test_types () = *) group "float"; insist (define_type_name "Ty05" float_type m); - insist (Float_type == classify_type float_type); + insist (TypeKind.Float == classify_type float_type); (* RUN: grep {Ty06.*double} < %t.ll *) group "double"; insist (define_type_name "Ty06" double_type m); - insist (Double_type == classify_type double_type); + insist (TypeKind.Double == classify_type double_type); (* RUN: grep {Ty07.*i32.*i1, double} < %t.ll *) group "function"; let ty = function_type i32_type [| i1_type; double_type |] in insist (define_type_name "Ty07" ty m); - insist (Function_type = classify_type ty); + insist (TypeKind.Function = classify_type ty); insist (not (is_var_arg ty)); insist (i32_type == return_type ty); insist (double_type == (param_types ty).(1)); @@ -101,7 +132,7 @@ let test_types () = insist (define_type_name "Ty09" ty m); insist (7 = array_length ty); insist (i8_type == element_type ty); - insist (Array_type == classify_type ty); + insist (TypeKind.Array == classify_type ty); begin group "pointer"; (* RUN: grep {UnqualPtrTy.*float\*} < %t.ll @@ -110,7 +141,7 @@ let test_types () = insist (define_type_name "UnqualPtrTy" ty m); insist (float_type == element_type ty); insist (0 == address_space ty); - insist (Pointer_type == classify_type ty) + insist (TypeKind.Pointer == classify_type ty) end; begin group "qualified_pointer"; @@ -195,12 +226,18 @@ let test_constants () = 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 @@ -222,7 +259,7 @@ let test_constants () = 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 @@ -289,8 +326,8 @@ let test_constants () = ignore (define_global "ConstAnd" (const_and foldbomb five) m); ignore (define_global "ConstOr" (const_or foldbomb five) m); ignore (define_global "ConstXor" (const_xor foldbomb five) m); - ignore (define_global "ConstICmp" (const_icmp Icmp_sle foldbomb five) m); - ignore (define_global "ConstFCmp" (const_fcmp Fcmp_ole ffoldbomb ffive) m); + ignore (define_global "ConstICmp" (const_icmp Icmp.Sle foldbomb five) m); + ignore (define_global "ConstFCmp" (const_fcmp Fcmp.Ole ffoldbomb ffive) m); group "constant casts"; (* RUN: grep {ConstTrunc.*trunc} < %t.ll @@ -336,7 +373,7 @@ let test_constants () = ignore (define_global "ConstSizeOf" (size_of (pointer_type i8_type)) m); ignore (define_global "ConstGEP" (const_gep foldbomb_gv [| five |]) m); ignore (define_global "ConstSelect" (const_select - (const_icmp Icmp_sle foldbomb five) + (const_icmp Icmp.Sle foldbomb five) (const_int i8_type (-1)) (const_int i8_type 0)) m); let zero = const_int i32_type 0 in @@ -371,8 +408,8 @@ let test_global_values () = *) group "linkage"; let g = define_global "GVal02" zero32 m ++ - set_linkage Link_once_linkage in - insist (Link_once_linkage = linkage g); + set_linkage Linkage.Link_once in + insist (Linkage.Link_once = linkage g); (* RUN: grep {GVal03.*Hanalei} < %t.ll *) @@ -385,8 +422,8 @@ let test_global_values () = *) group "visibility"; let g = define_global "GVal04" zero32 m ++ - set_visibility Hidden_visibility in - insist (Hidden_visibility = visibility g); + set_visibility Visibility.Hidden in + insist (Visibility.Hidden = visibility g); (* RUN: grep {GVal05.*align 128} < %t.ll *) @@ -444,7 +481,33 @@ let test_global_variables () = 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 ---------------------------------------------------------===*) @@ -455,17 +518,19 @@ let test_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 *) @@ -499,22 +564,84 @@ let test_functions () = *) group "callconv"; let fn = define_function "Fn5" ty m in - insist (ccc = function_call_conv fn); - set_function_call_conv fastcc fn; - insist (fastcc = function_call_conv fn); + insist (CallConv.c = function_call_conv fn); + set_function_call_conv CallConv.fast fn; + 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 @@ -562,7 +689,68 @@ let test_basic_blocks () = 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 -----------------------------------------------------------===*) @@ -570,6 +758,27 @@ let test_basic_blocks () = 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 @@ -616,7 +825,18 @@ let test_builder () = 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 @@ -745,22 +965,31 @@ let test_builder () = * RUN: grep {Inst42.*fcmp.*false.*F1.*F2} < %t.ll * RUN: grep {Inst43.*fcmp.*true.*F2.*F1} < %t.ll *) - ignore (build_icmp Icmp_ne p1 p2 "Inst40" atentry); - ignore (build_icmp Icmp_sle p2 p1 "Inst41" atentry); - ignore (build_fcmp Fcmp_false f1 f2 "Inst42" atentry); - ignore (build_fcmp Fcmp_true f2 f1 "Inst43" atentry) + ignore (build_icmp Icmp.Ne p1 p2 "Inst40" atentry); + ignore (build_icmp Icmp.Sle p2 p1 "Inst41" atentry); + ignore (build_fcmp Fcmp.False f1 f2 "Inst42" atentry); + ignore (build_fcmp Fcmp.True f2 f1 "Inst43" atentry) end; group "miscellaneous"; begin - (* RUN: grep {Inst45.*call.*P2.*P1} < %t.ll + (* RUN: grep {CallInst.*call.*P2.*P1} < %t.ll + * RUN: grep {CallInst.*cc63} < %t.ll * RUN: grep {Inst47.*select.*Inst46.*P1.*P2} < %t.ll * RUN: grep {Inst48.*va_arg.*null.*i32} < %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 *) - ignore (build_call fn [| p2; p1 |] "Inst45" atentry); - let inst46 = build_icmp Icmp_eq p1 p2 "Inst46" atentry in + 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); ignore (build_va_arg (const_null (pointer_type (pointer_type i8_type))) @@ -805,8 +1034,32 @@ let test_builder () = let test_module_provider () = let m = create_module "test" in - let mp = create_module_provider m in - dispose_module_provider mp + let mp = ModuleProvider.create m in + 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 ------------------------------------------------------------===*) @@ -820,19 +1073,23 @@ let test_writer () = group "writer"; insist (write_bitcode_file m filename); - dispose_module m + ModuleProvider.dispose mp (*===-- Driver ------------------------------------------------------------===*) let _ = + suite "target" test_target; suite "types" test_types; suite "constants" test_constants; 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