From: Torok Edwin Date: Fri, 14 Oct 2011 20:38:33 +0000 (+0000) Subject: OCaml bindings: add some missing functions and testcases. X-Git-Url: http://plrg.eecs.uci.edu/git/?p=oota-llvm.git;a=commitdiff_plain;h=ff616cb440d696b2663d55494e0a5aedfab20726 OCaml bindings: add some missing functions and testcases. The C bindings exposed some APIs that weren't covered by the OCaml bindings git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@141997 91177308-0d34-0410-b5e6-96231b3b80d8 --- diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index 2f4b4ae87cb..40b01386366 100644 --- a/bindings/ocaml/llvm/llvm.ml +++ b/bindings/ocaml/llvm/llvm.ml @@ -261,6 +261,7 @@ external set_data_layout: string -> llmodule -> unit external dump_module : llmodule -> unit = "llvm_dump_module" external set_module_inline_asm : llmodule -> string -> unit = "llvm_set_module_inline_asm" +external module_context : llmodule -> llcontext = "LLVMGetModuleContext" (*===-- Types -------------------------------------------------------------===*) external classify_type : lltype -> TypeKind.t = "llvm_classify_type" @@ -321,6 +322,7 @@ external vector_size : lltype -> int = "llvm_vector_size" (*--... Operations on other types ..........................................--*) external void_type : llcontext -> lltype = "llvm_void_type" external label_type : llcontext -> lltype = "llvm_label_type" +external type_by_name : llmodule -> string -> lltype option = "llvm_type_by_name" external classify_value : llvalue -> ValueKind.t = "llvm_classify_value" (*===-- Values ------------------------------------------------------------===*) @@ -812,6 +814,8 @@ external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos = "llvm_block_end" external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos = "llvm_block_pred" +external block_terminator : llbasicblock -> llvalue option = + "llvm_block_terminator" let rec iter_block_range f i e = if i = e then () else @@ -936,6 +940,7 @@ external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit = "llvm_add_incoming" external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming" +external delete_instruction : llvalue -> unit = "llvm_delete_instruction" (*===-- Instruction builders ----------------------------------------------===*) external builder : llcontext -> llbuilder = "llvm_builder" @@ -978,8 +983,15 @@ external build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder -> llvalue = "llvm_build_cond_br" external build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue = "llvm_build_switch" +external build_malloc : lltype -> string -> llbuilder -> llvalue = + "llvm_build_malloc" +external build_array_malloc : lltype -> llvalue -> string -> llbuilder -> + llvalue = "llvm_build_array_malloc" +external build_free : llvalue -> llbuilder -> llvalue = "llvm_build_free" external add_case : llvalue -> llvalue -> llbasicblock -> unit = "llvm_add_case" +external switch_default_dest : llvalue -> llbasicblock = + "LLVMGetSwitchDefaultDest" external build_indirect_br : llvalue -> int -> llbuilder -> llvalue = "llvm_build_indirect_br" external add_destination : llvalue -> llbasicblock -> unit @@ -990,6 +1002,8 @@ external build_invoke : llvalue -> llvalue array -> llbasicblock -> external build_landingpad : lltype -> llvalue -> int -> string -> llbuilder -> llvalue = "llvm_build_landingpad" external set_cleanup : llvalue -> bool -> unit = "llvm_set_cleanup" +external add_clause : llvalue -> llvalue -> unit = "llvm_add_clause" +external build_resume : llvalue -> llbuilder -> llvalue = "llvm_build_resume" external build_unreachable : llbuilder -> llvalue = "llvm_build_unreachable" (*--... Arithmetic .........................................................--*) diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index a90a72b771a..33bbc74deb1 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -363,7 +363,9 @@ val dump_module : llmodule -> unit the method [llvm::Module::setModuleInlineAsm]. *) val set_module_inline_asm : llmodule -> string -> unit - +(** [module_context m] returns the context of the specified module. + * See the method [llvm::Module::getContext] *) +val module_context : llmodule -> llcontext (** {6 Types} *) @@ -552,6 +554,11 @@ val void_type : llcontext -> lltype [llvm::Type::LabelTy]. *) val label_type : llcontext -> lltype +(** [type_by_name m name] returns the specified type from the current module + * if it exists. + * See the method [llvm::Module::getTypeByName] *) +val type_by_name : llmodule -> string -> lltype option + (* {6 Values} *) (** [type_of v] returns the type of the value [v]. @@ -1508,6 +1515,7 @@ val block_end : llvalue -> (llvalue, llbasicblock) llrev_pos See the method [llvm::Function::iterator::operator--]. *) val block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos +val block_terminator : llbasicblock -> llvalue option (** [rev_iter_blocks f fn] applies function [f] to each of the basic blocks of function [fn] in reverse order. Tail recursive. *) @@ -1625,7 +1633,9 @@ val add_incoming : (llvalue * llbasicblock) -> llvalue -> unit See the method [llvm::PHINode::getIncomingValue]. *) val incoming : llvalue -> (llvalue * llbasicblock) list - +(** [delete_instruction i] deletes the instruction [i]. + * See the method [llvm::Instruction::eraseFromParent]. *) +val delete_instruction : llvalue -> unit (** {6 Instruction builders} *) @@ -1739,12 +1749,30 @@ val build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder -> See the method [llvm::LLVMBuilder::CreateSwitch]. *) val build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue +(** [build_malloc ty name b] creates an [malloc] + instruction at the position specified by the instruction builder [b]. + See the method [llvm::CallInst::CreateMalloc]. *) +val build_malloc : lltype -> string -> llbuilder -> llvalue + +(** [build_array_malloc ty val name b] creates an [array malloc] + instruction at the position specified by the instruction builder [b]. + See the method [llvm::CallInst::CreateArrayMalloc]. *) +val build_array_malloc : lltype -> llvalue -> string -> llbuilder -> llvalue + +(** [build_free p b] creates a [free] + instruction at the position specified by the instruction builder [b]. + See the method [llvm::LLVMBuilder::CreateFree]. *) +val build_free : llvalue -> llbuilder -> llvalue (** [add_case sw onval bb] causes switch instruction [sw] to branch to [bb] when its input matches the constant [onval]. See the method [llvm::SwitchInst::addCase]. **) val add_case : llvalue -> llvalue -> llbasicblock -> unit +(** [switch_default_dest sw] returns the default destination of the [switch] + * instruction. + * See the method [llvm:;SwitchInst::getDefaultDest]. **) +val switch_default_dest : llvalue -> llbasicblock (** [build_indirect_br addr count b] creates a [indirectbr %addr] @@ -1778,6 +1806,15 @@ val build_landingpad : lltype -> llvalue -> int -> string -> llbuilder -> See the method [llvm::LandingPadInst::setCleanup]. *) val set_cleanup : llvalue -> bool -> unit +(** [add_clause lp clause] adds the clause to the [landingpad]instruction. + See the method [llvm::LandingPadInst::addClause]. *) +val add_clause : llvalue -> llvalue -> unit + +(* [build_resume exn b] builds a [resume exn] instruction + * at the position specified by the instruction builder [b]. + * See the method [llvm::LLVMBuilder::CreateResume] *) +val build_resume : llvalue -> llbuilder -> llvalue + (** [build_unreachable b] creates an [unreachable] instruction at the position specified by the instruction builder [b]. diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index 5090bf83d19..86cc4bd0143 100644 --- a/bindings/ocaml/llvm/llvm_ocaml.c +++ b/bindings/ocaml/llvm/llvm_ocaml.c @@ -387,6 +387,18 @@ CAMLprim LLVMTypeRef llvm_label_type(LLVMContextRef Context) { return LLVMLabelTypeInContext(Context); } +CAMLprim value llvm_type_by_name(LLVMModuleRef M, value Name) +{ + CAMLparam1(Name); + LLVMTypeRef Ty = LLVMGetTypeByName(M, String_val(Name)); + if (Ty) { + value Option = alloc(1, 0); + Field(Option, 0) = (value) Ty; + CAMLreturn(Option); + } + CAMLreturn(Val_int(0)); +} + /*===-- VALUES ------------------------------------------------------------===*/ /* llvalue -> lltype */ @@ -1098,6 +1110,19 @@ CAMLprim value llvm_set_param_alignment(LLVMValueRef Arg, value align) { DEFINE_ITERATORS( block, BasicBlock, LLVMValueRef, LLVMBasicBlockRef, LLVMGetBasicBlockParent) +/* llbasicblock -> llvalue option */ +CAMLprim value llvm_block_terminator(LLVMBasicBlockRef Block) +{ + CAMLparam0(); + LLVMValueRef Term = LLVMGetBasicBlockTerminator(Block); + if (Term) { + value Option = alloc(1, 0); + Field(Option, 0) = (value) Term; + CAMLreturn(Option); + } + CAMLreturn(Val_int(0)); +} + /* llvalue -> llbasicblock array */ CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) { value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0); @@ -1232,6 +1257,11 @@ CAMLprim value llvm_incoming(LLVMValueRef PhiNode) { CAMLreturn(Tl); } +/* llvalue -> unit */ +CAMLprim value llvm_delete_instruction(LLVMValueRef Instruction) { + LLVMInstructionEraseFromParent(Instruction); + return Val_unit; +} /*===-- Instruction builders ----------------------------------------------===*/ @@ -1359,6 +1389,27 @@ CAMLprim LLVMValueRef llvm_build_switch(LLVMValueRef Of, return LLVMBuildSwitch(Builder_val(B), Of, Else, Int_val(EstimatedCount)); } +/* lltype -> string -> llbuilder -> llvalue */ +CAMLprim LLVMValueRef llvm_build_malloc(LLVMTypeRef Ty, value Name, + value B) +{ + return LLVMBuildMalloc(Builder_val(B), Ty, String_val(Name)); +} + +/* lltype -> llvalue -> string -> llbuilder -> llvalue */ +CAMLprim LLVMValueRef llvm_build_array_malloc(LLVMTypeRef Ty, + LLVMValueRef Val, + value Name, value B) +{ + return LLVMBuildArrayMalloc(Builder_val(B), Ty, Val, String_val(Name)); +} + +/* llvalue -> llbuilder -> llvalue */ +CAMLprim LLVMValueRef llvm_build_free(LLVMValueRef P, value B) +{ + return LLVMBuildFree(Builder_val(B), P); +} + /* llvalue -> llvalue -> llbasicblock -> unit */ CAMLprim value llvm_add_case(LLVMValueRef Switch, LLVMValueRef OnVal, LLVMBasicBlockRef Dest) { @@ -1399,6 +1450,7 @@ CAMLprim LLVMValueRef llvm_build_invoke_bc(value Args[], int NumArgs) { Args[4], Args[5]); } +/* lltype -> llvalue -> int -> string -> llbuilder -> llvalue */ CAMLprim LLVMValueRef llvm_build_landingpad(LLVMTypeRef Ty, LLVMValueRef PersFn, value NumClauses, value Name, value B) { @@ -1406,12 +1458,27 @@ CAMLprim LLVMValueRef llvm_build_landingpad(LLVMTypeRef Ty, LLVMValueRef PersFn, String_val(Name)); } +/* llvalue -> llvalue -> unit */ +CAMLprim value llvm_add_clause(LLVMValueRef LandingPadInst, LLVMValueRef ClauseVal) +{ + LLVMAddClause(LandingPadInst, ClauseVal); + return Val_unit; +} + + +/* llvalue -> bool -> unit */ CAMLprim value llvm_set_cleanup(LLVMValueRef LandingPadInst, value flag) { LLVMSetCleanup(LandingPadInst, Bool_val(flag)); return Val_unit; } +/* llvalue -> llbuilder -> llvalue */ +CAMLprim LLVMValueRef llvm_build_resume(LLVMValueRef Exn, value B) +{ + return LLVMBuildResume(Builder_val(B), Exn); +} + /* llbuilder -> llvalue */ CAMLprim LLVMValueRef llvm_build_unreachable(value B) { return LLVMBuildUnreachable(Builder_val(B)); diff --git a/bindings/ocaml/transforms/scalar/llvm_scalar_opts.ml b/bindings/ocaml/transforms/scalar/llvm_scalar_opts.ml index 276e1182d05..93ab1de2582 100644 --- a/bindings/ocaml/transforms/scalar/llvm_scalar_opts.ml +++ b/bindings/ocaml/transforms/scalar/llvm_scalar_opts.ml @@ -20,6 +20,15 @@ external add_aggressive_dce : [ unit external add_scalar_repl_aggregation : [ unit = "llvm_add_scalar_repl_aggregation" + +external +add_scalar_repl_aggregation_ssa : [ unit + = "llvm_add_scalar_repl_aggregation_ssa" + +external +add_scalar_repl_aggregation_with_threshold : int -> [ unit + = "llvm_add_scalar_repl_aggregation_with_threshold" external add_ind_var_simplification : [ unit = "llvm_add_ind_var_simplification" @@ -67,6 +76,36 @@ external add_memcpy_opt : [ unit = "llvm_add_loop_deletion" + +external add_loop_idiom : [ unit + = "llvm_add_loop_idiom" + external add_lib_call_simplification : [ unit = "llvm_add_lib_call_simplification" + +external +add_verifier : [ unit + = "llvm_add_verifier" + +external +add_correlated_value_propagation : [ unit + = "llvm_add_correlated_value_propagation" + +external +add_early_cse : [ unit + = "llvm_add_early_cse" + +external +add_lower_expect_intrinsic : [ unit + = "llvm_add_lower_expect_intrinsic" + +external +add_type_based_alias_analysis : [ unit + = "llvm_add_type_based_alias_analysis" + +external +add_basic_alias_analysis : [ unit + = "llvm_add_basic_alias_analysis" + diff --git a/bindings/ocaml/transforms/scalar/llvm_scalar_opts.mli b/bindings/ocaml/transforms/scalar/llvm_scalar_opts.mli index d7162c769e4..121b3761282 100644 --- a/bindings/ocaml/transforms/scalar/llvm_scalar_opts.mli +++ b/bindings/ocaml/transforms/scalar/llvm_scalar_opts.mli @@ -35,6 +35,17 @@ external add_scalar_repl_aggregation : [ unit = "llvm_add_scalar_repl_aggregation" +(** See the [llvm::createScalarReplAggregatesPassSSA] function. *) +external +add_scalar_repl_aggregation_ssa : [ unit + = "llvm_add_scalar_repl_aggregation_ssa" + +(** See the [llvm::createScalarReplAggregatesWithThreshold] function. *) +external +add_scalar_repl_aggregation_with_threshold : int -> [ unit + = "llvm_add_scalar_repl_aggregation_with_threshold" + (** See the [llvm::createIndVarSimplifyPass] function. *) external add_ind_var_simplification : [ unit @@ -112,7 +123,42 @@ external add_loop_deletion : [ unit = "llvm_add_loop_deletion" +external add_loop_idiom : [ unit + = "llvm_add_loop_idiom" + (** See the [llvm::createSimplifyLibCallsPass] function. *) external add_lib_call_simplification : [ unit = "llvm_add_lib_call_simplification" + +(** See the [llvm::createVerifierPass] function. *) +external +add_verifier : [ unit + = "llvm_add_verifier" + +(** See the [llvm::createCorrelatedValuePropagationPass] function. *) +external +add_correlated_value_propagation : [ unit + = "llvm_add_correlated_value_propagation" + +(** See the [llvm::createEarlyCSE] function. *) +external +add_early_cse : [ unit + = "llvm_add_early_cse" + +(** See the [llvm::createLowerExpectIntrinsicPass] function. *) +external +add_lower_expect_intrinsic : [ unit + = "llvm_add_lower_expect_intrinsic" + +(** See the [llvm::createTypeBasedAliasAnalysisPass] function. *) +external +add_type_based_alias_analysis : [ unit + = "llvm_add_type_based_alias_analysis" + +(** See the [llvm::createBasicAliasAnalysisPass] function. *) +external +add_basic_alias_analysis : [ unit + = "llvm_add_basic_alias_analysis" + diff --git a/bindings/ocaml/transforms/scalar/scalar_opts_ocaml.c b/bindings/ocaml/transforms/scalar/scalar_opts_ocaml.c index df44807859c..2db645624a7 100644 --- a/bindings/ocaml/transforms/scalar/scalar_opts_ocaml.c +++ b/bindings/ocaml/transforms/scalar/scalar_opts_ocaml.c @@ -49,6 +49,19 @@ CAMLprim value llvm_add_scalar_repl_aggregation(LLVMPassManagerRef PM) { return Val_unit; } +/* [ unit */ +CAMLprim value llvm_add_scalar_repl_aggregation_ssa(LLVMPassManagerRef PM) { + LLVMAddScalarReplAggregatesPassSSA(PM); + return Val_unit; +} + +/* [ int -> unit */ +CAMLprim value llvm_add_scalar_repl_aggregation_with_threshold(value threshold, + LLVMPassManagerRef PM) { + LLVMAddScalarReplAggregatesPassWithThreshold(PM, Int_val(threshold)); + return Val_unit; +} + /* [ unit */ CAMLprim value llvm_add_ind_var_simplification(LLVMPassManagerRef PM) { LLVMAddIndVarSimplifyPass(PM); @@ -69,7 +82,7 @@ CAMLprim value llvm_add_licm(LLVMPassManagerRef PM) { /* [ unit */ CAMLprim value llvm_add_loop_unswitch(LLVMPassManagerRef PM) { - LLVMAddLoopUnrollPass(PM); + LLVMAddLoopUnswitchPass(PM); return Val_unit; } @@ -139,8 +152,50 @@ CAMLprim value llvm_add_loop_deletion(LLVMPassManagerRef PM) { return Val_unit; } +/* [ unit */ +CAMLprim value llvm_add_loop_idiom(LLVMPassManagerRef PM) { + LLVMAddLoopIdiomPass(PM); + return Val_unit; +} + /* [ unit */ CAMLprim value llvm_add_lib_call_simplification(LLVMPassManagerRef PM) { LLVMAddSimplifyLibCallsPass(PM); return Val_unit; } + +/* [ unit */ +CAMLprim value llvm_add_verifier(LLVMPassManagerRef PM) { + LLVMAddVerifierPass(PM); + return Val_unit; +} + +/* [ unit */ +CAMLprim value llvm_add_correlated_value_propagation(LLVMPassManagerRef PM) { + LLVMAddCorrelatedValuePropagationPass(PM); + return Val_unit; +} + +/* [ unit */ +CAMLprim value llvm_add_early_cse(LLVMPassManagerRef PM) { + LLVMAddEarlyCSEPass(PM); + return Val_unit; +} + +/* [ unit */ +CAMLprim value llvm_add_lower_expect_intrinsic(LLVMPassManagerRef PM) { + LLVMAddLowerExpectIntrinsicPass(PM); + return Val_unit; +} + +/* [ unit */ +CAMLprim value llvm_add_type_based_alias_analysis(LLVMPassManagerRef PM) { + LLVMAddTypeBasedAliasAnalysisPass(PM); + return Val_unit; +} + +/* [ unit */ +CAMLprim value llvm_add_basic_alias_analysis(LLVMPassManagerRef PM) { + LLVMAddBasicAliasAnalysisPass(PM); + return Val_unit; +} diff --git a/test/Bindings/Ocaml/scalar_opts.ml b/test/Bindings/Ocaml/scalar_opts.ml index 1ea97858edf..34a7a6a01bd 100644 --- a/test/Bindings/Ocaml/scalar_opts.ml +++ b/test/Bindings/Ocaml/scalar_opts.ml @@ -42,11 +42,14 @@ let test_transforms () = ignore (PassManager.create_function m ++ TargetData.add td + ++ add_verifier ++ add_constant_propagation ++ add_sccp ++ add_dead_store_elimination ++ add_aggressive_dce ++ add_scalar_repl_aggregation + ++ add_scalar_repl_aggregation_ssa + ++ add_scalar_repl_aggregation_with_threshold 4 ++ add_ind_var_simplification ++ add_instruction_combination ++ add_licm @@ -62,7 +65,14 @@ let test_transforms () = ++ add_gvn ++ add_memcpy_opt ++ add_loop_deletion + ++ add_loop_idiom ++ add_lib_call_simplification + ++ add_correlated_value_propagation + ++ add_early_cse + ++ add_lower_expect_intrinsic + ++ add_type_based_alias_analysis + ++ add_basic_alias_analysis + ++ add_verifier ++ PassManager.initialize ++ PassManager.run_function fn ++ PassManager.finalize diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml index 34a7338682e..93292862866 100644 --- a/test/Bindings/Ocaml/vmcore.ml +++ b/test/Bindings/Ocaml/vmcore.ml @@ -857,6 +857,14 @@ let test_builder () = let bb00 = append_block context "Bb00" fn in ignore (build_unreachable (builder_at_end context bb00)); + group "function attribute"; + begin + ignore (add_function_attr fn Attribute.UWTable); + (* RUN: grep "X7.*uwtable" < %t.ll + *) + insist ([Attribute.UWTable] = function_attr fn); + end; + (* see test/Feature/exception.ll *) let bblpad = append_block context "Bblpad" fn in let rt = struct_type context [| pointer_type i8_type; i32_type |] in @@ -872,10 +880,17 @@ let test_builder () = let lp = build_landingpad rt personality 0 "lpad" (builder_at_end context bblpad) in begin set_cleanup lp true; - ignore (build_unreachable (builder_at_end context bblpad)); + add_clause lp ztic; + insist((pointer_type (pointer_type i8_type)) = type_of ztid); + let ety = pointer_type (pointer_type i8_type) in + add_clause lp (const_array ety [| ztipkc; ztid |]); + ignore (build_resume lp (builder_at_end context bblpad)); end; (* RUN: grep "landingpad.*personality.*__gxx_personality_v0" < %t.ll * RUN: grep "cleanup" < %t.ll + * RUN: grep "catch.*i8\*\*.*@_ZTIc" < %t.ll + * RUN: grep "filter.*@_ZTIPKc.*@_ZTId" < %t.ll + * RUN: grep "resume " < %t.ll * *) end; @@ -914,9 +929,23 @@ let test_builder () = ignore (build_unreachable (builder_at_end context bb3)); let si = build_switch p1 bb3 1 (builder_at_end context bb1) in begin ignore (add_case si (const_int i32_type 2) bb2); + insist (switch_default_dest si = bb3); end; end; + group "malloc/free"; begin + (* RUN: grep {call.*@malloc(i32 ptrtoint} < %t.ll + * RUN: grep {call.*@free(i8\*} < %t.ll + * RUN: grep {call.*@malloc(i32 %} < %t.ll + *) + let bb1 = append_block context "MallocBlock1" fn in + let m1 = (build_malloc (pointer_type i32_type) "m1" + (builder_at_end context bb1)) in + ignore (build_free m1 (builder_at_end context bb1)); + ignore (build_array_malloc i32_type p1 "m2" (builder_at_end context bb1)); + ignore (build_unreachable (builder_at_end context bb1)); + end; + group "indirectbr"; begin (* RUN: grep {indirectbr i8\\* blockaddress(@X7, %IBRBlock2), \\\[label %IBRBlock2, label %IBRBlock3\\\]} < %t.ll *)