RPCS3/llvm-mirror
1
0
Fork 0
mirror of https://github.com/RPCS3/llvm-mirror.git synced 2024-10-19 02:52:53 +02:00
Code Issues Projects Releases Wiki Activity

[OCaml] Implement missing LLVMCore APIs

Browse Source 
llvm-svn: 193966
This commit is contained in:
Peter Zotov 2013-11-04 01:39:26 +00:00
parent d01f123fa7
commit 22f34b9373
4 changed files with 396 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
bindings/ocaml/llvm/llvm.ml
View File

@ -34,6 +34,7 @@ module TypeKind = struct
| Pointer
| Vector
| Metadata
| X86_mmx
end
module Linkage = struct
@ -42,6 +43,7 @@ module Linkage = struct
| Available_externally
| Link_once
| Link_once_odr
| Link_once_odr_auto_hide
| Weak
| Weak_odr
| Appending
@ -53,6 +55,7 @@ module Linkage = struct
| Ghost
| Common
| Linker_private
| Linker_private_weak
end
module Visibility = struct
@ -202,7 +205,48 @@ module Opcode = struct
| AtomicRMW
| Resume
| LandingPad
| Unwind
end
module LandingPadClauseTy = struct
type t =
| Catch
| Filter
end
module ThreadLocalMode = struct
type t =
| None
| GeneralDynamic
| LocalDynamic
| InitialExec
| LocalExec
end
module AtomicOrdering = struct
type t =
| NotAtomic
| Unordered
| Monotonic
| Invalid
| Acquire
| Release
| AcqiureRelease
| SequentiallyConsistent
end
module AtomicRMWBinOp = struct
type t =
| Xchg
| Add
| Sub
| And
| Nand
| Or
| Xor
| Max
| Min
| UMax
| UMin
end
module ValueKind = struct
@ -260,6 +304,8 @@ external data_layout: llmodule -> string
external set_data_layout: string -> llmodule -> unit
= "llvm_set_data_layout"
external dump_module : llmodule -> unit = "llvm_dump_module"
external print_module : string -> llmodule -> unit = "llvm_print_module"
external string_of_llmodule : llmodule -> string = "llvm_string_of_llmodule"
external set_module_inline_asm : llmodule -> string -> unit
= "llvm_set_module_inline_asm"
external module_context : llmodule -> llcontext = "LLVMGetModuleContext"
@ -268,6 +314,8 @@ external module_context : llmodule -> llcontext = "LLVMGetModuleContext"
external classify_type : lltype -> TypeKind.t = "llvm_classify_type"
external type_context : lltype -> llcontext = "llvm_type_context"
external type_is_sized : lltype -> bool = "llvm_type_is_sized"
external dump_type : lltype -> unit = "llvm_dump_type"
external string_of_lltype : lltype -> string = "llvm_string_of_lltype"
(*--... Operations on integer types ........................................--*)
external i1_type : llcontext -> lltype = "llvm_i1_type"
@ -323,6 +371,7 @@ external vector_size : lltype -> int = "llvm_vector_size"
(*--... Operations on other types ..........................................--*)
external void_type : llcontext -> lltype = "llvm_void_type"
external label_type : llcontext -> lltype = "llvm_label_type"
external x86_mmx_type : llcontext -> lltype = "llvm_x86_mmx_type"
external type_by_name : llmodule -> string -> lltype option = "llvm_type_by_name"
external classify_value : llvalue -> ValueKind.t = "llvm_classify_value"
@ -391,7 +440,10 @@ external clear_metadata : llvalue -> int -> unit = "llvm_clear_metadata"
external mdstring : llcontext -> string -> llvalue = "llvm_mdstring"
external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode"
external get_mdstring : llvalue -> string option = "llvm_get_mdstring"
external get_named_metadata : llmodule -> string -> llvalue array = "llvm_get_namedmd"
external get_named_metadata : llmodule -> string -> llvalue array
= "llvm_get_namedmd"
external add_named_metadata_operand : llmodule -> string -> llvalue -> unit
= "llvm_append_namedmd"
(*--... Operations on scalar constants .....................................--*)
external const_int : lltype -> int -> llvalue = "llvm_const_int"
@ -530,6 +582,14 @@ 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 thread_local_mode : llvalue -> ThreadLocalMode.t
= "llvm_thread_local_mode"
external set_thread_local_mode : ThreadLocalMode.t -> llvalue -> unit
= "llvm_set_thread_local_mode"
external is_externally_initialized : llvalue -> bool
= "llvm_is_externally_initialized"
external set_externally_initialized : bool -> llvalue -> unit
= "llvm_set_externally_initialized"
external global_begin : llmodule -> (llmodule, llvalue) llpos
= "llvm_global_begin"
external global_succ : llvalue -> (llmodule, llvalue) llpos
@ -725,6 +785,10 @@ let unpack_attr (a : int32) : Attribute.t list =
let add_function_attr llval attr =
llvm_add_function_attr llval (pack_attr attr)
external add_target_dependent_function_attr
: llvalue -> string -> string -> unit
= "llvm_add_target_dependent_function_attr"
let remove_function_attr llval attr =
llvm_remove_function_attr llval (pack_attr attr)
@ -803,6 +867,11 @@ 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 remove_block : llbasicblock -> unit = "llvm_remove_block"
external move_block_before : llbasicblock -> llbasicblock -> unit
= "llvm_move_block_before"
external move_block_after : llbasicblock -> llbasicblock -> unit
= "llvm_move_block_after"
external append_block : llcontext -> string -> llvalue -> llbasicblock
= "llvm_append_block"
external insert_block : llcontext -> string -> llbasicblock -> llbasicblock
@ -872,8 +941,6 @@ external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos
external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode"
external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate"
external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate"
let rec iter_instrs_range f i e =
if i = e then () else
match i with
@ -936,6 +1003,10 @@ let remove_instruction_param_attr llval i attr =
external is_tail_call : llvalue -> bool = "llvm_is_tail_call"
external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call"
(*--... Operations on load/store instructions (only) .......................--*)
external is_volatile : llvalue -> bool = "llvm_is_volatile"
external set_volatile : bool -> llvalue -> unit = "llvm_set_volatile"
(*--... Operations on phi nodes ............................................--*)
external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit
= "llvm_add_incoming"
@ -1078,6 +1149,11 @@ external build_load : llvalue -> string -> llbuilder -> llvalue
= "llvm_build_load"
external build_store : llvalue -> llvalue -> llbuilder -> llvalue
= "llvm_build_store"
external build_atomicrmw : AtomicRMWBinOp.t -> llvalue -> llvalue ->
AtomicOrdering.t -> bool -> string -> llbuilder ->
llvalue
= "llvm_build_atomicrmw_bytecode"
"llvm_build_atomicrmw_native"
external build_gep : llvalue -> llvalue array -> string -> llbuilder -> llvalue
= "llvm_build_gep"
external build_in_bounds_gep : llvalue -> llvalue array -> string ->
@ -1167,7 +1243,8 @@ external build_ptrdiff : llvalue -> llvalue -> string -> llbuilder -> llvalue
module MemoryBuffer = struct
external of_file : string -> llmemorybuffer = "llvm_memorybuffer_of_file"
external of_stdin : unit -> llmemorybuffer = "llvm_memorybuffer_of_stdin"
external of_string : ?name:string -> string -> llmemorybuffer = "llvm_memorybuffer_of_string"
external of_string : ?name:string -> string -> llmemorybuffer
= "llvm_memorybuffer_of_string"
external as_string : llmemorybuffer -> string = "llvm_memorybuffer_as_string"
external dispose : llmemorybuffer -> unit = "llvm_memorybuffer_dispose"
end
@ -1189,54 +1266,3 @@ module PassManager = struct
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. *)
let concat2 sep arr =
let s = ref "" in
if 0 < Array.length arr then begin
s := !s ^ arr.(0);
for i = 1 to (Array.length arr) - 1 do
s := !s ^ sep ^ arr.(i)
done
end;
!s
let rec string_of_lltype ty =
(* FIXME: stop infinite recursion! :) *)
match classify_type ty with
TypeKind.Integer -> "i" ^ string_of_int (integer_bitwidth ty)
| TypeKind.Pointer ->
(let ety = element_type ty in
match classify_type ety with
| TypeKind.Struct ->
(match struct_name ety with
| None -> (string_of_lltype ety)
| Some s -> s) ^ "*"
| _ -> (string_of_lltype (element_type ty)) ^ "*")
| TypeKind.Struct ->
let s = "{ " ^ (concat2 ", " (
Array.map string_of_lltype (struct_element_types ty)
)) ^ " }" in
if is_packed ty
then "<" ^ s ^ ">"
else s
| TypeKind.Array -> "[" ^ (string_of_int (array_length ty)) ^
" x " ^ (string_of_lltype (element_type ty)) ^ "]"
| TypeKind.Vector -> "<" ^ (string_of_int (vector_size ty)) ^
" x " ^ (string_of_lltype (element_type ty)) ^ ">"
| TypeKind.Function -> string_of_lltype (return_type ty) ^
" (" ^ (concat2 ", " (
Array.map string_of_lltype (param_types ty)
)) ^ ")"
| TypeKind.Label -> "label"
| TypeKind.Ppc_fp128 -> "ppc_fp128"
| TypeKind.Fp128 -> "fp128"
| TypeKind.X86fp80 -> "x86_fp80"
| TypeKind.Double -> "double"
| TypeKind.Float -> "float"
| TypeKind.Half -> "half"
| TypeKind.Void -> "void"
| TypeKind.Metadata -> "metadata"

