Objective Caml bindings for basic block, function, global, and arg iterators.

git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@48711 91177308-0d34-0410-b5e6-96231b3b80d8

diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml
index ac05a4dc65cb11a95a1249830a53da161bffa3ed..56bfa7bdba1c10dec2d65747040d67a78746f3af 100644 (file)
--- a/bindings/ocaml/llvm/llvm.ml
+++ b/bindings/ocaml/llvm/llvm.ml
@@ -102,6 +102,14 @@ exception IoError of string
 external register_exns : exn -> unit = "llvm_register_core_exns"
 let _ = register_exns (IoError "")
 
 external register_exns : exn -> unit = "llvm_register_core_exns"
 let _ = register_exns (IoError "")
 

+type ('a, 'b) llpos =
+| At_end of 'a
+| Before of 'b
+
+type ('a, 'b) llrev_pos =
+| At_start of 'a
+| After of 'b
+

 
 (*===-- Modules -----------------------------------------------------------===*)
 
 
 (*===-- Modules -----------------------------------------------------------===*)
 


@@ -298,6 +306,54 @@ external set_initializer : llvalue -> llvalue -> unit = "llvm_set_initializer"
 external remove_initializer : llvalue -> unit = "llvm_remove_initializer"
 external is_thread_local : llvalue -> bool = "llvm_is_thread_local"
 external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local"
 external remove_initializer : llvalue -> unit = "llvm_remove_initializer"
 external is_thread_local : llvalue -> bool = "llvm_is_thread_local"
 external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local"

+external global_begin : llmodule -> (llmodule, llvalue) llpos
+                      = "llvm_global_begin"
+external global_succ : llvalue -> (llmodule, llvalue) llpos
+                     = "llvm_global_succ"
+external global_end : llmodule -> (llmodule, llvalue) llrev_pos
+                    = "llvm_global_end"
+external global_pred : llvalue -> (llmodule, llvalue) llrev_pos
+                     = "llvm_global_pred"
+
+let rec iter_global_range f i e =
+  if i = e then () else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid global variable range.")
+  | Before bb ->
+      f bb;
+      iter_global_range f (global_succ bb) e
+
+let iter_globals f m =
+  iter_global_range f (global_begin m) (At_end m)
+
+let rec fold_left_global_range f init i e =
+  if i = e then init else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid global variable range.")
+  | Before bb -> fold_left_global_range f (f init bb) (global_succ bb) e
+
+let fold_left_globals f init m =
+  fold_left_global_range f init (global_begin m) (At_end m)
+
+let rec rev_iter_global_range f i e =
+  if i = e then () else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid global variable range.")
+  | After bb ->
+      f bb;
+      rev_iter_global_range f (global_pred bb) e
+
+let rev_iter_globals f m =
+  rev_iter_global_range f (global_end m) (At_start m)
+
+let rec fold_right_global_range f i e init =
+  if i = e then init else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid global variable range.")
+  | After bb -> fold_right_global_range f (global_pred bb) e (f bb init)
+
+let fold_right_globals f m init =
+  fold_right_global_range f (global_end m) (At_start m) init

 
 (*--... Operations on functions ............................................--*)
 external declare_function : string -> lltype -> llmodule -> llvalue
 
 (*--... Operations on functions ............................................--*)
 external declare_function : string -> lltype -> llmodule -> llvalue


@@ -313,6 +369,54 @@ external set_function_call_conv : int -> llvalue -> unit
                                 = "llvm_set_function_call_conv"
 external collector : llvalue -> string option = "llvm_collector"
 external set_collector : string option -> llvalue -> unit = "llvm_set_collector"
                                 = "llvm_set_function_call_conv"
 external collector : llvalue -> string option = "llvm_collector"
 external set_collector : string option -> llvalue -> unit = "llvm_set_collector"

+external function_begin : llmodule -> (llmodule, llvalue) llpos
+                        = "llvm_function_begin"
+external function_succ : llvalue -> (llmodule, llvalue) llpos
+                       = "llvm_function_succ"
+external function_end : llmodule -> (llmodule, llvalue) llrev_pos
+                      = "llvm_function_end"
+external function_pred : llvalue -> (llmodule, llvalue) llrev_pos
+                       = "llvm_function_pred"
+
+let rec iter_function_range f i e =
+  if i = e then () else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid function range.")
+  | Before fn ->
+      f fn;
+      iter_function_range f (function_succ fn) e
+
+let iter_functions f m =
+  iter_function_range f (function_begin m) (At_end m)
+
+let rec fold_left_function_range f init i e =
+  if i = e then init else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid function range.")
+  | Before fn -> fold_left_function_range f (f init fn) (function_succ fn) e
+
+let fold_left_functions f init m =
+  fold_left_function_range f init (function_begin m) (At_end m)
+
+let rec rev_iter_function_range f i e =
+  if i = e then () else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid function range.")
+  | After fn ->
+      f fn;
+      rev_iter_function_range f (function_pred fn) e
+
+let rev_iter_functions f m =
+  rev_iter_function_range f (function_end m) (At_start m)
+
+let rec fold_right_function_range f i e init =
+  if i = e then init else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid function range.")
+  | After fn -> fold_right_function_range f (function_pred fn) e (f fn init)
+
+let fold_right_functions f m init =
+  fold_right_function_range f (function_end m) (At_start m) init

 
 (* TODO: param attrs *)
 
 
 (* TODO: param attrs *)
 


