Index: bindings/ocaml/transforms/ipo/ipo_ocaml.c =================================================================== --- bindings/ocaml/transforms/ipo/ipo_ocaml.c +++ bindings/ocaml/transforms/ipo/ipo_ocaml.c @@ -15,9 +15,14 @@ |* *| \*===----------------------------------------------------------------------===*/ -#include "llvm-c/Transforms/IPO.h" -#include "caml/mlvalues.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/memory.h" #include "caml/misc.h" +#include "caml/mlvalues.h" +#include "llvm-c/Core.h" +#include "llvm-c/Transforms/IPO.h" +#include /* [`Module] Llvm.PassManager.t -> unit */ CAMLprim value llvm_add_argument_promotion(LLVMPassManagerRef PM) { @@ -91,6 +96,33 @@ return Val_unit; } +/* string -> bool */ +static value *predicate_f = NULL; + +LLVMBool MustPreserveCallBack(LLVMValueRef Val, void *Ctx) { + CAMLparam0(); + CAMLlocal1(LLVMValName); + const char *llvmValName; + LLVMBool ret; + assert(predicate_f != NULL && + "llvm_add_internalize_predicate must be called with \ + LLVMInternalizePredicateCallback symbol set"); + + llvmValName = LLVMGetValueName(Val); + LLVMValName = caml_copy_string(llvmValName); + ret = Bool_val(caml_callback(*predicate_f, LLVMValName)); + + CAMLreturnT(LLVMBool, ret); +} + +/* [`Module] Llvm.PassManager.t -> unit */ +CAMLprim value llvm_add_internalize_predicate(LLVMPassManagerRef PM) { + predicate_f = caml_named_value("LLVMInternalizePredicateCallback"); + LLVMAddInternalizePassWithMustPreservePredicate(PM, NULL, + &MustPreserveCallBack); + return Val_unit; +} + /* [`Module] Llvm.PassManager.t -> unit */ CAMLprim value llvm_add_strip_dead_prototypes(LLVMPassManagerRef PM) { LLVMAddStripDeadPrototypesPass(PM); Index: bindings/ocaml/transforms/ipo/llvm_ipo.ml =================================================================== --- bindings/ocaml/transforms/ipo/llvm_ipo.ml +++ bindings/ocaml/transforms/ipo/llvm_ipo.ml @@ -42,6 +42,17 @@ external add_internalize : [ `Module ] Llvm.PassManager.t -> all_but_main:bool -> unit = "llvm_add_internalize" + +external add_internalize_predicate_raw + : [ `Module ] Llvm.PassManager.t -> unit + = "llvm_add_internalize_predicate" + +let add_internalize_predicate + : [ `Module ] Llvm.PassManager.t -> (string -> bool) -> unit = + fun pm predicate -> + Callback.register "LLVMInternalizePredicateCallback" predicate; + add_internalize_predicate_raw pm + external add_strip_dead_prototypes : [ `Module ] Llvm.PassManager.t -> unit = "llvm_add_strip_dead_prototypes" Index: bindings/ocaml/transforms/ipo/llvm_ipo.mli =================================================================== --- bindings/ocaml/transforms/ipo/llvm_ipo.mli +++ bindings/ocaml/transforms/ipo/llvm_ipo.mli @@ -71,6 +71,12 @@ : [ `Module ] Llvm.PassManager.t -> all_but_main:bool -> unit = "llvm_add_internalize" +(** See the [llvm::createInternalizePass] function. + If predicate returns [true], that symbol is preserved. + NOT THREAD SAFE! *) +val add_internalize_predicate + : [ `Module ] Llvm.PassManager.t -> (string -> bool) -> unit + (** See the [llvm::createStripDeadPrototypesPass] function. *) external add_strip_dead_prototypes : [ `Module ] Llvm.PassManager.t -> unit