diff options
| -rw-r--r-- | bindings/ocaml/llvm/llvm.ml | 33 | ||||
| -rw-r--r-- | bindings/ocaml/llvm/llvm.mli | 35 | ||||
| -rw-r--r-- | bindings/ocaml/llvm/llvm_ocaml.c | 36 | ||||
| -rw-r--r-- | test/Bindings/Ocaml/vmcore.ml | 28 |
4 files changed, 132 insertions, 0 deletions
diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index 0af8f48..7b906d2 100644 --- a/bindings/ocaml/llvm/llvm.ml +++ b/bindings/ocaml/llvm/llvm.ml @@ -13,6 +13,7 @@ type llmodule type lltype type lltypehandle type llvalue +type lluse type llbasicblock type llbuilder type llmoduleprovider @@ -242,6 +243,38 @@ external dump_value : llvalue -> unit = "llvm_dump_value" external replace_all_uses_with : llvalue -> llvalue -> unit = "LLVMReplaceAllUsesWith" +(*--... Operations on uses .................................................--*) +external use_begin : llvalue -> lluse option = "llvm_use_begin" +external use_succ : lluse -> lluse option = "llvm_use_succ" +external user : lluse -> llvalue = "llvm_user" +external used_value : lluse -> llvalue = "llvm_used_value" + +let iter_uses f v = + let rec aux = function + | None -> () + | Some u -> + f u; + aux (use_succ u) + in + aux (use_begin v) + +let fold_left_uses f init v = + let rec aux init u = + match u with + | None -> init + | Some u -> aux (f init u) (use_succ u) + in + aux init (use_begin v) + +let fold_right_uses f v init = + let rec aux u init = + match u with + | None -> init + | Some u -> f u (aux (use_succ u) init) + in + aux (use_begin v) init + + (*--... Operations on users ................................................--*) external operand : llvalue -> int -> llvalue = "llvm_operand" diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index 674ec9e..cf06d5a 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -39,6 +39,9 @@ type lltypehandle This type covers a wide range of subclasses. *) type llvalue +(** Used to store users and usees of values. See the [llvm::Use] class. *) +type lluse + (** A basic block in LLVM IR. See the [llvm::BasicBlock] class. *) type llbasicblock @@ -513,6 +516,38 @@ external replace_all_uses_with : llvalue -> llvalue -> unit = "LLVMReplaceAllUsesWith" +(* {6 Uses} *) + +(** [use_begin v] returns the first position in the use list for the value [v]. + [use_begin] and [use_succ] can e used to iterate over the use list in order. + See the method [llvm::Value::use_begin]. *) +external use_begin : llvalue -> lluse option = "llvm_use_begin" + +(** [use_succ u] returns the use list position succeeding [u]. + See the method [llvm::use_value_iterator::operator++]. *) +external use_succ : lluse -> lluse option = "llvm_use_succ" + +(** [user u] returns the user of the use [u]. + See the method [llvm::Use::getUser]. *) +external user : lluse -> llvalue = "llvm_user" + +(** [used_value u] returns the usee of the use [u]. + See the method [llvm::Use::getUsedValue]. *) +external used_value : lluse -> llvalue = "llvm_used_value" + +(** [iter_uses f v] applies function [f] to each of the users of the value [v] + in order. Tail recursive. *) +val iter_uses : (lluse -> unit) -> llvalue -> unit + +(** [fold_left_uses f init v] is [f (... (f init u1) ...) uN] where + [u1,...,uN] are the users of the value [v]. Tail recursive. *) +val fold_left_uses : ('a -> lluse -> 'a) -> 'a -> llvalue -> 'a + +(** [fold_right_uses f v init] is [f u1 (... (f uN init) ...)] where + [u1,...,uN] are the users of the value [v]. Not tail recursive. *) +val fold_right_uses : (lluse -> 'a -> 'a) -> llvalue -> 'a -> 'a + + (* {6 Users} *) (** [operand v i] returns the operand at index [i] for the value [v]. See the diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index cdd137e..4bcc764 100644 --- a/bindings/ocaml/llvm/llvm_ocaml.c +++ b/bindings/ocaml/llvm/llvm_ocaml.c @@ -707,6 +707,42 @@ CAMLprim value llvm_set_alignment(value Bytes, LLVMValueRef Global) { return Val_unit; } +/*--... Operations on uses .................................................--*/ + +/* llvalue -> lluse option */ +CAMLprim value llvm_use_begin(LLVMValueRef Val) { + CAMLparam0(); + LLVMUseRef First; + if ((First = LLVMGetFirstUse(Val))) { + value Option = alloc(1, 0); + Field(Option, 0) = (value) First; + CAMLreturn(Option); + } + CAMLreturn(Val_int(0)); +} + +/* lluse -> lluse option */ +CAMLprim value llvm_use_succ(LLVMUseRef U) { + CAMLparam0(); + LLVMUseRef Next; + if ((Next = LLVMGetNextUse(U))) { + value Option = alloc(1, 0); + Field(Option, 0) = (value) Next; + CAMLreturn(Option); + } + CAMLreturn(Val_int(0)); +} + +/* lluse -> llvalue */ +CAMLprim LLVMValueRef llvm_user(LLVMUseRef UR) { + return LLVMGetUser(UR); +} + +/* lluse -> llvalue */ +CAMLprim LLVMValueRef llvm_used_value(LLVMUseRef UR) { + return LLVMGetUsedValue(UR); +} + /*--... Operations on global variables .....................................--*/ DEFINE_ITERATORS(global, Global, LLVMModuleRef, LLVMValueRef, diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml index cbd52e4..d87e162 100644 --- a/test/Bindings/Ocaml/vmcore.ml +++ b/test/Bindings/Ocaml/vmcore.ml @@ -607,6 +607,33 @@ let test_global_variables () = end +(*===-- Uses --------------------------------------------------------------===*) + +let test_uses () = + let ty = function_type i32_type [| i32_type; i32_type |] in + let fn = define_function "use_function" ty m in + let b = builder_at_end context (entry_block fn) in + + let p1 = param fn 0 in + let p2 = param fn 1 in + let v1 = build_add p1 p2 "v1" b in + let v2 = build_add p1 v1 "v2" b in + let _ = build_add v1 v2 "v3" b in + + let lf s u = value_name (user u) ^ "->" ^ s in + insist ("v2->v3->" = fold_left_uses lf "" v1); + let rf u s = value_name (user u) ^ "<-" ^ s in + insist ("v3<-v2<-" = fold_right_uses rf v1 ""); + + let lf s u = value_name (used_value u) ^ "->" ^ s in + insist ("v1->v1->" = fold_left_uses lf "" v1); + + let rf u s = value_name (used_value u) ^ "<-" ^ s in + insist ("v1<-v1<-" = fold_right_uses rf v1 ""); + + ignore (build_unreachable b) + + (*===-- Users -------------------------------------------------------------===*) let test_users () = @@ -1291,6 +1318,7 @@ let _ = suite "constants" test_constants; suite "global values" test_global_values; suite "global variables" test_global_variables; + suite "uses" test_uses; suite "users" test_users; suite "aliases" test_aliases; suite "functions" test_functions; |