@@ -320,6 +424,50 @@ external set_collector : string option -> llvalue -> unit = "llvm_set_collector"
 external params : llvalue -> llvalue array = "llvm_params"
 external param : llvalue -> int -> llvalue = "llvm_param"
 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
 external params : llvalue -> llvalue array = "llvm_params"
 external param : llvalue -> int -> llvalue = "llvm_param"
 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"

+external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin"
+external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ"
+external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end"
+external param_pred : llvalue -> (llvalue, llvalue) llrev_pos ="llvm_param_pred"
+
+let rec iter_param_range f i e =
+  if i = e then () else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid parameter range.")
+  | Before p ->
+      f p;
+      iter_param_range f (param_succ p) e
+
+let iter_params f fn =
+  iter_param_range f (param_begin fn) (At_end fn)
+
+let rec fold_left_param_range f init i e =
+  if i = e then init else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid parameter range.")
+  | Before p -> fold_left_param_range f (f init p) (param_succ p) e
+
+let fold_left_params f init fn =
+  fold_left_param_range f init (param_begin fn) (At_end fn)
+
+let rec rev_iter_param_range f i e =
+  if i = e then () else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid parameter range.")
+  | After p ->
+      f p;
+      rev_iter_param_range f (param_pred p) e
+
+let rev_iter_params f fn =
+  rev_iter_param_range f (param_end fn) (At_start fn)
+
+let rec fold_right_param_range f init i e =
+  if i = e then init else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid parameter range.")
+  | After p -> fold_right_param_range f (f p init) (param_pred p) e
+
+let fold_right_params f fn init =
+  fold_right_param_range f init (param_end fn) (At_start fn)

 
 (*--... Operations on basic blocks .........................................--*)
 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
 
 (*--... Operations on basic blocks .........................................--*)
 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"


@@ -332,6 +480,54 @@ external delete_block : llbasicblock -> unit = "llvm_delete_block"
 external append_block : string -> llvalue -> llbasicblock = "llvm_append_block"
 external insert_block : string -> llbasicblock -> llbasicblock
                       = "llvm_insert_block"
 external append_block : string -> llvalue -> llbasicblock = "llvm_append_block"
 external insert_block : string -> llbasicblock -> llbasicblock
                       = "llvm_insert_block"

+external block_begin : llvalue -> (llvalue, llbasicblock) llpos
+                     = "llvm_block_begin"
+external block_succ : llbasicblock -> (llvalue, llbasicblock) llpos
+                    = "llvm_block_succ"
+external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos
+                   = "llvm_block_end"
+external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos
+                    = "llvm_block_pred"
+
+let rec iter_block_range f i e =
+  if i = e then () else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid block range.")
+  | Before bb ->
+      f bb;
+      iter_block_range f (block_succ bb) e
+
+let iter_blocks f fn =
+  iter_block_range f (block_begin fn) (At_end fn)
+
+let rec fold_left_block_range f init i e =
+  if i = e then init else
+  match i with
+  | At_end _ -> raise (Invalid_argument "Invalid block range.")
+  | Before bb -> fold_left_block_range f (f init bb) (block_succ bb) e
+
+let fold_left_blocks f init fn =
+  fold_left_block_range f init (block_begin fn) (At_end fn)
+
+let rec rev_iter_block_range f i e =
+  if i = e then () else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid block range.")
+  | After bb ->
+      f bb;
+      rev_iter_block_range f (block_pred bb) e
+
+let rev_iter_blocks f fn =
+  rev_iter_block_range f (block_end fn) (At_start fn)
+
+let rec fold_right_block_range f init i e =
+  if i = e then init else
+  match i with
+  | At_start _ -> raise (Invalid_argument "Invalid block range.")
+  | After bb -> fold_right_block_range f (f bb init) (block_pred bb) e
+
+let fold_right_blocks f fn init =
+  fold_right_block_range f init (block_end fn) (At_start fn)

 
 (*--... Operations on instructions .........................................--*)
 external instr_parent : llvalue -> llbasicblock = "LLVMGetInstructionParent"
 
 (*--... Operations on instructions .........................................--*)
 external instr_parent : llvalue -> llbasicblock = "LLVMGetInstructionParent"

diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli
index 5996ecd1b949767b311b7617d78b3bef6ed13adc..398e83f618a8bfb5d00e970256fbe5318f323101 100644 (file)
--- a/bindings/ocaml/llvm/llvm.mli
+++ b/bindings/ocaml/llvm/llvm.mli
@@ -149,6 +149,23 @@ module Fcmp : sig
 end
 
 
 end
 
 