137
bindings/ocaml/llvm/llvm.mli
View File

@ -67,6 +67,7 @@ module TypeKind : sig
| Pointer
| Vector
| Metadata
| X86_mmx
end
(** The linkage of a global value, accessed with {!linkage} and
@ -77,6 +78,7 @@ module Linkage : sig
| Available_externally
| Link_once
| Link_once_odr
| Link_once_odr_auto_hide
| Weak
| Weak_odr
| Appending
@ -88,6 +90,7 @@ module Linkage : sig
| Ghost
| Common
| Linker_private
| Linker_private_weak
end
(** The linker visibility of a global value, accessed with {!visibility} and
@ -252,7 +255,57 @@ module Opcode : sig
| AtomicRMW
| Resume
| LandingPad
| Unwind
end
(** The type of a clause of a [landingpad] instruction.
See [llvm::LandingPadInst::ClauseType]. *)
module LandingPadClauseTy : sig
type t =
| Catch
| Filter
end
(** The thread local mode of a global value, accessed with {!thread_local_mode}
and {!set_thread_local_mode}.
See [llvm::GlobalVariable::ThreadLocalMode]. *)
module ThreadLocalMode : sig
type t =
| None
| GeneralDynamic
| LocalDynamic
| InitialExec
| LocalExec
end
(** The ordering of an atomic [load], [store], [cmpxchg], [atomicrmw] or
[fence] instruction. See [llvm::AtomicOrdering]. *)
module AtomicOrdering : sig
type t =
| NotAtomic
| Unordered
| Monotonic
| Invalid (* removed due to API changes *)
| Acquire
| Release
| AcqiureRelease
| SequentiallyConsistent
end
(** The opcode of an [atomicrmw] instruction.
See [llvm::AtomicRMWInst::BinOp]. *)
module AtomicRMWBinOp : sig
type t =
| Xchg
| Add
| Sub
| And
| Nand
| Or
| Xor
| Max
| Min
| UMax
| UMin
end
(** The kind of an [llvalue], the result of [classify_value v].
@ -358,6 +411,14 @@ val set_data_layout: string -> llmodule -> unit
error. See the method [llvm::Module::dump]. *)
val dump_module : llmodule -> unit
(** [print_module f m] prints the .ll representation of the module [m]
to file [f]. See the method [llvm::Module::print]. *)
val print_module : string -> llmodule -> unit
(** [string_of_llmodule m] returns the .ll representation of the module [m]
as a string. See the method [llvm::Module::print]. *)
val string_of_llmodule : llmodule -> string
(** [set_module_inline_asm m asm] sets the inline assembler for the module. See
the method [llvm::Module::setModuleInlineAsm]. *)
val set_module_inline_asm : llmodule -> string -> unit
@ -382,6 +443,10 @@ val type_is_sized : lltype -> bool
See the method [llvm::Type::getContext]. *)
val type_context : lltype -> llcontext
(** [dump_type ty] prints the .ll representation of the type [ty] to standard
error. See the method [llvm::Type::dump]. *)
val dump_type : lltype -> unit
(** [string_of_lltype ty] returns a string describing the type [ty]. *)
val string_of_lltype : lltype -> string
@ -552,6 +617,10 @@ val void_type : llcontext -> lltype
[llvm::Type::LabelTy]. *)
val label_type : llcontext -> lltype
(** [x86_mmx_type c] returns the x86 64-bit MMX register type in the
context [c]. See [llvm::Type::X86_MMXTy]. *)
val x86_mmx_type : llcontext -> lltype
(** [type_by_name m name] returns the specified type from the current module
if it exists.
See the method [llvm::Module::getTypeByName] *)
@ -707,6 +776,13 @@ val get_mdstring : llvalue -> string option
See the method [llvm::NamedMDNode::getOperand]. *)
val get_named_metadata : llmodule -> string -> llvalue array
(** [add_named_metadata_operand m name v] adds [v] as the last operand of
metadata named [name] in module [m]. If the metadata does not exist,
it is created.
See the methods [llvm::Module::getNamedMetadata()] and
[llvm::MDNode::addOperand()]. *)
val add_named_metadata_operand : llmodule -> string -> llvalue -> unit
(** {7 Operations on scalar constants} *)
@ -1243,6 +1319,26 @@ val is_thread_local : llvalue -> bool
See the method [llvm::GlobalVariable::setThreadLocal]. *)
val set_thread_local : bool -> llvalue -> unit
(** [is_thread_local gv] returns the thread local mode of the global
variable [gv].
See the method [llvm::GlobalVariable::getThreadLocalMode]. *)
val thread_local_mode : llvalue -> ThreadLocalMode.t
(** [set_thread_local c gv] sets the thread local mode of the global
variable [gv].
See the method [llvm::GlobalVariable::setThreadLocalMode]. *)
val set_thread_local_mode : ThreadLocalMode.t -> llvalue -> unit
(** [is_externally_initialized gv] returns [true] if the global
variable [gv] is externally initialized and [false] otherwise.
See the method [llvm::GlobalVariable::isExternallyInitialized]. *)
val is_externally_initialized : llvalue -> bool
(** [set_externally_initialized c gv] sets the global variable [gv] to be
externally initialized if [c] is [true] and not otherwise.
See the method [llvm::GlobalVariable::setExternallyInitialized]. *)
val set_externally_initialized : bool -> llvalue -> unit
(** {7 Operations on aliases} *)
@ -1338,6 +1434,10 @@ val set_gc : string option -> llvalue -> unit
[f]. *)
val add_function_attr : llvalue -> Attribute.t -> unit
(** [add_target_dependent_function_attr f a] adds target-dependent attribute
[a] to function [f]. *)
val add_target_dependent_function_attr : llvalue -> string -> string -> unit
(** [function_attr f] returns the function attribute for the function [f].
See the method [llvm::Function::getAttributes] *)
val function_attr : llvalue -> Attribute.t list
@ -1427,6 +1527,18 @@ val entry_block : llvalue -> llbasicblock
See the method [llvm::BasicBlock::eraseFromParent]. *)
val delete_block : llbasicblock -> unit
(** [remove_block bb] removes the basic block [bb] from its parent function.
See the method [llvm::BasicBlock::removeFromParent]. *)
val remove_block : llbasicblock -> unit
(** [move_block_before pos bb] moves the basic block [bb] before [pos].
See the method [llvm::BasicBlock::moveBefore]. *)
val move_block_before : llbasicblock -> llbasicblock -> unit
(** [move_block_after pos bb] moves the basic block [bb] after [pos].
See the method [llvm::BasicBlock::moveAfter]. *)
val move_block_after : llbasicblock -> llbasicblock -> unit
(** [append_block c name f] creates a new basic block named [name] at the end of
function [f] in the context [c].
See the constructor of [llvm::BasicBlock]. *)
@ -1574,6 +1686,21 @@ val is_tail_call : llvalue -> bool
val set_tail_call : bool -> llvalue -> unit
(** {7 Operations on load/store instructions (only)} *)
(** [is_volatile i] is [true] if the load or store instruction [i] is marked
as volatile.
See the methods [llvm::LoadInst::isVolatile] and
[llvm::StoreInst::isVolatile]. *)
val is_volatile : llvalue -> bool
(** [set_volatile v i] marks the load or store instruction [i] as volatile
if [v] is [true], unmarks otherwise.
See the methods [llvm::LoadInst::setVolatile] and
[llvm::StoreInst::setVolatile]. *)
val set_volatile : bool -> llvalue -> unit
(** {7 Operations on phi nodes} *)
(** [add_incoming (v, bb) pn] adds the value [v] to the phi node [pn] for use
@ -1982,6 +2109,14 @@ val build_load : llvalue -> string -> llbuilder -> llvalue
See the method [llvm::LLVMBuilder::CreateStore]. *)
val build_store : llvalue -> llvalue -> llbuilder -> llvalue
(** [build_atomicrmw op ptr val o st b] creates an [atomicrmw] instruction with
operation [op] performed on pointer [ptr] and value [val] with ordering [o]
and singlethread flag set to [st] at the position specified by
the instruction builder [b].
See the method [llvm::IRBuilder::CreateAtomicRMW]. *)
val build_atomicrmw : AtomicRMWBinOp.t -> llvalue -> llvalue ->
AtomicOrdering.t -> bool -> string -> llbuilder -> llvalue
(** [build_gep p indices name b] creates a
[%name = getelementptr %p, indices...]
instruction at the position specified by the instruction builder [b].

136
bindings/ocaml/llvm/llvm_ocaml.c
View File

@ -158,6 +158,27 @@ CAMLprim value llvm_dump_module(LLVMModuleRef M) {
return Val_unit;
}
/* string -> llmodule -> unit */
CAMLprim value llvm_print_module(value Filename, LLVMModuleRef M) {
char* Message;
if(LLVMPrintModuleToFile(M, String_val(Filename), &Message)) {
llvm_raise(llvm_ioerror_exn, Message);
}
return Val_unit;
}
/* llmodule -> string */
CAMLprim value llvm_string_of_llmodule(LLVMModuleRef M) {
char* ModuleCStr;
ModuleCStr = LLVMPrintModuleToString(M);
value ModuleStr = caml_copy_string(ModuleCStr);
LLVMDisposeMessage(ModuleCStr);
return ModuleStr;
}
/* llmodule -> string -> unit */
CAMLprim value llvm_set_module_inline_asm(LLVMModuleRef M, value Asm) {
LLVMSetModuleInlineAsm(M, String_val(Asm));
@ -180,6 +201,23 @@ CAMLprim LLVMContextRef llvm_type_context(LLVMTypeRef Ty) {
return LLVMGetTypeContext(Ty);
}
/* lltype -> unit */
CAMLprim value llvm_dump_type(LLVMTypeRef Val) {
LLVMDumpType(Val);
return Val_unit;
}
/* lltype -> string */
CAMLprim value llvm_string_of_lltype(LLVMTypeRef M) {
char* TypeCStr;
TypeCStr = LLVMPrintTypeToString(M);
value TypeStr = caml_copy_string(TypeCStr);
LLVMDisposeMessage(TypeCStr);
return TypeStr;
}
/*--... Operations on integer types ........................................--*/
/* llcontext -> lltype */
@ -244,11 +282,6 @@ CAMLprim LLVMTypeRef llvm_ppc_fp128_type(LLVMContextRef Context) {
return LLVMPPCFP128TypeInContext(Context);
}
/* llcontext -> lltype */
CAMLprim LLVMTypeRef llvm_x86mmx_type(LLVMContextRef Context) {
return LLVMX86MMXTypeInContext(Context);
}
/*--... Operations on function types .......................................--*/
/* lltype -> lltype array -> lltype */
@ -386,6 +419,11 @@ CAMLprim LLVMTypeRef llvm_label_type(LLVMContextRef Context) {
return LLVMLabelTypeInContext(Context);
}
/* llcontext -> lltype */
CAMLprim LLVMTypeRef llvm_x86_mmx_type(LLVMContextRef Context) {
return LLVMX86MMXTypeInContext(Context);
}
CAMLprim value llvm_type_by_name(LLVMModuleRef M, value Name)
{
CAMLparam1(Name);
@ -605,6 +643,13 @@ CAMLprim value llvm_get_namedmd(LLVMModuleRef M, value Name)
LLVMGetNamedMetadataOperands(M, String_val(Name), (LLVMValueRef *) Nodes);
CAMLreturn(Nodes);
}
/* llmodule -> string -> llvalue -> unit */
CAMLprim value llvm_append_namedmd(LLVMModuleRef M, value Name, LLVMValueRef Val) {
LLVMAddNamedMetadataOperand(M, String_val(Name), Val);
return Val_unit;
}
/*--... Operations on scalar constants .....................................--*/
/* lltype -> int -> llvalue */
@ -952,6 +997,30 @@ CAMLprim value llvm_set_thread_local(value IsThreadLocal,
return Val_unit;
}
/* llvalue -> ThreadLocalMode.t */
CAMLprim value llvm_thread_local_mode(LLVMValueRef GlobalVar) {
return Val_int(LLVMGetThreadLocalMode(GlobalVar));
}
/* ThreadLocalMode.t -> llvalue -> unit */
CAMLprim value llvm_set_thread_local_mode(value ThreadLocalMode,
LLVMValueRef GlobalVar) {
LLVMSetThreadLocalMode(GlobalVar, Int_val(ThreadLocalMode));
return Val_unit;
}
/* llvalue -> bool */
CAMLprim value llvm_is_externally_initialized(LLVMValueRef GlobalVar) {
return Val_bool(LLVMIsExternallyInitialized(GlobalVar));
}
/* bool -> llvalue -> unit */
CAMLprim value llvm_set_externally_initialized(value IsExternallyInitialized,
LLVMValueRef GlobalVar) {
LLVMSetExternallyInitialized(GlobalVar, Bool_val(IsExternallyInitialized));
return Val_unit;
}
/* llvalue -> bool */
CAMLprim value llvm_is_global_constant(LLVMValueRef GlobalVar) {
return Val_bool(LLVMIsGlobalConstant(GlobalVar));
@ -1058,6 +1127,13 @@ CAMLprim value llvm_add_function_attr(LLVMValueRef Arg, value PA) {
return Val_unit;
}
/* llvalue -> string -> string -> unit */
CAMLprim value llvm_add_target_dependent_function_attr(
LLVMValueRef Arg, value A, value V) {
LLVMAddTargetDependentFunctionAttr(Arg, String_val(A), String_val(V));
return Val_unit;
}
/* llvalue -> int32 */
CAMLprim value llvm_function_attr(LLVMValueRef Fn)
{
@ -1142,6 +1218,24 @@ CAMLprim value llvm_delete_block(LLVMBasicBlockRef BB) {
return Val_unit;
}
/* llbasicblock -> unit */
CAMLprim value llvm_remove_block(LLVMBasicBlockRef BB) {
LLVMRemoveBasicBlockFromParent(BB);
return Val_unit;
}
/* llbasicblock -> llbasicblock -> unit */
CAMLprim value llvm_move_block_before(LLVMBasicBlockRef Pos, LLVMBasicBlockRef BB) {
LLVMMoveBasicBlockBefore(BB, Pos);
return Val_unit;
}
/* llbasicblock -> llbasicblock -> unit */
CAMLprim value llvm_move_block_after(LLVMBasicBlockRef Pos, LLVMBasicBlockRef BB) {
LLVMMoveBasicBlockAfter(BB, Pos);
return Val_unit;
}
/* string -> llvalue -> llbasicblock */
CAMLprim LLVMBasicBlockRef llvm_append_block(LLVMContextRef Context, value Name,
LLVMValueRef Fn) {
@ -1230,6 +1324,20 @@ CAMLprim value llvm_set_tail_call(value IsTailCall,
return Val_unit;
}
/*--... Operations on load/store instructions (only)........................--*/
/* llvalue -> bool */
CAMLprim value llvm_is_volatile(LLVMValueRef MemoryInst) {
return Val_bool(LLVMGetVolatile(MemoryInst));
}
/* bool -> llvalue -> unit */
CAMLprim value llvm_set_volatile(value IsVolatile,
LLVMValueRef MemoryInst) {
LLVMSetVolatile(MemoryInst, Bool_val(IsVolatile));
return Val_unit;
}
/*--... Operations on phi nodes ............................................--*/
/* (llvalue * llbasicblock) -> llvalue -> unit */
@ -1701,6 +1809,24 @@ CAMLprim LLVMValueRef llvm_build_store(LLVMValueRef Value, LLVMValueRef Pointer,
return LLVMBuildStore(Builder_val(B), Value, Pointer);
}
/* AtomicRMWBinOp.t -> llvalue -> llvalue -> AtomicOrdering.t ->
bool -> llbuilder -> llvalue */
CAMLprim LLVMValueRef llvm_build_atomicrmw_native(value BinOp, LLVMValueRef Ptr,
LLVMValueRef Val, value Ord,
value ST, value Name, value B) {
LLVMValueRef Instr;
Instr = LLVMBuildAtomicRMW(Builder_val(B), Int_val(BinOp),
Ptr, Val, Int_val(Ord), Bool_val(ST));
LLVMSetValueName(Instr, String_val(Name));
return Instr;
}
CAMLprim LLVMValueRef llvm_build_atomicrmw_bytecode(value *argv, int argn) {
return llvm_build_atomicrmw_native(argv[0], (LLVMValueRef) argv[1],
(LLVMValueRef) argv[2], argv[3],
argv[4], argv[5], argv[6]);
}
/* llvalue -> llvalue array -> string -> llbuilder -> llvalue */
CAMLprim LLVMValueRef llvm_build_gep(LLVMValueRef Pointer, value Indices,
value Name, value B) {

53
test/Bindings/Ocaml/vmcore.ml
View File

@ -452,10 +452,24 @@ let test_global_variables () =
set_thread_local true in
insist (is_thread_local g);
(* CHECK-NOWHERE-NOT: GVar05
(* CHECK: GVar05{{.*}}thread_local(initialexec)
*)
group "threadlocal_mode";
let g = define_global "GVar05" fourty_two32 m ++
set_thread_local_mode ThreadLocalMode.InitialExec in
insist ((thread_local_mode g) = ThreadLocalMode.InitialExec);
(* CHECK: GVar06{{.*}}externally_initialized
*)
group "externally_initialized";
let g = define_global "GVar06" fourty_two32 m ++
set_externally_initialized true in
insist (is_externally_initialized g);
(* CHECK-NOWHERE-NOT: GVar07
*)
group "delete";
let g = define_global "GVar05" fourty_two32 m in
let g = define_global "GVar07" fourty_two32 m in
delete_global g;
(* CHECK: ConstGlobalVar{{.*}}constant
@ -1027,6 +1041,16 @@ let test_builder () =
set_metadata i kind md
end;
group "named metadata"; begin
(* !md is emitted at EOF. *)
let n1 = const_int i32_type 1 in
let n2 = mdstring context "metadata test" in
let md = mdnode context [| n1; n2 |] in
add_named_metadata_operand m "md" md;
insist ((get_named_metadata m "md") = [| md |])
end;
group "dbg"; begin
(* CHECK: %dbg = add i32 %P1, %P2, !dbg !1
* !1 is metadata emitted at EOF.
@ -1237,16 +1261,27 @@ let test_builder () =
(* CHECK: %build_alloca = alloca i32
* CHECK: %build_array_alloca = alloca i32, i32 %P2
* CHECK: %build_load = load i32* %build_array_alloca
* CHECK: store i32 %P2, i32* %build_alloca
* CHECK: %build_load = load volatile i32* %build_array_alloca, align 4
* CHECK: store volatile i32 %P2, i32* %build_alloca, align 4
* CHECK: %build_gep = getelementptr i32* %build_array_alloca, i32 %P2
* CHECK: %build_in_bounds_gep = getelementptr inbounds i32* %build_array_alloca, i32 %P2
* CHECK: %build_struct_gep = getelementptr inbounds{{.*}}%build_alloca2, i32 0, i32 1
* CHECK: %build_atomicrmw = atomicrmw xchg i8* %p, i8 42 seq_cst
*)
let alloca = build_alloca i32_type "build_alloca" b in
let array_alloca = build_array_alloca i32_type p2 "build_array_alloca" b in
ignore(build_load array_alloca "build_load" b);
ignore(build_store p2 alloca b);
let load = build_load array_alloca "build_load" b in
ignore(set_alignment 4 load);
ignore(set_volatile true load);
insist(true = is_volatile load);
insist(4 = alignment load);
let store = build_store p2 alloca b in
ignore(set_volatile true store);
ignore(set_alignment 4 store);
insist(true = is_volatile store);
insist(4 = alignment store);
ignore(build_gep array_alloca [| p2 |] "build_gep" b);
ignore(build_in_bounds_gep array_alloca [| p2 |] "build_in_bounds_gep" b);
@ -1254,6 +1289,11 @@ let test_builder () =
let alloca2 = build_alloca sty "build_alloca2" b in
ignore(build_struct_gep alloca2 1 "build_struct_gep" b);
let p = build_alloca i8_type "p" b in
ignore(build_atomicrmw AtomicRMWBinOp.Xchg p (const_int i8_type 42)
AtomicOrdering.SequentiallyConsistent false "build_atomicrmw"
b);
ignore(build_unreachable b)
end;
@ -1292,6 +1332,7 @@ let test_builder () =
(* End-of-file checks for things like metdata and attributes.
* CHECK: attributes #0 = {{.*}}uwtable{{.*}}
* CHECK: !md = !{!0}
* CHECK: !0 = metadata !{i32 1, metadata !"metadata test"}
* CHECK: !1 = metadata !{i32 2, i32 3, metadata !2, metadata !2}
*)