mirror of
https://github.com/c64scene-ar/llvm-6502.git
synced 2024-12-13 04:30:23 +00:00
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
This commit is contained in:
Gordon Henriksen
parent
82818eb223
commit
4733be3893
@ -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"
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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);
|
||||
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);
|
||||
@ -405,12 +409,16 @@ unsigned LLVMCountParams(LLVMValueRef Fn);
|
||||
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 */
|
||||
LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef Bb);
|
||||
LLVMValueRef LLVMBasicBlockAsValue(LLVMBasicBlockRef BB);
|
||||
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);
|
||||
|
||||
@ -628,7 +628,7 @@ LLVMValueRef LLVMGetNextGlobal(LLVMValueRef GlobalVar) {
|
||||
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);
|
||||
}
|
||||
@ -705,7 +705,7 @@ LLVMValueRef LLVMGetNextFunction(LLVMValueRef Fn) {
|
||||
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);
|
||||
}
|
||||
@ -767,6 +767,38 @@ LLVMValueRef LLVMGetParamParent(LLVMValueRef V) {
|
||||
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) {
|
||||
@ -781,8 +813,8 @@ LLVMBasicBlockRef LLVMValueAsBasicBlock(LLVMValueRef 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) {
|
||||
|
||||
@ -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;
|
||||
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 ---------------------------------------------------------===*)
|
||||
@ -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)));
|
||||
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
|
||||
|
||||
|
||||
@ -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));
|
||||
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 -----------------------------------------------------------===*)
|
||||
@ -907,6 +1022,7 @@ let _ =
|
||||
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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user