+(** {6 Iteration} *)
+
+(** [Before b] and [At_end a] specify positions from the start of the ['b] list
+    of [a]. [llpos] is used to specify positions in and for reverse iteration
+    through the various value lists maintained by the LLVM IR. *)
+type ('a, 'b) llpos =
+| At_end of 'a
+| Before of 'b
+
+(** [After b] and [At_start a] specify positions from the end of the ['b] list
+    of [a]. [llrev_pos] is used for reverse iteration through the various value
+    lists maintained by the LLVM IR. *)
+type ('a, 'b) llrev_pos =
+| At_start of 'a
+| After of 'b
+
+

 (** {6 Exceptions} *)
 
 exception IoError of string
 (** {6 Exceptions} *)
 
 exception IoError of string


@@ -745,6 +762,48 @@ external lookup_global : string -> llmodule -> llvalue option
     See the method [llvm::GlobalVariable::eraseFromParent]. *)
 external delete_global : llvalue -> unit = "llvm_delete_global"
 
     See the method [llvm::GlobalVariable::eraseFromParent]. *)
 external delete_global : llvalue -> unit = "llvm_delete_global"
 

+(** [global_begin m] returns the first position in the global variable list of
+    the module [m]. [global_begin] and [global_succ] can be used to iterate
+    over the global list in order.
+    See the method [llvm::Module::global_begin]. *)
+external global_begin : llmodule -> (llmodule, llvalue) llpos
+                      = "llvm_global_begin"
+
+(** [global_succ gv] returns the global variable list position succeeding
+    [Before gv].
+    See the method [llvm::Module::global_iterator::operator++]. *)
+external global_succ : llvalue -> (llmodule, llvalue) llpos
+                     = "llvm_global_succ"
+
+(** [iter_globals f m] applies function [f] to each of the global variables of
+    module [m] in order. Tail recursive. *)
+val iter_globals : (llvalue -> unit) -> llmodule -> unit
+
+(** [fold_left_globals f init m] is [f (... (f init g1) ...) gN] where
+    [g1,...,gN] are the global variables of module [m]. Tail recursive. *)
+val fold_left_globals : ('a -> llvalue -> 'a) -> 'a -> llmodule -> 'a
+
+(** [global_end m] returns the last position in the global variable list of the
+    module [m]. [global_end] and [global_pred] can be used to iterate over the
+    global list in reverse.
+    See the method [llvm::Module::global_end]. *)
+external global_end : llmodule -> (llmodule, llvalue) llrev_pos
+                    = "llvm_global_end"
+
+(** [global_pred gv] returns the global variable list position preceding
+    [After gv].
+    See the method [llvm::Module::global_iterator::operator--]. *)
+external global_pred : llvalue -> (llmodule, llvalue) llrev_pos
+                     = "llvm_global_pred"
+
+(** [rev_iter_globals f m] applies function [f] to each of the global variables
+    of module [m] in reverse order. Tail recursive. *)
+val rev_iter_globals : (llvalue -> unit) -> llmodule -> unit
+
+(** [fold_right_globals f m init] is [f g1 (... (f gN init) ...)] where
+    [g1,...,gN] are the global variables of module [m]. Tail recursive. *)
+val fold_right_globals : (llvalue -> 'a -> 'a) -> llmodule -> 'a -> 'a
+

 (** [is_global_constant gv] returns [true] if the global variabile [gv] is a
     constant. Returns [false] otherwise.
     See the method [llvm::GlobalVariable::isConstant]. *)
 (** [is_global_constant gv] returns [true] if the global variabile [gv] is a
     constant. Returns [false] otherwise.
     See the method [llvm::GlobalVariable::isConstant]. *)


@@ -812,6 +871,47 @@ external lookup_function : string -> llmodule -> llvalue option
     See the method [llvm::Function::eraseFromParent]. *)
 external delete_function : llvalue -> unit = "llvm_delete_function"
 
     See the method [llvm::Function::eraseFromParent]. *)
 external delete_function : llvalue -> unit = "llvm_delete_function"
 

+(** [function_begin m] returns the first position in the function list of the
+    module [m]. [function_begin] and [function_succ] can be used to iterate over
+    the function list in order.
+    See the method [llvm::Module::begin]. *)
+external function_begin : llmodule -> (llmodule, llvalue) llpos
+                        = "llvm_function_begin"
+
+(** [function_succ gv] returns the function list position succeeding
+    [Before gv].
+    See the method [llvm::Module::iterator::operator++]. *)
+external function_succ : llvalue -> (llmodule, llvalue) llpos
+                       = "llvm_function_succ"
+
+(** [iter_functions f m] applies function [f] to each of the functions of module
+    [m] in order. Tail recursive. *)
+val iter_functions : (llvalue -> unit) -> llmodule -> unit
+
+(** [fold_left_function f init m] is [f (... (f init f1) ...) fN] where
+    [f1,...,fN] are the functions of module [m]. Tail recursive. *)
+val fold_left_functions : ('a -> llvalue -> 'a) -> 'a -> llmodule -> 'a
+
+(** [function_end m] returns the last position in the function list of
+    the module [m]. [function_end] and [function_pred] can be used to iterate
+    over the function list in reverse.
+    See the method [llvm::Module::end]. *)
+external function_end : llmodule -> (llmodule, llvalue) llrev_pos
+                      = "llvm_function_end"
+
+(** [function_pred gv] returns the function list position preceding [After gv].
+    See the method [llvm::Module::iterator::operator--]. *)
+external function_pred : llvalue -> (llmodule, llvalue) llrev_pos
+                       = "llvm_function_pred"
+
+(** [rev_iter_functions f fn] applies function [f] to each of the functions of
+    module [m] in reverse order. Tail recursive. *)
+val rev_iter_functions : (llvalue -> unit) -> llmodule -> unit
+
+(** [fold_right_functions f m init] is [f (... (f init fN) ...) f1] where
+    [f1,...,fN] are the functions of module [m]. Tail recursive. *)
+val fold_right_functions : (llvalue -> 'a -> 'a) -> llmodule -> 'a -> 'a
+

 (** [is_intrinsic f] returns true if the function [f] is an intrinsic.
     See the method [llvm::Function::isIntrinsic]. *)
 external is_intrinsic : llvalue -> bool = "llvm_is_intrinsic"
 (** [is_intrinsic f] returns true if the function [f] is an intrinsic.
     See the method [llvm::Function::isIntrinsic]. *)
 external is_intrinsic : llvalue -> bool = "llvm_is_intrinsic"


