diff options
Diffstat (limited to 'bindings')
| -rw-r--r-- | bindings/ocaml/llvm/llvm.ml | 196 | ||||
| -rw-r--r-- | bindings/ocaml/llvm/llvm.mli | 179 | ||||
| -rw-r--r-- | bindings/ocaml/llvm/llvm_ocaml.c | 78 |
3 files changed, 441 insertions, 12 deletions
diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index ac05a4dc65..56bfa7bdba 100644 --- 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 "") +type ('a, 'b) llpos = +| At_end of 'a +| Before of 'b + +type ('a, 'b) llrev_pos = +| At_start of 'a +| After of 'b + (*===-- 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 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 @@ -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" +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 *) @@ -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 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" @@ -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 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" diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index 5996ecd1b9..398e83f618 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -149,6 +149,23 @@ module Fcmp : sig 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 @@ -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" +(** [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]. *) @@ -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" +(** [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" @@ -850,6 +950,44 @@ external param : llvalue -> int -> llvalue = "llvm_param" 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} *) @@ -880,6 +1018,47 @@ external insert_block : string -> llbasicblock -> llbasicblock 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" diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index c966091ccb..9943af760b 100644 --- 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 } +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 -----------------------------------------------------------===*/ @@ -464,6 +505,9 @@ CAMLprim value llvm_set_alignment(value Bytes, LLVMValueRef Global) { /*--... 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) { @@ -541,6 +585,9 @@ CAMLprim value llvm_set_global_constant(value Flag, LLVMValueRef GlobalVar) { /*--... 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) { @@ -579,18 +626,6 @@ CAMLprim value llvm_delete_function(LLVMValueRef Fn) { 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)); @@ -630,8 +665,27 @@ CAMLprim value llvm_set_collector(value GC, LLVMValueRef Fn) { 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 .........................................--*/ +DEFINE_ITERATORS( + block, BasicBlock, LLVMValueRef, LLVMBasicBlockRef, LLVMGetBasicBlockParent) + /* llvalue -> llbasicblock array */ CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) { value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0); |