diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index 779066bddc1..e19228afac2 100644 --- a/bindings/ocaml/llvm/llvm.ml +++ b/bindings/ocaml/llvm/llvm.ml @@ -314,6 +314,11 @@ external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue" external value_is_block : llvalue -> bool = "llvm_value_is_block" external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock" +(*--... Operations on phi nodes ............................................--*) +external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit + = "llvm_add_incoming" +external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming" + (*===-- Instruction builders ----------------------------------------------===*) external builder_before : llvalue -> llbuilder = "llvm_builder_before" @@ -422,7 +427,8 @@ external build_fcmp : real_predicate -> llvalue -> llvalue -> string -> llbuilder -> llvalue = "llvm_build_fcmp" (*--... Miscellaneous instructions .........................................--*) -external build_phi : lltype -> string -> llbuilder -> llvalue = "llvm_build_phi" +external build_phi : (llvalue * llbasicblock) list -> string -> llbuilder -> + llvalue = "llvm_build_phi" external build_call : llvalue -> llvalue array -> string -> llbuilder -> llvalue = "llvm_build_call" external build_select : llvalue -> llvalue -> llvalue -> string -> llbuilder -> diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index 5e55b200b17..abb90f24c8c 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -295,6 +295,11 @@ external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue" external value_is_block : llvalue -> bool = "llvm_value_is_block" external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock" +(*--... Operations on phi nodes ............................................--*) +external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit + = "llvm_add_incoming" +external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming" + (*===-- Instruction builders ----------------------------------------------===*) external builder_before : llvalue -> llbuilder = "llvm_builder_before" @@ -403,7 +408,8 @@ external build_fcmp : real_predicate -> llvalue -> llvalue -> string -> llbuilder -> llvalue = "llvm_build_fcmp" (*--... Miscellaneous instructions .........................................--*) -external build_phi : lltype -> string -> llbuilder -> llvalue = "llvm_build_phi" +external build_phi : (llvalue * llbasicblock) list -> string -> llbuilder -> + llvalue = "llvm_build_phi" external build_call : llvalue -> llvalue array -> string -> llbuilder -> llvalue = "llvm_build_call" external build_select : llvalue -> llvalue -> llvalue -> string -> llbuilder -> diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index 98354fc84cd..ddf577adb29 100644 --- a/bindings/ocaml/llvm/llvm_ocaml.c +++ b/bindings/ocaml/llvm/llvm_ocaml.c @@ -21,6 +21,7 @@ #include "caml/mlvalues.h" #include "caml/memory.h" #include "llvm/Config/config.h" +#include /*===-- Modules -----------------------------------------------------------===*/ @@ -572,6 +573,39 @@ CAMLprim value llvm_value_is_block(LLVMValueRef Val) { return Val_bool(LLVMValueIsBasicBlock(Val)); } +/*--... Operations on phi nodes ............................................--*/ + +/* (llvalue * llbasicblock) -> llvalue -> unit */ +CAMLprim value llvm_add_incoming(value Incoming, LLVMValueRef PhiNode) { + LLVMAddIncoming(PhiNode, + (LLVMValueRef*) &Field(Incoming, 0), + (LLVMBasicBlockRef*) &Field(Incoming, 1), + 1); + return Val_unit; +} + +/* llvalue -> (llvalue * llbasicblock) list */ +CAMLprim value llvm_incoming(LLVMValueRef PhiNode) { + unsigned I; + CAMLparam0(); + CAMLlocal3(Hd, Tl, Tmp); + + /* Build a tuple list of them. */ + Tl = Val_int(0); + for (I = LLVMCountIncoming(PhiNode); I != 0; ) { + Hd = alloc(2, 0); + Store_field(Hd, 0, (value) LLVMGetIncomingValue(PhiNode, --I)); + Store_field(Hd, 1, (value) LLVMGetIncomingBlock(PhiNode, I)); + + Tmp = alloc(2, 0); + Store_field(Tmp, 0, Hd); + Store_field(Tmp, 1, Tl); + Tl = Tmp; + } + + CAMLreturn(Tl); +} + /*===-- Instruction builders ----------------------------------------------===*/ @@ -933,10 +967,25 @@ CAMLprim LLVMValueRef llvm_build_fcmp(value Pred, /*--... Miscellaneous instructions .........................................--*/ -/* lltype -> string -> llbuilder -> llvalue */ -CAMLprim LLVMValueRef llvm_build_phi(LLVMTypeRef Ty, - value Name, value B) { - return LLVMBuildPhi(Builder_val(B), Ty, String_val(Name)); +/* (llvalue * llbasicblock) list -> string -> llbuilder -> llvalue */ +CAMLprim LLVMValueRef llvm_build_phi(value Incoming, value Name, value B) { + value Hd, Tl; + LLVMValueRef FirstValue, PhiNode; + + assert(Incoming != Val_int(0) && "Empty list passed to Llvm.build_phi!"); + + Hd = Field(Incoming, 0); + FirstValue = (LLVMValueRef) Field(Hd, 0); + PhiNode = LLVMBuildPhi(Builder_val(B), LLVMTypeOf(FirstValue), + String_val(Name)); + + for (Tl = Incoming; Tl != Val_int(0); Tl = Field(Tl, 1)) { + value Hd = Field(Tl, 0); + LLVMAddIncoming(PhiNode, (LLVMValueRef*) &Field(Hd, 0), + (LLVMBasicBlockRef*) &Field(Hd, 1), 1); + } + + return PhiNode; } /* llvalue -> llvalue array -> string -> llbuilder -> llvalue */ diff --git a/include/llvm-c/Core.h b/include/llvm-c/Core.h index d8bff3211a3..a9228bcfc30 100644 --- a/include/llvm-c/Core.h +++ b/include/llvm-c/Core.h @@ -352,6 +352,12 @@ LLVMBasicBlockRef LLVMInsertBasicBlock(LLVMBasicBlockRef InsertBeforeBB, const char *Name); void LLVMDeleteBasicBlock(LLVMBasicBlockRef BB); +/* Operations on phi nodes */ +void LLVMAddIncoming(LLVMValueRef PhiNode, LLVMValueRef *IncomingValues, + LLVMBasicBlockRef *IncomingBlocks, unsigned Count); +unsigned LLVMCountIncoming(LLVMValueRef PhiNode); +LLVMValueRef LLVMGetIncomingValue(LLVMValueRef PhiNode, unsigned Index); +LLVMBasicBlockRef LLVMGetIncomingBlock(LLVMValueRef PhiNode, unsigned Index); /*===-- Instruction builders ----------------------------------------------===*/ diff --git a/lib/VMCore/Core.cpp b/lib/VMCore/Core.cpp index 34a0e13a2be..61ff6a8c00d 100644 --- a/lib/VMCore/Core.cpp +++ b/lib/VMCore/Core.cpp @@ -562,7 +562,6 @@ void LLVMSetThreadLocal(LLVMValueRef GlobalVar, int IsThreadLocal) { } int LLVMIsGlobalConstant(LLVMValueRef GlobalVar) { - bool res = unwrap(GlobalVar)->isConstant(); return unwrap(GlobalVar)->isConstant(); } @@ -684,6 +683,27 @@ void LLVMSetInstructionCallConv(LLVMValueRef Instr, unsigned CC) { assert(0 && "LLVMSetInstructionCallConv applies only to call and invoke!"); } +/*--.. Operations on phi nodes .............................................--*/ + +void LLVMAddIncoming(LLVMValueRef PhiNode, LLVMValueRef *IncomingValues, + LLVMBasicBlockRef *IncomingBlocks, unsigned Count) { + PHINode *PhiVal = unwrap(PhiNode); + for (unsigned I = 0; I != Count; ++I) + PhiVal->addIncoming(unwrap(IncomingValues[I]), unwrap(IncomingBlocks[I])); +} + +unsigned LLVMCountIncoming(LLVMValueRef PhiNode) { + return unwrap(PhiNode)->getNumIncomingValues(); +} + +LLVMValueRef LLVMGetIncomingValue(LLVMValueRef PhiNode, unsigned Index) { + return wrap(unwrap(PhiNode)->getIncomingValue(Index)); +} + +LLVMBasicBlockRef LLVMGetIncomingBlock(LLVMValueRef PhiNode, unsigned Index) { + return wrap(unwrap(PhiNode)->getIncomingBlock(Index)); +} + /*===-- Instruction builders ----------------------------------------------===*/ diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml index 4280b1c9f37..5c24992929a 100644 --- a/test/Bindings/Ocaml/vmcore.ml +++ b/test/Bindings/Ocaml/vmcore.ml @@ -1,4 +1,4 @@ -(* RUN: %ocamlc llvm.cma llvm_bitwriter.cma %s -o %t +(* RUN: %ocamlc llvm.cma llvm_analysis.cma llvm_bitwriter.cma %s -o %t * RUN: ./%t %t.bc * RUN: llvm-dis < %t.bc > %t.ll *) @@ -467,7 +467,7 @@ let test_functions () = let fn = define_function "Fn3" ty m in insist (not (is_declaration fn)); insist (1 = Array.length (basic_blocks fn)); - (* this function is not valid because init bb lacks a terminator *) + ignore (build_unreachable (builder_at_end (entry_block fn))); (* RUN: grep {define.*Fn4.*Param1.*Param2} < %t.ll *) @@ -481,7 +481,7 @@ let test_functions () = insist (i64_type = type_of params.(1)); set_value_name "Param1" params.(0); set_value_name "Param2" params.(1); - (* this function is not valid because init bb lacks a terminator *) + ignore (build_unreachable (builder_at_end (entry_block fn))); (* RUN: grep {fastcc.*Fn5} < %t.ll *) @@ -489,7 +489,8 @@ let test_functions () = 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 (fastcc = function_call_conv fn); + ignore (build_unreachable (builder_at_end (entry_block fn))) (*===-- Basic Blocks ------------------------------------------------------===*) @@ -503,6 +504,7 @@ let test_basic_blocks () = let fn = declare_function "X" ty m in let bb = append_block "Bb1" fn in insist (bb = entry_block fn); + ignore (build_unreachable (builder_at_end bb)); (* RUN: grep -v Bb2 < %t.ll *) @@ -513,15 +515,18 @@ let test_basic_blocks () = group "insert"; let fn = declare_function "X3" ty m in - let bbb = append_block "" fn in - let bba = insert_block "" bbb in + let bbb = append_block "b" fn in + let bba = insert_block "a" bbb in insist ([| bba; bbb |] = basic_blocks fn); + ignore (build_unreachable (builder_at_end bba)); + ignore (build_unreachable (builder_at_end 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)); let bbv = value_of_block bb in set_value_name "Bb3" bbv; insist ("Bb3" = value_name bbv); @@ -529,6 +534,7 @@ 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)); 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))) @@ -650,7 +656,8 @@ let test_builder () = let inst16 = build_or p1 inst15 "Inst16" b in let inst17 = build_xor p1 inst16 "Inst17" b in let inst18 = build_neg inst17 "Inst18" b in - ignore (build_not inst18 "Inst19" b) + ignore (build_not inst18 "Inst19" b); + ignore (build_unreachable b) end; group "memory"; begin @@ -673,7 +680,8 @@ let test_builder () = ignore(build_free inst20 b); ignore(build_load inst21 "Inst25" b); ignore(build_store p2 inst22 b); - ignore(build_gep inst23 [| p2 |] "Inst27" b) + ignore(build_gep inst23 [| p2 |] "Inst27" b); + ignore(build_unreachable b) end; group "casts"; begin @@ -724,11 +732,8 @@ let test_builder () = * 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.*Vec3} < %t.ll + * RUN: grep {Inst51.*shufflevector.*Vec1.*Vec2.*1.*1.*0.*0} < %t.ll *) - - (* TODO: %Inst44 = Phi *) - ignore (build_call fn [| p2; p1 |] "Inst45" atentry); let inst46 = build_icmp Icmp_eq p1 p2 "Inst46" atentry in ignore (build_select inst46 p1 p2 "Inst47" atentry); @@ -737,8 +742,8 @@ let test_builder () = i32_type "Inst48" atentry); (* Set up some vector vregs. *) - let one = const_int i32_type (-1) in - let zero = const_int i32_type 1 in + let one = const_int i32_type 1 in + let zero = const_int i32_type 0 in let t1 = const_vector [| one; zero; one; zero |] in let t2 = const_vector [| zero; one; zero; one |] in let t3 = const_vector [| one; one; zero; zero |] in @@ -748,13 +753,38 @@ let test_builder () = ignore (build_extractelement vec1 p2 "Inst49" atentry); ignore (build_insertelement vec1 p1 p2 "Inst50" atentry); - ignore (build_shufflevector vec1 vec2 vec3 "Inst51" atentry); + ignore (build_shufflevector vec1 vec2 t3 "Inst51" atentry); + end; + + 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 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 phi = build_phi [(p1, b1)] "PhiNode" at_jb in + insist ([(p1, b1)] = incoming phi); + + add_incoming (p2, b2) phi; + insist ([(p1, b1); (p2, b2)] = incoming phi); + + ignore (build_unreachable at_jb); end (*===-- Writer ------------------------------------------------------------===*) let test_writer () = + group "valid"; + insist (match Llvm_analysis.verify_module m with + | None -> true + | Some msg -> prerr_string msg; false); + group "writer"; insist (write_bitcode_file m filename);