@@ -850,6 +950,44 @@ external param : llvalue -> int -> llvalue = "llvm_param"
     See the method [llvm::Argument::getParent]. *)
 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
 
     See the method [llvm::Argument::getParent]. *)
 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
 

+(** [param_begin f] returns the first position in the parameter list of the
+    function [f]. [param_begin] and [param_succ] can be used to iterate over
+    the parameter list in order.
+    See the method [llvm::Function::arg_begin]. *)
+external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin"
+
+(** [param_succ bb] returns the parameter list position succeeding
+    [Before bb].
+    See the method [llvm::Function::arg_iterator::operator++]. *)
+external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ"
+
+(** [iter_params f fn] applies function [f] to each of the parameters
+    of function [fn] in order. Tail recursive. *)
+val iter_params : (llvalue -> unit) -> llvalue -> unit
+
+(** [fold_left_params f init fn] is [f (... (f init b1) ...) bN] where
+    [b1,...,bN] are the parameters of function [fn]. Tail recursive. *)
+val fold_left_params : ('a -> llvalue -> 'a) -> 'a -> llvalue -> 'a
+
+(** [param_end f] returns the last position in the parameter list of
+    the function [f]. [param_end] and [param_pred] can be used to iterate
+    over the parameter list in reverse.
+    See the method [llvm::Function::arg_end]. *)
+external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end"
+
+(** [param_pred gv] returns the function list position preceding [After gv].
+    See the method [llvm::Function::arg_iterator::operator--]. *)
+external param_pred : llvalue -> (llvalue, llvalue) llrev_pos
+                    = "llvm_param_pred"
+
+(** [rev_iter_params f fn] applies function [f] to each of the parameters
+    of function [fn] in reverse order. Tail recursive. *)
+val rev_iter_params : (llvalue -> unit) -> llvalue -> unit
+
+(** [fold_right_params f fn init] is [f (... (f init bN) ...) b1] where
+    [b1,...,bN] are the parameters of function [fn]. Tail recursive. *)
+val fold_right_params : (llvalue -> 'a -> 'a) -> llvalue -> 'a -> 'a
+

 
 (** {7 Operations on basic blocks} *)
 
 
 (** {7 Operations on basic blocks} *)
 


@@ -880,6 +1018,47 @@ external insert_block : string -> llbasicblock -> llbasicblock
     See the method [llvm::BasicBlock::getParent]. *)
 external block_parent : llbasicblock -> llvalue = "LLVMGetBasicBlockParent"
 
     See the method [llvm::BasicBlock::getParent]. *)
 external block_parent : llbasicblock -> llvalue = "LLVMGetBasicBlockParent"
 

+(** [block_begin f] returns the first position in the basic block list of the
+    function [f]. [block_begin] and [block_succ] can be used to iterate over
+    the basic block list in order.
+    See the method [llvm::Function::begin]. *)
+external block_begin : llvalue -> (llvalue, llbasicblock) llpos
+                     = "llvm_block_begin"
+
+(** [block_succ bb] returns the basic block list position succeeding
+    [Before bb].
+    See the method [llvm::Function::iterator::operator++]. *)
+external block_succ : llbasicblock -> (llvalue, llbasicblock) llpos
+                    = "llvm_block_succ"
+
+(** [iter_blocks f fn] applies function [f] to each of the basic blocks
+    of function [fn] in order. Tail recursive. *)
+val iter_blocks : (llbasicblock -> unit) -> llvalue -> unit
+
+(** [fold_left_blocks f init fn] is [f (... (f init b1) ...) bN] where
+    [b1,...,bN] are the basic blocks of function [fn]. Tail recursive. *)
+val fold_left_blocks : ('a -> llbasicblock -> 'a) -> 'a -> llvalue -> 'a
+
+(** [block_end f] returns the last position in the basic block list of
+    the function [f]. [block_end] and [block_pred] can be used to iterate
+    over the basic block list in reverse.
+    See the method [llvm::Function::end]. *)
+external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos
+                   = "llvm_block_end"
+
+(** [block_pred gv] returns the function list position preceding [After gv].
+    See the method [llvm::Function::iterator::operator--]. *)
+external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos
+                    = "llvm_block_pred"
+
+(** [rev_iter_blocks f fn] applies function [f] to each of the basic blocks
+    of function [fn] in reverse order. Tail recursive. *)
+val rev_iter_blocks : (llbasicblock -> unit) -> llvalue -> unit
+
+(** [fold_right_blocks f fn init] is [f (... (f init bN) ...) b1] where
+    [b1,...,bN] are the basic blocks of function [fn]. Tail recursive. *)
+val fold_right_blocks : (llbasicblock -> 'a -> 'a) -> llvalue -> 'a -> 'a
+

 (** [value_of_block bb] losslessly casts [bb] to an [llvalue]. *)
 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
 
 (** [value_of_block bb] losslessly casts [bb] to an [llvalue]. *)
 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
 

diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c
index c966091ccbb74755d6e3f86024b7ef6939f38543..9943af760b09fcc8134308f274d1849604b14e73 100644 (file)
--- a/bindings/ocaml/llvm/llvm_ocaml.c
+++ b/bindings/ocaml/llvm/llvm_ocaml.c
@@ -50,6 +50,47 @@ static void llvm_raise(value Prototype, char *Message) {
 #endif
 }
 
 #endif
 }
 

+static value alloc_variant(int tag, void *Value) {
+  value Iter = alloc_small(1, tag);
+  Field(Iter, 0) = Val_op(Value);
+  return Iter;
+}
+
+/* Macro to convert the C first/next/last/prev idiom to the Ocaml llpos/
+   llrev_pos idiom. */
+#define DEFINE_ITERATORS(camlname, cname, pty, cty, pfun) \
+  /* llmodule -> ('a, 'b) llpos */                        \
+  CAMLprim value llvm_##camlname##_begin(pty Mom) {       \
+    cty First = LLVMGetFirst##cname(Mom);                 \
+    if (First)                                            \
+      return alloc_variant(1, First);                     \
+    return alloc_variant(0, Mom);                         \
+  }                                                       \
+                                                          \
+  /* llvalue -> ('a, 'b) llpos */                         \
+  CAMLprim value llvm_##camlname##_succ(cty Kid) {        \
+    cty Next = LLVMGetNext##cname(Kid);                   \
+    if (Next)                                             \
+      return alloc_variant(1, Next);                      \
+    return alloc_variant(0, pfun(Kid))                  ; \
+  }                                                       \
+                                                          \
+  /* llmodule -> ('a, 'b) llrev_pos */                    \
+  CAMLprim value llvm_##camlname##_end(pty Mom) {         \
+    cty Last = LLVMGetLast##cname(Mom);                   \
+    if (Last)                                             \
+      return alloc_variant(1, Last);                      \
+    return alloc_variant(0, Mom);                         \
+  }                                                       \
+                                                          \
+  /* llvalue -> ('a, 'b) llrev_pos */                     \
+  CAMLprim value llvm_##camlname##_pred(cty Kid) {        \
+    cty Prev = LLVMGetPrevious##cname(Kid);               \
+    if (Prev)                                             \
+      return alloc_variant(1, Prev);                      \
+    return alloc_variant(0, pfun(Kid));                   \
+  }
+

 
 /*===-- Modules -----------------------------------------------------------===*/
 
 
 /*===-- Modules -----------------------------------------------------------===*/
 


