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 -----------------------------------------------------------===*)
= "llvm_add_type_name"
external delete_type_name : string -> llmodule -> unit
= "llvm_delete_type_name"
-
+external dump_module : llmodule -> unit = "llvm_dump_module"
(*===-- Types -------------------------------------------------------------===*)
= "LLVMConstShuffleVector"
(*--... Operations on global variables, functions, and aliases (globals) ...--*)
+external global_parent : llvalue -> llmodule = "LLVMGetGlobalParent"
external is_declaration : llvalue -> bool = "llvm_is_declaration"
external linkage : llvalue -> Linkage.t = "llvm_linkage"
external set_linkage : Linkage.t -> llvalue -> unit = "llvm_set_linkage"
external lookup_global : string -> llmodule -> llvalue option
= "llvm_lookup_global"
external delete_global : llvalue -> unit = "llvm_delete_global"
-external has_initializer : llvalue -> bool = "llvm_has_initializer"
external global_initializer : llvalue -> llvalue = "LLVMGetInitializer"
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
external lookup_function : string -> llmodule -> llvalue option
= "llvm_lookup_function"
external delete_function : llvalue -> unit = "llvm_delete_function"
-external params : llvalue -> llvalue array = "llvm_params"
-external param : llvalue -> int -> llvalue = "llvm_param"
external is_intrinsic : llvalue -> bool = "llvm_is_intrinsic"
external function_call_conv : llvalue -> int = "llvm_function_call_conv"
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 gc : llvalue -> string option = "llvm_gc"
+external set_gc : string option -> llvalue -> unit = "llvm_set_gc"
+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 *)
+(*--... Operations on params ...............................................--*)
+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"
+external value_is_block : llvalue -> bool = "llvm_value_is_block"
+external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock"
+external block_parent : llbasicblock -> llvalue = "LLVMGetBasicBlockParent"
external basic_blocks : llvalue -> llbasicblock array = "llvm_basic_blocks"
external entry_block : llvalue -> llbasicblock = "LLVMGetEntryBasicBlock"
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 value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
-external value_is_block : llvalue -> bool = "llvm_value_is_block"
-external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock"
+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"
+external instr_begin : llbasicblock -> (llbasicblock, llvalue) llpos
+ = "llvm_instr_begin"
+external instr_succ : llvalue -> (llbasicblock, llvalue) llpos
+ = "llvm_instr_succ"
+external instr_end : llbasicblock -> (llbasicblock, llvalue) llrev_pos
+ = "llvm_instr_end"
+external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos
+ = "llvm_instr_pred"
+
+let rec iter_instrs_range f i e =
+ if i = e then () else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid instruction range.")
+ | Before i ->
+ f i;
+ iter_instrs_range f (instr_succ i) e
+
+let iter_instrs f bb =
+ iter_instrs_range f (instr_begin bb) (At_end bb)
+
+let rec fold_left_instrs_range f init i e =
+ if i = e then init else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid instruction range.")
+ | Before i -> fold_left_instrs_range f (f init i) (instr_succ i) e
+
+let fold_left_instrs f init bb =
+ fold_left_instrs_range f init (instr_begin bb) (At_end bb)
+
+let rec rev_iter_instrs_range f i e =
+ if i = e then () else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid instruction range.")
+ | After i ->
+ f i;
+ rev_iter_instrs_range f (instr_pred i) e
+
+let rev_iter_instrs f bb =
+ rev_iter_instrs_range f (instr_end bb) (At_start bb)
+
+let rec fold_right_instr_range f i e init =
+ if i = e then init else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid instruction range.")
+ | After i -> fold_right_instr_range f (instr_pred i) e (f i init)
+
+let fold_right_instrs f bb init =
+ fold_right_instr_range f (instr_end bb) (At_start bb) init
+
(*--... Operations on call sites ...........................................--*)
external instruction_call_conv: llvalue -> int
external set_instruction_call_conv: int -> llvalue -> unit
= "llvm_set_instruction_call_conv"
+(*--... Operations on call instructions (only) .............................--*)
+external is_tail_call : llvalue -> bool = "llvm_is_tail_call"
+external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call"
+
(*--... Operations on phi nodes ............................................--*)
external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit
= "llvm_add_incoming"
(*===-- Instruction builders ----------------------------------------------===*)
-external builder: unit-> llbuilder
- = "llvm_builder"
-external builder_before : llvalue -> llbuilder = "llvm_builder_before"
-external builder_at_end : llbasicblock -> llbuilder = "llvm_builder_at_end"
-external position_before : llvalue -> llbuilder -> unit = "llvm_position_before"
-external position_at_end : llbasicblock -> llbuilder -> unit
- = "llvm_position_at_end"
+external builder : unit -> llbuilder = "llvm_builder"
+external position_builder : (llbasicblock, llvalue) llpos -> llbuilder -> unit
+ = "llvm_position_builder"
+external insertion_block : llbuilder -> llbasicblock = "llvm_insertion_block"
+
+let builder_at ip =
+ let b = builder () in
+ position_builder ip b;
+ b
+
+let builder_before i = builder_at (Before i)
+let builder_at_end bb = builder_at (At_end bb)
+
+let position_before i = position_builder (Before i)
+let position_at_end bb = position_builder (At_end bb)
+
(*--... Terminators ........................................................--*)
external build_ret_void : llbuilder -> llvalue = "llvm_build_ret_void"
llvalue = "llvm_build_cond_br"
external build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue
= "llvm_build_switch"
+external add_case : llvalue -> llvalue -> llbasicblock -> unit
+ = "llvm_add_case"
external build_invoke : llvalue -> llvalue array -> llbasicblock ->
llbasicblock -> string -> llbuilder -> llvalue
= "llvm_build_invoke_bc" "llvm_build_invoke_nat"
end
+(*===-- Pass Manager ------------------------------------------------------===*)
+
+module PassManager = struct
+ type 'a t
+ type any = [ `Module | `Function ]
+ external create : unit -> [ `Module ] t = "llvm_passmanager_create"
+ external create_function : llmoduleprovider -> [ `Function ] t
+ = "LLVMCreateFunctionPassManager"
+ external run_module : llmodule -> [ `Module ] t -> bool
+ = "llvm_passmanager_run_module"
+ external initialize : [ `Function ] t -> bool = "llvm_passmanager_initialize"
+ external run_function : llvalue -> [ `Function ] t -> bool
+ = "llvm_passmanager_run_function"
+ external finalize : [ `Function ] t -> bool = "llvm_passmanager_finalize"
+ external dispose : [< any ] t -> unit = "llvm_passmanager_dispose"
+end
+
+
(*===-- Non-Externs -------------------------------------------------------===*)
(* These functions are built using the externals, so must be declared late. *)
projects / oota-llvm.git / blobdiff