X-Git-Url: http://plrg.eecs.uci.edu/git/?p=oota-llvm.git;a=blobdiff_plain;f=test%2FBindings%2FOcaml%2Fvmcore.ml;h=da3fa656f450985a28cc772104589704ba261b94;hp=24846b68bb85b07ba2216a125799433b299080c6;hb=d2b4aff4bca23ff5dadf180281a74902a18fcf73;hpb=21491edbf4027df4db559eb1a9aa8fbf3779cfab diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml index 24846b68bb8..da3fa656f45 100644 --- a/test/Bindings/Ocaml/vmcore.ml +++ b/test/Bindings/Ocaml/vmcore.ml @@ -1,9 +1,9 @@ -(* RUN: %ocamlc -warn-error A llvm.cma llvm_analysis.cma llvm_bitwriter.cma %s -o %t +(* RUN: %ocamlopt -warn-error A llvm.cmxa llvm_analysis.cmxa llvm_bitwriter.cmxa %s -o %t * RUN: ./%t %t.bc * RUN: llvm-dis < %t.bc > %t.ll *) -(* Note: It takes several seconds for ocamlc to link an executable with +(* 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. *) @@ -17,6 +17,16 @@ let suite_name = ref "" let group_name = ref "" let case_num = ref 0 let print_checkpoints = false +let context = global_context () +let i1_type = Llvm.i1_type context +let i8_type = Llvm.i8_type context +let i16_type = Llvm.i16_type context +let i32_type = Llvm.i32_type context +let i64_type = Llvm.i64_type context +let void_type = Llvm.void_type context +let float_type = Llvm.float_type context +let double_type = Llvm.double_type context +let fp128_type = Llvm.fp128_type context let group name = group_name := !suite_name ^ "/" ^ name; @@ -47,7 +57,7 @@ let suite name f = (*===-- Fixture -----------------------------------------------------------===*) let filename = Sys.argv.(1) -let m = create_module filename +let m = create_module context filename let mp = ModuleProvider.create m @@ -93,7 +103,7 @@ let test_types () = (* RUN: grep {Ty04.*i42} < %t.ll *) group "i42"; - let ty = integer_type 42 in + let ty = integer_type context 42 in insist (define_type_name "Ty04" ty m); (* RUN: grep {Ty05.*float} < %t.ll @@ -164,22 +174,22 @@ let test_types () = (* RUN: grep {Ty12.*opaque} < %t.ll *) group "opaque"; - let ty = opaque_type () in + let ty = opaque_type context in insist (define_type_name "Ty12" ty m); insist (ty == ty); - insist (ty <> opaque_type ()); + insist (ty <> opaque_type context); (* RUN: grep -v {Ty13} < %t.ll *) group "delete"; - let ty = opaque_type () in + let ty = opaque_type context in insist (define_type_name "Ty13" ty m); delete_type_name "Ty13" m; (* RUN: grep -v {RecursiveTy.*RecursiveTy} < %t.ll *) group "recursive"; - let ty = opaque_type () in + let ty = opaque_type context in let th = handle_to_type ty in refine_type ty (pointer_type ty); let ty = type_of_handle th in @@ -212,22 +222,30 @@ let test_constants () = ignore (define_global "Const03" c m); insist (i64_type = type_of c); + (* RUN: grep {ConstIntString.*i32.*-1} < %t.ll + *) + group "int string"; + let c = const_int_of_string i32_type "-1" 10 in + ignore (define_global "ConstIntString" c m); + insist (i32_type = type_of c); + (* RUN: grep {Const04.*"cruel\\\\00world"} < %t.ll *) group "string"; - let c = const_string "cruel\000world" in + let c = const_string context "cruel\000world" in ignore (define_global "Const04" c m); insist ((array_type i8_type 11) = type_of c); (* RUN: grep {Const05.*"hi\\\\00again\\\\00"} < %t.ll *) group "stringz"; - let c = const_stringz "hi\000again" in + let c = const_stringz context "hi\000again" in ignore (define_global "Const05" c m); insist ((array_type i8_type 9) = type_of c); (* RUN: grep {ConstSingle.*2.75} < %t.ll * RUN: grep {ConstDouble.*3.1459} < %t.ll + * RUN: grep {ConstDoubleString.*1.25} < %t.ll *) begin group "real"; let cs = const_float float_type 2.75 in @@ -236,6 +254,10 @@ let test_constants () = let cd = const_float double_type 3.1459 in ignore (define_global "ConstDouble" cd m); + insist (double_type = type_of cd); + + let cd = const_float_of_string double_type "1.25" in + ignore (define_global "ConstDoubleString" cd m); insist (double_type = type_of cd) end; @@ -244,34 +266,34 @@ let test_constants () = let three = const_int i32_type 3 in let four = const_int i32_type 4 in - (* RUN: grep {Const07.*\\\[ i32 3, i32 4 \\\]} < %t.ll + (* RUN: grep {Const07.*\\\[i32 3, i32 4\\\]} < %t.ll *) group "array"; let c = const_array i32_type [| three; four |] in ignore (define_global "Const07" c m); insist ((array_type i32_type 2) = (type_of c)); - (* RUN: grep {Const08.*< i16 1, i16 2.* >} < %t.ll + (* RUN: grep {Const08.*} < %t.ll *) group "vector"; let c = const_vector [| one; two; one; two; one; two; one; two |] 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 1, i16 2, i32 3, i32 4} < %t.ll *) group "structure"; - let c = const_struct [| one; two; three; four |] in + let c = const_struct context [| one; two; three; four |] in ignore (define_global "Const09" c m); - insist ((struct_type [| i16_type; i16_type; i32_type; i32_type |]) + insist ((struct_type context [| i16_type; i16_type; i32_type; i32_type |]) = (type_of c)); (* RUN: grep {Const10.*zeroinit} < %t.ll *) group "null"; - let c = const_null (packed_struct_type [| i1_type; i8_type; - i64_type; double_type |]) in + let c = const_null (packed_struct_type context [| i1_type; i8_type; i64_type; + double_type |]) in ignore (define_global "Const10" c m); (* RUN: grep {Const11.*-1} < %t.ll @@ -343,7 +365,7 @@ let test_constants () = * RUN: grep {ConstIntToPtr.*inttoptr} < %t.ll * RUN: grep {ConstBitCast.*bitcast} < %t.ll *) - let i128_type = integer_type 128 in + let i128_type = integer_type context 128 in ignore (define_global "ConstTrunc" (const_trunc (const_add foldbomb five) i8_type) m); ignore (define_global "ConstSExt" (const_sext foldbomb i128_type) m); @@ -484,7 +506,7 @@ let test_global_variables () = insist (is_global_constant g); begin group "iteration"; - let m = create_module "temp" in + let m = create_module context "temp" in insist (At_end m = global_begin m); insist (At_start m = global_end m); @@ -544,7 +566,7 @@ let test_functions () = let fn = define_function "Fn3" ty m in insist (not (is_declaration fn)); insist (1 = Array.length (basic_blocks fn)); - ignore (build_unreachable (builder_at_end (entry_block fn))); + ignore (build_unreachable (builder_at_end context (entry_block fn))); (* RUN: grep {define.*Fn4.*Param1.*Param2} < %t.ll *) @@ -558,7 +580,7 @@ let test_functions () = insist (i64_type = type_of params.(1)); set_value_name "Param1" params.(0); set_value_name "Param2" params.(1); - ignore (build_unreachable (builder_at_end (entry_block fn))); + ignore (build_unreachable (builder_at_end context (entry_block fn))); (* RUN: grep {fastcc.*Fn5} < %t.ll *) @@ -567,23 +589,23 @@ let test_functions () = 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))); + ignore (build_unreachable (builder_at_end context (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; - ignore (build_unreachable (builder_at_end (entry_block 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 context (entry_block fn))); end; begin group "iteration"; - let m = create_module "temp" in + let m = create_module context "temp" in insist (At_end m = function_begin m); insist (At_start m = function_end m); @@ -613,7 +635,7 @@ let test_functions () = let test_params () = begin group "iteration"; - let m = create_module "temp" in + let m = create_module context "temp" in let vf = define_function "void" (function_type void_type [| |]) m in @@ -626,7 +648,13 @@ let test_params () = let p2 = param f 1 in set_value_name "One" p1; set_value_name "Two" p2; - + add_param_attr p1 Attribute.Sext; + add_param_attr p2 Attribute.Noalias; + remove_param_attr p2 Attribute.Noalias; + add_function_attr f Attribute.Nounwind; + add_function_attr f Attribute.Noreturn; + remove_function_attr f Attribute.Noreturn; + insist (Before p1 = param_begin f); insist (Before p2 = param_succ p1); insist (At_end f = param_succ p2); @@ -654,31 +682,31 @@ let test_basic_blocks () = *) group "entry"; let fn = declare_function "X" ty m in - let bb = append_block "Bb1" fn in + let bb = append_block context "Bb1" fn in insist (bb = entry_block fn); - ignore (build_unreachable (builder_at_end bb)); + ignore (build_unreachable (builder_at_end context bb)); (* RUN: grep -v Bb2 < %t.ll *) group "delete"; let fn = declare_function "X2" ty m in - let bb = append_block "Bb2" fn in + let bb = append_block context "Bb2" fn in delete_block bb; group "insert"; let fn = declare_function "X3" ty m in - let bbb = append_block "b" fn in - let bba = insert_block "a" bbb in + let bbb = append_block context "b" fn in + let bba = insert_block context "a" bbb in insist ([| bba; bbb |] = basic_blocks fn); - ignore (build_unreachable (builder_at_end bba)); - ignore (build_unreachable (builder_at_end bbb)); + ignore (build_unreachable (builder_at_end context bba)); + ignore (build_unreachable (builder_at_end context bbb)); (* RUN: grep Bb3 < %t.ll *) group "name/value"; let fn = define_function "X4" ty m in let bb = entry_block fn in - ignore (build_unreachable (builder_at_end bb)); + ignore (build_unreachable (builder_at_end context bb)); let bbv = value_of_block bb in set_value_name "Bb3" bbv; insist ("Bb3" = value_name bbv); @@ -686,20 +714,20 @@ let test_basic_blocks () = group "casts"; let fn = define_function "X5" ty m in let bb = entry_block fn in - ignore (build_unreachable (builder_at_end bb)); + ignore (build_unreachable (builder_at_end context 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))); begin group "iteration"; - let m = create_module "temp" in + let m = create_module context "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 + let b1 = append_block context "One" f in + let b2 = append_block context "Two" f in insist (Before b1 = block_begin f); insist (Before b2 = block_succ b1); @@ -723,11 +751,11 @@ let test_basic_blocks () = let test_instructions () = begin group "iteration"; - let m = create_module "temp" in + let m = create_module context "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 + let b = builder_at context (At_end bb) in insist (At_end bb = instr_begin bb); insist (At_start bb = instr_end bb); @@ -760,7 +788,7 @@ let test_builder () = begin group "parent"; insist (try - ignore (insertion_block (builder ())); + ignore (insertion_block (builder context)); false with Not_found -> true); @@ -768,7 +796,7 @@ let test_builder () = 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 b = builder_at_end context bb in let p = param fn 0 in let sum = build_add p p "sum" b in ignore (build_ret_void b); @@ -785,21 +813,21 @@ let test_builder () = *) let fty = function_type void_type [| |] in let fn = declare_function "X6" fty m in - let b = builder_at_end (append_block "Bb01" fn) in + let b = builder_at_end context (append_block context "Bb01" fn) in ignore (build_ret_void b) end; (* The rest of the tests will use one big function. *) let fty = function_type i32_type [| i32_type; i32_type |] in let fn = define_function "X7" fty m in - let atentry = builder_at_end (entry_block fn) in + let atentry = builder_at_end context (entry_block fn) in let p1 = param fn 0 ++ set_value_name "P1" in let p2 = param fn 1 ++ set_value_name "P2" in let f1 = build_uitofp p1 float_type "F1" atentry in let f2 = build_uitofp p2 float_type "F2" atentry in - let bb00 = append_block "Bb00" fn in - ignore (build_unreachable (builder_at_end bb00)); + let bb00 = append_block context "Bb00" fn in + ignore (build_unreachable (builder_at_end context bb00)); group "ret"; begin (* RUN: grep {ret.*P1} < %t.ll @@ -811,16 +839,16 @@ let test_builder () = group "br"; begin (* RUN: grep {br.*Bb02} < %t.ll *) - let bb02 = append_block "Bb02" fn in - let b = builder_at_end bb02 in + let bb02 = append_block context "Bb02" fn in + let b = builder_at_end context bb02 in ignore (build_br bb02 b) end; group "cond_br"; begin (* RUN: grep {br.*Inst01.*Bb03.*Bb00} < %t.ll *) - let bb03 = append_block "Bb03" fn in - let b = builder_at_end bb03 in + let bb03 = append_block context "Bb03" fn in + let b = builder_at_end context bb03 in let cond = build_trunc p1 i1_type "Inst01" b in ignore (build_cond_br cond bb03 bb00 b) end; @@ -829,12 +857,12 @@ let test_builder () = (* 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 + let bb1 = append_block context "SwiBlock1" fn in + let bb2 = append_block context "SwiBlock2" fn in + ignore (build_unreachable (builder_at_end context bb2)); + let bb3 = append_block context "SwiBlock3" fn in + ignore (build_unreachable (builder_at_end context bb3)); + let si = build_switch p1 bb3 1 (builder_at_end context bb1) in ignore (add_case si (const_int i32_type 2) bb2) end; @@ -842,30 +870,30 @@ let test_builder () = (* RUN: grep {Inst02.*invoke.*P1.*P2} < %t.ll * RUN: grep {to.*Bb04.*unwind.*Bb00} < %t.ll *) - let bb04 = append_block "Bb04" fn in - let b = builder_at_end bb04 in + let bb04 = append_block context "Bb04" fn in + let b = builder_at_end context bb04 in ignore (build_invoke fn [| p1; p2 |] bb04 bb00 "Inst02" b) end; group "unwind"; begin (* RUN: grep {unwind} < %t.ll *) - let bb05 = append_block "Bb05" fn in - let b = builder_at_end bb05 in + let bb05 = append_block context "Bb05" fn in + let b = builder_at_end context bb05 in ignore (build_unwind b) end; group "unreachable"; begin (* RUN: grep {unreachable} < %t.ll *) - let bb06 = append_block "Bb06" fn in - let b = builder_at_end bb06 in + let bb06 = append_block context "Bb06" fn in + let b = builder_at_end context bb06 in ignore (build_unreachable b) end; group "arithmetic"; begin - let bb07 = append_block "Bb07" fn in - let b = builder_at_end bb07 in + let bb07 = append_block context "Bb07" fn in + let b = builder_at_end context bb07 in (* RUN: grep {Inst03.*add.*P1.*P2} < %t.ll * RUN: grep {Inst04.*sub.*P1.*Inst03} < %t.ll @@ -906,24 +934,18 @@ let test_builder () = end; group "memory"; begin - let bb08 = append_block "Bb08" fn in - let b = builder_at_end bb08 in - - (* RUN: grep {Inst20.*malloc.*i8 } < %t.ll - * RUN: grep {Inst21.*malloc.*i8.*P1} < %t.ll - * RUN: grep {Inst22.*alloca.*i32 } < %t.ll + let bb08 = append_block context "Bb08" fn in + let b = builder_at_end context bb08 in + + (* RUN: grep {Inst22.*alloca.*i32 } < %t.ll * RUN: grep {Inst23.*alloca.*i32.*P2} < %t.ll - * RUN: grep {free.*Inst20} < %t.ll - * RUN: grep {Inst25.*load.*Inst21} < %t.ll + * RUN: grep {Inst25.*load.*Inst23} < %t.ll * RUN: grep {store.*P2.*Inst22} < %t.ll * RUN: grep {Inst27.*getelementptr.*Inst23.*P2} < %t.ll *) - let inst20 = build_malloc i8_type "Inst20" b in - let inst21 = build_array_malloc i8_type p1 "Inst21" b in let inst22 = build_alloca i32_type "Inst22" b in let inst23 = build_array_alloca i32_type p2 "Inst23" b in - ignore(build_free inst20 b); - ignore(build_load inst21 "Inst25" b); + ignore(build_load inst23 "Inst25" b); ignore(build_store p2 inst22 b); ignore(build_gep inst23 [| p2 |] "Inst27" b); ignore(build_unreachable b) @@ -979,11 +1001,18 @@ let test_builder () = * 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); + add_instruction_param_attr ci 1 Attribute.Sext; + add_instruction_param_attr ci 2 Attribute.Noalias; + remove_instruction_param_attr ci 2 Attribute.Noalias; let inst46 = build_icmp Icmp.Eq p1 p2 "Inst46" atentry in ignore (build_select inst46 p1 p2 "Inst47" atentry); @@ -1008,13 +1037,13 @@ let test_builder () = group "phi"; begin (* RUN: grep {PhiNode.*P1.*PhiBlock1.*P2.*PhiBlock2} < %t.ll *) - let b1 = append_block "PhiBlock1" fn in - let b2 = append_block "PhiBlock2" fn in + let b1 = append_block context "PhiBlock1" fn in + let b2 = append_block context "PhiBlock2" fn in - let jb = append_block "PhiJoinBlock" fn in - ignore (build_br jb (builder_at_end b1)); - ignore (build_br jb (builder_at_end b2)); - let at_jb = builder_at_end jb in + let jb = append_block context "PhiJoinBlock" fn in + ignore (build_br jb (builder_at_end context b1)); + ignore (build_br jb (builder_at_end context b2)); + let at_jb = builder_at_end context jb in let phi = build_phi [(p1, b1)] "PhiNode" at_jb in insist ([(p1, b1)] = incoming phi); @@ -1029,7 +1058,7 @@ let test_builder () = (*===-- Module Provider ---------------------------------------------------===*) let test_module_provider () = - let m = create_module "test" in + let m = create_module context "test" in let mp = ModuleProvider.create m in ModuleProvider.dispose mp @@ -1048,7 +1077,7 @@ let test_pass_manager () = 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 (build_ret_void (builder_at_end context (entry_block fn))); ignore (PassManager.create_function mp ++ PassManager.initialize