@@ -464,6 +505,9 @@ CAMLprim value llvm_set_alignment(value Bytes, LLVMValueRef Global) {
 
 /*--... Operations on global variables .....................................--*/
 
 
 /*--... Operations on global variables .....................................--*/
 

+DEFINE_ITERATORS(global, Global, LLVMModuleRef, LLVMValueRef,
+                 LLVMGetGlobalParent)
+

 /* lltype -> string -> llmodule -> llvalue */
 CAMLprim LLVMValueRef llvm_declare_global(LLVMTypeRef Ty, value Name,
                                           LLVMModuleRef M) {
 /* lltype -> string -> llmodule -> llvalue */
 CAMLprim LLVMValueRef llvm_declare_global(LLVMTypeRef Ty, value Name,
                                           LLVMModuleRef M) {


@@ -541,6 +585,9 @@ CAMLprim value llvm_set_global_constant(value Flag, LLVMValueRef GlobalVar) {
 
 /*--... Operations on functions ............................................--*/
 
 
 /*--... Operations on functions ............................................--*/
 

+DEFINE_ITERATORS(function, Function, LLVMModuleRef, LLVMValueRef,
+                 LLVMGetGlobalParent)
+

 /* string -> lltype -> llmodule -> llvalue */
 CAMLprim LLVMValueRef llvm_declare_function(value Name, LLVMTypeRef Ty,
                                             LLVMModuleRef M) {
 /* string -> lltype -> llmodule -> llvalue */
 CAMLprim LLVMValueRef llvm_declare_function(value Name, LLVMTypeRef Ty,
                                             LLVMModuleRef M) {


@@ -579,18 +626,6 @@ CAMLprim value llvm_delete_function(LLVMValueRef Fn) {
   return Val_unit;
 }
 
   return Val_unit;
 }
 

-/* llvalue -> int -> llvalue */
-CAMLprim LLVMValueRef llvm_param(LLVMValueRef Fn, value Index) {
-  return LLVMGetParam(Fn, Int_val(Index));
-}
-
-/* llvalue -> int -> llvalue */
-CAMLprim value llvm_params(LLVMValueRef Fn, value Index) {
-  value Params = alloc(LLVMCountParams(Fn), 0);
-  LLVMGetParams(Fn, (LLVMValueRef *) Op_val(Params));
-  return Params;
-}
-

 /* llvalue -> bool */
 CAMLprim value llvm_is_intrinsic(LLVMValueRef Fn) {
   return Val_bool(LLVMGetIntrinsicID(Fn));
 /* llvalue -> bool */
 CAMLprim value llvm_is_intrinsic(LLVMValueRef Fn) {
   return Val_bool(LLVMGetIntrinsicID(Fn));


@@ -630,8 +665,27 @@ CAMLprim value llvm_set_collector(value GC, LLVMValueRef Fn) {
   return Val_unit;
 }
 
   return Val_unit;
 }
 

+/*--... Operations on parameters ...........................................--*/
+
+DEFINE_ITERATORS(param, Param, LLVMValueRef, LLVMValueRef, LLVMGetParamParent)
+
+/* llvalue -> int -> llvalue */
+CAMLprim LLVMValueRef llvm_param(LLVMValueRef Fn, value Index) {
+  return LLVMGetParam(Fn, Int_val(Index));
+}
+
+/* llvalue -> int -> llvalue */
+CAMLprim value llvm_params(LLVMValueRef Fn, value Index) {
+  value Params = alloc(LLVMCountParams(Fn), 0);
+  LLVMGetParams(Fn, (LLVMValueRef *) Op_val(Params));
+  return Params;
+}
+

 /*--... Operations on basic blocks .........................................--*/
 
 /*--... Operations on basic blocks .........................................--*/
 

+DEFINE_ITERATORS(
+  block, BasicBlock, LLVMValueRef, LLVMBasicBlockRef, LLVMGetBasicBlockParent)
+

 /* llvalue -> llbasicblock array */
 CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) {
   value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0);
 /* llvalue -> llbasicblock array */
 CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) {
   value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0);

diff --git a/include/llvm-c/Core.h b/include/llvm-c/Core.h
index eb4bc207e8ee49167d89a17ec2b7568f0a8a8e81..ef1e2f6ce2f81bc3599dd48f7afc40344965ced8 100644 (file)
--- a/include/llvm-c/Core.h
+++ b/include/llvm-c/Core.h
@@ -376,6 +376,10 @@ void LLVMSetAlignment(LLVMValueRef Global, unsigned Bytes);
 /* Operations on global variables */
 LLVMValueRef LLVMAddGlobal(LLVMModuleRef M, LLVMTypeRef Ty, const char *Name);
 LLVMValueRef LLVMGetNamedGlobal(LLVMModuleRef M, const char *Name);
 /* Operations on global variables */
 LLVMValueRef LLVMAddGlobal(LLVMModuleRef M, LLVMTypeRef Ty, const char *Name);
 LLVMValueRef LLVMGetNamedGlobal(LLVMModuleRef M, const char *Name);

+LLVMValueRef LLVMGetFirstGlobal(LLVMModuleRef M);
+LLVMValueRef LLVMGetLastGlobal(LLVMModuleRef M);
+LLVMValueRef LLVMGetNextGlobal(LLVMValueRef GlobalVar);
+LLVMValueRef LLVMGetPreviousGlobal(LLVMValueRef GlobalVar);

 void LLVMDeleteGlobal(LLVMValueRef GlobalVar);
 int LLVMHasInitializer(LLVMValueRef GlobalVar);
 LLVMValueRef LLVMGetInitializer(LLVMValueRef GlobalVar);
 void LLVMDeleteGlobal(LLVMValueRef GlobalVar);
 int LLVMHasInitializer(LLVMValueRef GlobalVar);
 LLVMValueRef LLVMGetInitializer(LLVMValueRef GlobalVar);


@@ -405,12 +409,16 @@ unsigned LLVMCountParams(LLVMValueRef Fn);
 void LLVMGetParams(LLVMValueRef Fn, LLVMValueRef *Params);
 LLVMValueRef LLVMGetParam(LLVMValueRef Fn, unsigned Index);
 LLVMValueRef LLVMGetParamParent(LLVMValueRef Inst);
 void LLVMGetParams(LLVMValueRef Fn, LLVMValueRef *Params);
 LLVMValueRef LLVMGetParam(LLVMValueRef Fn, unsigned Index);
 LLVMValueRef LLVMGetParamParent(LLVMValueRef Inst);

+LLVMValueRef LLVMGetFirstParam(LLVMValueRef Fn);
+LLVMValueRef LLVMGetLastParam(LLVMValueRef Fn);
+LLVMValueRef LLVMGetNextParam(LLVMValueRef Arg);
+LLVMValueRef LLVMGetPreviousParam(LLVMValueRef Arg);

 
 /* Operations on basic blocks */
 
 /* Operations on basic blocks */

-LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef Bb);
+LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef BB);

 int LLVMValueIsBasicBlock(LLVMValueRef Val);
 LLVMBasicBlockRef LLVMValueAsBasicBlock(LLVMValueRef Val);
 int LLVMValueIsBasicBlock(LLVMValueRef Val);
 LLVMBasicBlockRef LLVMValueAsBasicBlock(LLVMValueRef Val);

-LLVMValueRef LLVMGetBasicBlockParent(LLVMValueRef V);
+LLVMValueRef LLVMGetBasicBlockParent(LLVMBasicBlockRef BB);

 unsigned LLVMCountBasicBlocks(LLVMValueRef Fn);
 void LLVMGetBasicBlocks(LLVMValueRef Fn, LLVMBasicBlockRef *BasicBlocks);
 LLVMBasicBlockRef LLVMGetFirstBasicBlock(LLVMValueRef Fn);
 unsigned LLVMCountBasicBlocks(LLVMValueRef Fn);
 void LLVMGetBasicBlocks(LLVMValueRef Fn, LLVMBasicBlockRef *BasicBlocks);
 LLVMBasicBlockRef LLVMGetFirstBasicBlock(LLVMValueRef Fn);

diff --git a/lib/VMCore/Core.cpp b/lib/VMCore/Core.cpp
index ac7738bf8594546a54c79204d577afbfe8fceabb..59b9b1ab69a58d33c96646f20457f01aa2c61301 100644 (file)
--- a/lib/VMCore/Core.cpp
+++ b/lib/VMCore/Core.cpp
@@ -628,7 +628,7 @@ LLVMValueRef LLVMGetNextGlobal(LLVMValueRef GlobalVar) {
 LLVMValueRef LLVMGetPreviousGlobal(LLVMValueRef GlobalVar) {
   GlobalVariable *GV = unwrap<GlobalVariable>(GlobalVar);
   Module::global_iterator I = GV;
 LLVMValueRef LLVMGetPreviousGlobal(LLVMValueRef GlobalVar) {
   GlobalVariable *GV = unwrap<GlobalVariable>(GlobalVar);
   Module::global_iterator I = GV;

-  if (I == GV->getParent()->global_end())
+  if (I == GV->getParent()->global_begin())

     return 0;
   return wrap(--I);
 }
     return 0;
   return wrap(--I);
 }


@@ -705,7 +705,7 @@ LLVMValueRef LLVMGetNextFunction(LLVMValueRef Fn) {
 LLVMValueRef LLVMGetPreviousFunction(LLVMValueRef Fn) {
   Function *Func = unwrap<Function>(Fn);
   Module::iterator I = Func;
 LLVMValueRef LLVMGetPreviousFunction(LLVMValueRef Fn) {
   Function *Func = unwrap<Function>(Fn);
   Module::iterator I = Func;

-  if (I == Func->getParent()->end())
+  if (I == Func->getParent()->begin())

     return 0;
   return wrap(--I);
 }
     return 0;
   return wrap(--I);
 }


@@ -767,6 +767,38 @@ LLVMValueRef LLVMGetParamParent(LLVMValueRef V) {
   return wrap(unwrap<Argument>(V)->getParent());
 }
 
   return wrap(unwrap<Argument>(V)->getParent());
 }
 

+LLVMValueRef LLVMGetFirstParam(LLVMValueRef Fn) {
+  Function *Func = unwrap<Function>(Fn);
+  Function::arg_iterator I = Func->arg_begin();
+  if (I == Func->arg_end())
+    return 0;
+  return wrap(I);
+}
+
+LLVMValueRef LLVMGetLastParam(LLVMValueRef Fn) {
+  Function *Func = unwrap<Function>(Fn);
+  Function::arg_iterator I = Func->arg_end();
+  if (I == Func->arg_begin())
+    return 0;
+  return wrap(--I);
+}
+
+LLVMValueRef LLVMGetNextParam(LLVMValueRef Arg) {
+  Argument *A = unwrap<Argument>(Arg);
+  Function::arg_iterator I = A;
+  if (++I == A->getParent()->arg_end())
+    return 0;
+  return wrap(I);
+}
+
+LLVMValueRef LLVMGetPreviousParam(LLVMValueRef Arg) {
+  Argument *A = unwrap<Argument>(Arg);
+  Function::arg_iterator I = A;
+  if (I == A->getParent()->arg_begin())
+    return 0;
+  return wrap(--I);
+}
+

 /*--.. Operations on basic blocks ..........................................--*/
 
 LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef BB) {
 /*--.. Operations on basic blocks ..........................................--*/
 
 LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef BB) {


@@ -781,8 +813,8 @@ LLVMBasicBlockRef LLVMValueAsBasicBlock(LLVMValueRef Val) {
   return wrap(unwrap<BasicBlock>(Val));
 }
 
   return wrap(unwrap<BasicBlock>(Val));
 }
 

-LLVMValueRef LLVMGetBasicBlockParent(LLVMValueRef V) {
-  return wrap(unwrap<BasicBlock>(V)->getParent());
+LLVMValueRef LLVMGetBasicBlockParent(LLVMBasicBlockRef BB) {
+  return wrap(unwrap(BB)->getParent());

 }
 
 unsigned LLVMCountBasicBlocks(LLVMValueRef FnRef) {
 }
 
 unsigned LLVMCountBasicBlocks(LLVMValueRef FnRef) {

diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml
index 73b5b286bef27018b437b346dd83e23067cd2894..3ff8cb9faafb6526ef8fde92cfc725647c4add2b 100644 (file)
--- a/test/Bindings/Ocaml/vmcore.ml
+++ b/test/Bindings/Ocaml/vmcore.ml
@@ -467,7 +467,33 @@ let test_global_variables () =
   let g = define_global "ConstGlobalVar" fourty_two32 m in
   insist (not (is_global_constant g));
   set_global_constant true g;
   let g = define_global "ConstGlobalVar" fourty_two32 m in
   insist (not (is_global_constant g));
   set_global_constant true g;

-  insist (is_global_constant g)
+  insist (is_global_constant g);
+  
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    insist (At_end m = global_begin m);
+    insist (At_start m = global_end m);
+    
+    let g1 = declare_global i32_type "One" m in
+    let g2 = declare_global i32_type "Two" m in
+    
+    insist (Before g1 = global_begin m);
+    insist (Before g2 = global_succ g1);
+    insist (At_end m = global_succ g2);
+    
+    insist (After g2 = global_end m);
+    insist (After g1 = global_pred g2);
+    insist (At_start m = global_pred g1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_globals lf "" m);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_globals rf m "");
+    
+    dispose_module m
+  end

 
 
 (*===-- Functions ---------------------------------------------------------===*)
 
 
 (*===-- Functions ---------------------------------------------------------===*)


@@ -540,6 +566,68 @@ let test_functions () =
     insist (None = collector fn);
     set_collector (Some "shadowstack") fn;
     ignore (build_unreachable (builder_at_end (entry_block fn)));
     insist (None = collector fn);
     set_collector (Some "shadowstack") fn;
     ignore (build_unreachable (builder_at_end (entry_block fn)));

+  end;
+  
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    insist (At_end m = function_begin m);
+    insist (At_start m = function_end m);
+    
+    let f1 = define_function "One" ty m in
+    let f2 = define_function "Two" ty m in
+    
+    insist (Before f1 = function_begin m);
+    insist (Before f2 = function_succ f1);
+    insist (At_end m = function_succ f2);
+    
+    insist (After f2 = function_end m);
+    insist (After f1 = function_pred f2);
+    insist (At_start m = function_pred f1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_functions lf "" m);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_functions rf m "");
+    
+    dispose_module m
+  end
+
+
+(*===-- Params ------------------------------------------------------------===*)
+
+let test_params () =
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    let vf = define_function "void" (function_type void_type [| |]) m in
+    
+    insist (At_end vf = param_begin vf);
+    insist (At_start vf = param_end vf);
+    
+    let ty = function_type void_type [| i32_type; i32_type |] in
+    let f = define_function "f" ty m in
+    let p1 = param f 0 in
+    let p2 = param f 1 in
+    set_value_name "One" p1;
+    set_value_name "Two" p2;
+    
+    insist (Before p1 = param_begin f);
+    insist (Before p2 = param_succ p1);
+    insist (At_end f = param_succ p2);
+    
+    insist (After p2 = param_end f);
+    insist (After p1 = param_pred p2);
+    insist (At_start f = param_pred p1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_params lf "" f);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_params rf f "");
+    
+    dispose_module m

   end
 
 
   end
 
 


@@ -587,7 +675,34 @@ let test_basic_blocks () =
   ignore (build_unreachable (builder_at_end bb));
   insist (bb = block_of_value (value_of_block bb));
   insist (value_is_block (value_of_block bb));
   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)))
+  insist (not (value_is_block (const_null i32_type)));
+  
+  begin group "iteration";
+    let m = create_module "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
+    
+    insist (Before b1 = block_begin f);
+    insist (Before b2 = block_succ b1);
+    insist (At_end f = block_succ b2);
+    
+    insist (After b2 = block_end f);
+    insist (After b1 = block_pred b2);
+    insist (At_start f = block_pred b1);
+    
+    let lf s x = s ^ "->" ^ value_name (value_of_block x) in
+    insist ("->One->Two" = fold_left_blocks lf "" f);
+    
+    let rf x s = value_name (value_of_block x) ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_blocks rf f "");
+    
+    dispose_module m
+  end

 
 
 (*===-- Builder -----------------------------------------------------------===*)
 
 
 (*===-- Builder -----------------------------------------------------------===*)


@@ -907,6 +1022,7 @@ let _ =
   suite "global values"    test_global_values;
   suite "global variables" test_global_variables;
   suite "functions"        test_functions;
   suite "global values"    test_global_values;
   suite "global variables" test_global_variables;
   suite "functions"        test_functions;

+  suite "params"           test_params;

   suite "basic blocks"     test_basic_blocks;
   suite "builder"          test_builder;
   suite "module provider"  test_module_provider;
   suite "basic blocks"     test_basic_blocks;
   suite "builder"          test_builder;
   suite "module provider"  test_module_provider;