RPCS3/llvm
1
0
Fork 0
mirror of https://github.com/RPCS3/llvm.git synced 2024-11-25 12:49:50 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

[OCaml] Adapt to the new attribute C API.

Browse Source 
git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@286705 91177308-0d34-0410-b5e6-96231b3b80d8
This commit is contained in:
whitequark 2016-11-12 03:38:30 +00:00
parent b1cfc87891
commit 18c0ee2638
5 changed files with 354 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,8 @@ type llvalue
type lluse
type llbasicblock
type llbuilder
type llattrkind
type llattribute
type llmemorybuffer
type llmdkind
@ -81,6 +83,25 @@ module CallConv = struct
let x86_fastcall = 65
end
module AttrRepr = struct
type t =
| Enum of llattrkind * int64
| String of string * string
end
module AttrIndex = struct
type t =
| Function
| Return
| Param of int
let to_int index =
match index with
| Function -> -1
| Return -> 0
| Param(n) -> 1 + n
end
module Attribute = struct
type t =
| Zext
@ -332,6 +353,47 @@ external dispose_context : llcontext -> unit = "llvm_dispose_context"
external global_context : unit -> llcontext = "llvm_global_context"
external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
(*===-- Attributes --------------------------------------------------------===*)
exception UnknownAttribute of string
let () = Callback.register_exception "Llvm.UnknownAttribute"
(UnknownAttribute "")
external enum_attr_kind : string -> llattrkind = "llvm_enum_attr_kind"
external llvm_create_enum_attr : llcontext -> llattrkind -> int64 ->
llattribute
= "llvm_create_enum_attr_by_kind"
external is_enum_attr : llattribute -> bool = "llvm_is_enum_attr"
external get_enum_attr_kind : llattribute -> llattrkind
= "llvm_get_enum_attr_kind"
external get_enum_attr_value : llattribute -> int64
= "llvm_get_enum_attr_value"
external llvm_create_string_attr : llcontext -> string -> string ->
llattribute
= "llvm_create_string_attr"
external is_string_attr : llattribute -> bool = "llvm_is_string_attr"
external get_string_attr_kind : llattribute -> string
= "llvm_get_string_attr_kind"
external get_string_attr_value : llattribute -> string
= "llvm_get_string_attr_value"
let create_enum_attr context name value =
llvm_create_enum_attr context (enum_attr_kind name) value
let create_string_attr context kind value =
llvm_create_string_attr context kind value
let attr_of_repr context repr =
match repr with
| AttrRepr.Enum(kind, value) -> llvm_create_enum_attr context kind value
| AttrRepr.String(key, value) -> llvm_create_string_attr context key value
let repr_of_attr attr =
if is_enum_attr attr then
AttrRepr.Enum(get_enum_attr_kind attr, get_enum_attr_value attr)
else if is_string_attr attr then
AttrRepr.String(get_string_attr_kind attr, get_string_attr_value attr)
else assert false
(*===-- Modules -----------------------------------------------------------===*)
external create_module : llcontext -> string -> llmodule = "llvm_create_module"
external dispose_module : llmodule -> unit = "llvm_dispose_module"
@ -760,99 +822,27 @@ let rec fold_right_function_range f i e init =
let fold_right_functions f m init =
fold_right_function_range f (function_end m) (At_start m) init
external llvm_add_function_attr : llvalue -> int32 -> unit
external llvm_add_function_attr : llvalue -> llattribute -> int -> unit
= "llvm_add_function_attr"
external llvm_remove_function_attr : llvalue -> int32 -> unit
= "llvm_remove_function_attr"
external llvm_function_attr : llvalue -> int32 = "llvm_function_attr"
external llvm_function_attrs : llvalue -> int -> llattribute array
= "llvm_function_attrs"
external llvm_remove_enum_function_attr : llvalue -> llattrkind -> int -> unit
= "llvm_remove_enum_function_attr"
external llvm_remove_string_function_attr : llvalue -> string -> int -> unit
= "llvm_remove_string_function_attr"
let pack_attr (attr:Attribute.t) : int32 =
match attr with
Attribute.Zext -> Int32.shift_left 1l 0
| Attribute.Sext -> Int32.shift_left 1l 1
| Attribute.Noreturn -> Int32.shift_left 1l 2
| Attribute.Inreg -> Int32.shift_left 1l 3
| Attribute.Structret -> Int32.shift_left 1l 4
| Attribute.Nounwind -> Int32.shift_left 1l 5
| Attribute.Noalias -> Int32.shift_left 1l 6
| Attribute.Byval -> Int32.shift_left 1l 7
| Attribute.Nest -> Int32.shift_left 1l 8
| Attribute.Readnone -> Int32.shift_left 1l 9
| Attribute.Readonly -> Int32.shift_left 1l 10
| Attribute.Noinline -> Int32.shift_left 1l 11
| Attribute.Alwaysinline -> Int32.shift_left 1l 12
| Attribute.Optsize -> Int32.shift_left 1l 13
| Attribute.Ssp -> Int32.shift_left 1l 14
| Attribute.Sspreq -> Int32.shift_left 1l 15
| Attribute.Alignment n -> Int32.shift_left (Int32.of_int n) 16
| Attribute.Nocapture -> Int32.shift_left 1l 21
| Attribute.Noredzone -> Int32.shift_left 1l 22
| Attribute.Noimplicitfloat -> Int32.shift_left 1l 23
| Attribute.Naked -> Int32.shift_left 1l 24
| Attribute.Inlinehint -> Int32.shift_left 1l 25
| Attribute.Stackalignment n -> Int32.shift_left (Int32.of_int n) 26
| Attribute.ReturnsTwice -> Int32.shift_left 1l 29
| Attribute.UWTable -> Int32.shift_left 1l 30
| Attribute.NonLazyBind -> Int32.shift_left 1l 31
let unpack_attr (a : int32) : Attribute.t list =
let l = ref [] in
let check attr =
Int32.logand (pack_attr attr) a in
let checkattr attr =
if (check attr) <> 0l then begin
l := attr :: !l
end
in
checkattr Attribute.Zext;
checkattr Attribute.Sext;
checkattr Attribute.Noreturn;
checkattr Attribute.Inreg;
checkattr Attribute.Structret;
checkattr Attribute.Nounwind;
checkattr Attribute.Noalias;
checkattr Attribute.Byval;
checkattr Attribute.Nest;
checkattr Attribute.Readnone;
checkattr Attribute.Readonly;
checkattr Attribute.Noinline;
checkattr Attribute.Alwaysinline;
checkattr Attribute.Optsize;
checkattr Attribute.Ssp;
checkattr Attribute.Sspreq;
let align = Int32.logand (Int32.shift_right_logical a 16) 31l in
if align <> 0l then
l := Attribute.Alignment (Int32.to_int align) :: !l;
checkattr Attribute.Nocapture;
checkattr Attribute.Noredzone;
checkattr Attribute.Noimplicitfloat;
checkattr Attribute.Naked;
checkattr Attribute.Inlinehint;
let stackalign = Int32.logand (Int32.shift_right_logical a 26) 7l in
if stackalign <> 0l then
l := Attribute.Stackalignment (Int32.to_int stackalign) :: !l;
checkattr Attribute.ReturnsTwice;
checkattr Attribute.UWTable;
checkattr Attribute.NonLazyBind;
!l;;
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)
let function_attr f = unpack_attr (llvm_function_attr f)
let add_function_attr f a i =
llvm_add_function_attr f a (AttrIndex.to_int i)
let function_attrs f i =
llvm_function_attrs f (AttrIndex.to_int i)
let remove_enum_function_attr f k i =
llvm_remove_enum_function_attr f k (AttrIndex.to_int i)
let remove_string_function_attr f k i =
llvm_remove_string_function_attr f k (AttrIndex.to_int i)
(*--... Operations on params ...............................................--*)
external params : llvalue -> llvalue array = "llvm_params"
external param : llvalue -> int -> llvalue = "llvm_param"
external llvm_param_attr : llvalue -> int32 = "llvm_param_attr"
let param_attr p = unpack_attr (llvm_param_attr p)
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"
@ -899,20 +889,6 @@ let rec fold_right_param_range f init i e =
let fold_right_params f fn init =
fold_right_param_range f init (param_end fn) (At_start fn)
external llvm_add_param_attr : llvalue -> int32 -> unit
= "llvm_add_param_attr"
external llvm_remove_param_attr : llvalue -> int32 -> unit
= "llvm_remove_param_attr"
let add_param_attr llval attr =
llvm_add_param_attr llval (pack_attr attr)
let remove_param_attr llval attr =
llvm_remove_param_attr llval (pack_attr attr)
external set_param_alignment : llvalue -> int -> unit
= "llvm_set_param_alignment"
(*--... Operations on basic blocks .........................................--*)
external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
external value_is_block : llvalue -> bool = "llvm_value_is_block"
@ -1044,16 +1020,23 @@ external instruction_call_conv: llvalue -> int
external set_instruction_call_conv: int -> llvalue -> unit
= "llvm_set_instruction_call_conv"
external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit
= "llvm_add_instruction_param_attr"
external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit
= "llvm_remove_instruction_param_attr"
external llvm_add_call_site_attr : llvalue -> llattribute -> int -> unit
= "llvm_add_call_site_attr"
external llvm_call_site_attrs : llvalue -> int -> llattribute array
= "llvm_call_site_attrs"
external llvm_remove_enum_call_site_attr : llvalue -> llattrkind -> int -> unit
= "llvm_remove_enum_call_site_attr"
external llvm_remove_string_call_site_attr : llvalue -> string -> int -> unit
= "llvm_remove_string_call_site_attr"
let add_instruction_param_attr llval i attr =
llvm_add_instruction_param_attr llval i (pack_attr attr)
let remove_instruction_param_attr llval i attr =
llvm_remove_instruction_param_attr llval i (pack_attr attr)
let add_call_site_attr f a i =
llvm_add_call_site_attr f a (AttrIndex.to_int i)
let call_site_attrs f i =
llvm_call_site_attrs f (AttrIndex.to_int i)
let remove_enum_call_site_attr f k i =
llvm_remove_enum_call_site_attr f k (AttrIndex.to_int i)
let remove_string_call_site_attr f k i =
llvm_remove_string_call_site_attr f k (AttrIndex.to_int i)
(*--... Operations on call instructions (only) .............................--*)
external is_tail_call : llvalue -> bool = "llvm_is_tail_call"

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

@ -44,6 +44,12 @@ type llbasicblock
class. *)
type llbuilder
(** Used to represent attribute kinds. *)
type llattrkind
(** An attribute in LLVM IR. See the [llvm::Attribute] class. *)
type llattribute
(** Used to efficiently handle large buffers of read-only binary data.
See the [llvm::MemoryBuffer] class. *)
type llmemorybuffer
@ -130,36 +136,19 @@ module CallConv : sig
convention from C. *)
end
(** The attribute kind of a function parameter, result or the function itself.
See [llvm::Attribute::AttrKind]. *)
module Attribute : sig
(** The logical representation of an attribute. *)
module AttrRepr : sig
type t =
| Zext
| Sext
| Noreturn
| Inreg
| Structret
| Nounwind
| Noalias
| Byval
| Nest
| Readnone
| Readonly
| Noinline
| Alwaysinline
| Optsize
| Ssp
| Sspreq
| Alignment of int
| Nocapture
| Noredzone
| Noimplicitfloat
| Naked
| Inlinehint
| Stackalignment of int
| ReturnsTwice
| UWTable
| NonLazyBind
| Enum of llattrkind * int64
| String of string * string
end
(** The position of an attribute. See [LLVMAttributeIndex]. *)
module AttrIndex : sig
type t =
| Function
| Return
| Param of int
end
(** The predicate for an integer comparison ([icmp]) instruction.
@ -443,6 +432,36 @@ val global_context : unit -> llcontext
val mdkind_id : llcontext -> string -> llmdkind
(** {6 Attributes} *)
(** [UnknownAttribute attr] is raised when a enum attribute name [name]
is not recognized by LLVM. *)
exception UnknownAttribute of string
(** [enum_attr_kind name] returns the kind of enum attributes named [name].
May raise [UnknownAttribute]. *)
val enum_attr_kind : string -> llattrkind
(** [create_enum_attr context value kind] creates an enum attribute
with the supplied [kind] and [value] in [context]; if the value
is not required (as for the majority of attributes), use [0L].
May raise [UnknownAttribute].
See the constructor [llvm::Attribute::get]. *)
val create_enum_attr : llcontext -> string -> int64 -> llattribute
(** [create_string_attr context kind value] creates a string attribute
with the supplied [kind] and [value] in [context].
See the constructor [llvm::Attribute::get]. *)
val create_string_attr : llcontext -> string -> string -> llattribute
(** [attr_of_repr context repr] creates an attribute with the supplied
representation [repr] in [context]. *)
val attr_of_repr : llcontext -> AttrRepr.t -> llattribute
(** [repr_of_attr attr] describes the representation of attribute [attr]. *)
val repr_of_attr : llattribute -> AttrRepr.t
(** {6 Modules} *)
(** [create_module context id] creates a module with the supplied module ID in
@ -1547,21 +1566,21 @@ val gc : llvalue -> string option
[gc]. See the method [llvm::Function::setGC]. *)
val set_gc : string option -> llvalue -> unit
(** [add_function_attr f a] adds attribute [a] to the return type of function
[f]. *)
val add_function_attr : llvalue -> Attribute.t -> unit
(** [add_function_attr f a i] adds attribute [a] to the function [f]
at position [i]. *)
val add_function_attr : llvalue -> llattribute -> AttrIndex.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_attrs f i] returns the attributes for the function [f]
at position [i]. *)
val function_attrs : llvalue -> AttrIndex.t -> llattribute array
(** [function_attr f] returns the function attribute for the function [f].
See the method [llvm::Function::getAttributes] *)
val function_attr : llvalue -> Attribute.t list
(** [remove_enum_function_attr f k i] removes enum attribute with kind [k]
from the function [f] at position [i]. *)
val remove_enum_function_attr : llvalue -> llattrkind -> AttrIndex.t -> unit
(** [remove_function_attr f a] removes attribute [a] from the return type of
function [f]. *)
val remove_function_attr : llvalue -> Attribute.t -> unit
(** [remove_string_function_attr f k i] removes string attribute with kind [k]
from the function [f] at position [i]. *)
val remove_string_function_attr : llvalue -> string -> AttrIndex.t -> unit
(** {7 Operations on params} *)
@ -1574,11 +1593,6 @@ val params : llvalue -> llvalue array
See the method [llvm::Function::getArgumentList]. *)
val param : llvalue -> int -> llvalue
(** [param_attr p] returns the attributes of parameter [p].
See the methods [llvm::Function::getAttributes] and
[llvm::Attributes::getParamAttributes] *)
val param_attr : llvalue -> Attribute.t list
(** [param_parent p] returns the parent function that owns the parameter.
See the method [llvm::Argument::getParent]. *)
val param_parent : llvalue -> llvalue
@ -1620,15 +1634,6 @@ val rev_iter_params : (llvalue -> unit) -> llvalue -> unit
[b1,...,bN] are the parameters of function [fn]. Tail recursive. *)
val fold_right_params : (llvalue -> 'a -> 'a) -> llvalue -> 'a -> 'a
(** [add_param p a] adds attribute [a] to parameter [p]. *)
val add_param_attr : llvalue -> Attribute.t -> unit
(** [remove_param_attr p a] removes attribute [a] from parameter [p]. *)
val remove_param_attr : llvalue -> Attribute.t -> unit
(** [set_param_alignment p a] set the alignment of parameter [p] to [a]. *)
val set_param_alignment : llvalue -> int -> unit
(** {7 Operations on basic blocks} *)
@ -1797,15 +1802,21 @@ val instruction_call_conv: llvalue -> int
and [llvm::InvokeInst::setCallingConv]. *)
val set_instruction_call_conv: int -> llvalue -> unit
(** [add_instruction_param_attr ci i a] adds attribute [a] to the [i]th
parameter of the call or invoke instruction [ci]. [i]=0 denotes the return
value. *)
val add_instruction_param_attr : llvalue -> int -> Attribute.t -> unit
(** [add_call_site_attr f a i] adds attribute [a] to the call instruction [ci]
at position [i]. *)
val add_call_site_attr : llvalue -> llattribute -> AttrIndex.t -> unit
(** [remove_instruction_param_attr ci i a] removes attribute [a] from the
[i]th parameter of the call or invoke instruction [ci]. [i]=0 denotes the
return value. *)
val remove_instruction_param_attr : llvalue -> int -> Attribute.t -> unit
(** [call_site_attr f i] returns the attributes for the call instruction [ci]
at position [i]. *)
val call_site_attrs : llvalue -> AttrIndex.t -> llattribute array
(** [remove_enum_call_site_attr f k i] removes enum attribute with kind [k]
from the call instruction [ci] at position [i]. *)
val remove_enum_call_site_attr : llvalue -> llattrkind -> AttrIndex.t -> unit
(** [remove_string_call_site_attr f k i] removes string attribute with kind [k]
from the call instruction [ci] at position [i]. *)
val remove_string_call_site_attr : llvalue -> string -> AttrIndex.t -> unit
(** {7 Operations on call instructions (only)} *)

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

@ -185,6 +185,69 @@ CAMLprim value llvm_mdkind_id(LLVMContextRef C, value Name) {
return Val_int(MDKindID);
}
/*===-- Attributes --------------------------------------------------------===*/
/* string -> llattrkind */
CAMLprim value llvm_enum_attr_kind(value Name) {
unsigned Kind = LLVMGetEnumAttributeKindForName(
String_val(Name), caml_string_length(Name));
if(Kind == 0)
caml_raise_with_arg(*caml_named_value("Llvm.UnknownAttribute"), Name);
return Val_int(Kind);
}
/* llcontext -> int -> int64 -> llattribute */
CAMLprim LLVMAttributeRef
llvm_create_enum_attr_by_kind(LLVMContextRef C, value Kind, value Value) {
return LLVMCreateEnumAttribute(C, Int_val(Kind), Int64_val(Value));
}
/* llattribute -> bool */
CAMLprim value llvm_is_enum_attr(LLVMAttributeRef A) {
return Val_int(LLVMIsEnumAttribute(A));
}
/* llattribute -> llattrkind */
CAMLprim value llvm_get_enum_attr_kind(LLVMAttributeRef A) {
return Val_int(LLVMGetEnumAttributeKind(A));
}
/* llattribute -> int64 */
CAMLprim value llvm_get_enum_attr_value(LLVMAttributeRef A) {
return caml_copy_int64(LLVMGetEnumAttributeValue(A));
}
/* llcontext -> kind:string -> name:string -> llattribute */
CAMLprim LLVMAttributeRef llvm_create_string_attr(LLVMContextRef C,
value Kind, value Value) {
return LLVMCreateStringAttribute(C,
String_val(Kind), caml_string_length(Kind),
String_val(Value), caml_string_length(Value));
}
/* llattribute -> bool */
CAMLprim value llvm_is_string_attr(LLVMAttributeRef A) {
return Val_int(LLVMIsStringAttribute(A));
}
/* llattribute -> string */
CAMLprim value llvm_get_string_attr_kind(LLVMAttributeRef A) {
unsigned Length;
const char *String = LLVMGetStringAttributeKind(A, &Length);
value Result = caml_alloc_string(Length);
memcpy(String_val(Result), String, Length);
return Result;
}
/* llattribute -> string */
CAMLprim value llvm_get_string_attr_value(LLVMAttributeRef A) {
unsigned Length;
const char *String = LLVMGetStringAttributeValue(A, &Length);
value Result = caml_alloc_string(Length);
memcpy(String_val(Result), String, Length);
return Result;
}
/*===-- Modules -----------------------------------------------------------===*/
/* llcontext -> string -> llmodule */
@ -1308,31 +1371,37 @@ CAMLprim value llvm_set_gc(value GC, LLVMValueRef Fn) {
return Val_unit;
}
/* llvalue -> int32 -> unit */
CAMLprim value llvm_add_function_attr(LLVMValueRef Arg, value PA) {
LLVMAddFunctionAttr(Arg, Int32_val(PA));
/* llvalue -> llattribute -> int -> unit */
CAMLprim value llvm_add_function_attr(LLVMValueRef F, LLVMAttributeRef A,
value Index) {
LLVMAddAttributeAtIndex(F, Int_val(Index), A);
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));
/* llvalue -> int -> llattribute array */
CAMLprim value llvm_function_attrs(LLVMValueRef F, value Index) {
unsigned Length = LLVMGetAttributeCountAtIndex(F, Int_val(Index));
value Array = caml_alloc(Length, 0);
LLVMGetAttributesAtIndex(F, Int_val(Index),
(LLVMAttributeRef *) Op_val(Array));
return Array;
}
/* llvalue -> llattrkind -> int -> unit */
CAMLprim value llvm_remove_enum_function_attr(LLVMValueRef F, value Kind,
value Index) {
LLVMRemoveEnumAttributeAtIndex(F, Int_val(Index), Int_val(Kind));
return Val_unit;
}
/* llvalue -> int32 */
CAMLprim value llvm_function_attr(LLVMValueRef Fn)
{
CAMLparam0();
CAMLreturn(caml_copy_int32(LLVMGetFunctionAttr(Fn)));
}
/* llvalue -> int32 -> unit */
CAMLprim value llvm_remove_function_attr(LLVMValueRef Arg, value PA) {
LLVMRemoveFunctionAttr(Arg, Int32_val(PA));
/* llvalue -> string -> int -> unit */
CAMLprim value llvm_remove_string_function_attr(LLVMValueRef F, value Kind,
value Index) {
LLVMRemoveStringAttributeAtIndex(F, Int_val(Index), String_val(Kind),
caml_string_length(Kind));
return Val_unit;
}
/*--... Operations on parameters ...........................................--*/
DEFINE_ITERATORS(param, Param, LLVMValueRef, LLVMValueRef, LLVMGetParamParent)
@ -1342,13 +1411,6 @@ CAMLprim LLVMValueRef llvm_param(LLVMValueRef Fn, value Index) {
return LLVMGetParam(Fn, Int_val(Index));
}
/* llvalue -> int */
CAMLprim value llvm_param_attr(LLVMValueRef Param)
{
CAMLparam0();
CAMLreturn(caml_copy_int32(LLVMGetAttribute(Param)));
}
/* llvalue -> llvalue */
CAMLprim value llvm_params(LLVMValueRef Fn) {
value Params = alloc(LLVMCountParams(Fn), 0);
@ -1356,24 +1418,6 @@ CAMLprim value llvm_params(LLVMValueRef Fn) {
return Params;
}
/* llvalue -> int32 -> unit */
CAMLprim value llvm_add_param_attr(LLVMValueRef Arg, value PA) {
LLVMAddAttribute(Arg, Int32_val(PA));
return Val_unit;
}
/* llvalue -> int32 -> unit */
CAMLprim value llvm_remove_param_attr(LLVMValueRef Arg, value PA) {
LLVMRemoveAttribute(Arg, Int32_val(PA));
return Val_unit;
}
/* llvalue -> int -> unit */
CAMLprim value llvm_set_param_alignment(LLVMValueRef Arg, value align) {
LLVMSetParamAlignment(Arg, Int_val(align));
return Val_unit;
}
/*--... Operations on basic blocks .........................................--*/
DEFINE_ITERATORS(
@ -1500,19 +1544,34 @@ CAMLprim value llvm_set_instruction_call_conv(value CC, LLVMValueRef Inst) {
return Val_unit;
}
/* llvalue -> int -> int32 -> unit */
CAMLprim value llvm_add_instruction_param_attr(LLVMValueRef Instr,
value index,
value PA) {
LLVMAddInstrAttribute(Instr, Int_val(index), Int32_val(PA));
/* llvalue -> llattribute -> int -> unit */
CAMLprim value llvm_add_call_site_attr(LLVMValueRef F, LLVMAttributeRef A,
value Index) {
LLVMAddCallSiteAttribute(F, Int_val(Index), A);
return Val_unit;
}
/* llvalue -> int -> int32 -> unit */
CAMLprim value llvm_remove_instruction_param_attr(LLVMValueRef Instr,
value index,
value PA) {
LLVMRemoveInstrAttribute(Instr, Int_val(index), Int32_val(PA));
/* llvalue -> int -> llattribute array */
CAMLprim value llvm_call_site_attrs(LLVMValueRef F, value Index) {
unsigned Count = LLVMGetCallSiteAttributeCount(F, Int_val(Index));
value Array = caml_alloc(Count, 0);
LLVMGetCallSiteAttributes(F, Int_val(Index),
(LLVMAttributeRef *)Op_val(Array));
return Array;
}
/* llvalue -> llattrkind -> int -> unit */
CAMLprim value llvm_remove_enum_call_site_attr(LLVMValueRef F, value Kind,
value Index) {
LLVMRemoveCallSiteEnumAttribute(F, Int_val(Index), Int_val(Kind));
return Val_unit;
}
/* llvalue -> string -> int -> unit */
CAMLprim value llvm_remove_string_call_site_attr(LLVMValueRef F, value Kind,
value Index) {
LLVMRemoveCallSiteStringAttribute(F, Int_val(Index), String_val(Kind),
caml_string_length(Kind));
return Val_unit;
}

3
docs/ReleaseNotes.rst
View File

@ -98,7 +98,8 @@ Changes to the AMDGPU Target
Changes to the OCaml bindings
-----------------------------
During this release ...
* The attribute API was completely overhauled, following the changes
to the C API.
External Open Source Projects Using LLVM 4.0.0

90
test/Bindings/OCaml/core.ml
View File

@ -404,6 +404,42 @@ let test_constants () =
end
(*===-- Attributes --------------------------------------------------------===*)
let test_attributes () =
group "enum attrs";
let nonnull_kind = enum_attr_kind "nonnull" in
let dereferenceable_kind = enum_attr_kind "dereferenceable" in
insist (nonnull_kind = (enum_attr_kind "nonnull"));
insist (nonnull_kind <> dereferenceable_kind);
let nonnull =
create_enum_attr context "nonnull" 0L in
let dereferenceable_4 =
create_enum_attr context "dereferenceable" 4L in
let dereferenceable_8 =
create_enum_attr context "dereferenceable" 8L in
insist (nonnull <> dereferenceable_4);
insist (dereferenceable_4 <> dereferenceable_8);
insist (nonnull = (create_enum_attr context "nonnull" 0L));
insist ((repr_of_attr nonnull) =
AttrRepr.Enum(nonnull_kind, 0L));
insist ((repr_of_attr dereferenceable_4) =
AttrRepr.Enum(dereferenceable_kind, 4L));
insist ((attr_of_repr context (repr_of_attr nonnull)) =
nonnull);
insist ((attr_of_repr context (repr_of_attr dereferenceable_4)) =
dereferenceable_4);
group "string attrs";
let foo_bar = create_string_attr context "foo" "bar" in
let foo_baz = create_string_attr context "foo" "baz" in
insist (foo_bar <> foo_baz);
insist (foo_bar = (create_string_attr context "foo" "bar"));
insist ((repr_of_attr foo_bar) = AttrRepr.String("foo", "bar"));
insist ((attr_of_repr context (repr_of_attr foo_bar)) = foo_bar);
()
(*===-- Global Values -----------------------------------------------------===*)
let test_global_values () =
@ -747,12 +783,6 @@ let test_params () =
let p2 = param f 1 in
set_value_name "One" p1;
set_value_name "Two" p2;
add_param_attr p1 Attribute.Sext;
add_param_attr p2 Attribute.Noalias;
remove_param_attr p2 Attribute.Noalias;
add_function_attr f Attribute.Nounwind;
add_function_attr f Attribute.Noreturn;
remove_function_attr f Attribute.Noreturn;
insist (Before p1 = param_begin f);
insist (Before p2 = param_succ p1);
@ -960,11 +990,25 @@ let test_builder () =
group "function attribute";
begin
ignore (add_function_attr fn Attribute.UWTable);
(* CHECK: X7{{.*}}#0{{.*}}personality{{.*}}@__gxx_personality_v0
* #0 is uwtable, defined at EOF.
*)
insist ([Attribute.UWTable] = function_attr fn);
let signext = create_enum_attr context "signext" 0L in
let zeroext = create_enum_attr context "zeroext" 0L in
let noalias = create_enum_attr context "noalias" 0L in
let nounwind = create_enum_attr context "nounwind" 0L in
let no_sse = create_string_attr context "no-sse" "" in
add_function_attr fn signext (AttrIndex.Param 0);
add_function_attr fn noalias (AttrIndex.Param 1);
insist ((function_attrs fn (AttrIndex.Param 1)) = [|noalias|]);
remove_enum_function_attr fn (enum_attr_kind "noalias") (AttrIndex.Param 1);
add_function_attr fn no_sse (AttrIndex.Param 1);
insist ((function_attrs fn (AttrIndex.Param 1)) = [|no_sse|]);
remove_string_function_attr fn "no-sse" (AttrIndex.Param 1);
insist ((function_attrs fn (AttrIndex.Param 1)) = [||]);
add_function_attr fn nounwind AttrIndex.Function;
add_function_attr fn zeroext AttrIndex.Return;
(* CHECK: define zeroext i32 @X7(i32 signext %P1, i32 %P2)
*)
end;
group "casts"; begin
@ -1057,7 +1101,7 @@ let test_builder () =
end;
group "miscellaneous"; begin
(* CHECK: %build_call = tail call cc63 i32 @{{.*}}(i32 signext %P2, i32 %P1)
(* CHECK: %build_call = tail call cc63 zeroext i32 @{{.*}}(i32 signext %P2, i32 %P1)
* CHECK: %build_select = select i1 %build_icmp, i32 %P1, i32 %P2
* CHECK: %build_va_arg = va_arg i8** null, i32
* CHECK: %build_extractelement = extractelement <4 x i32> %Vec1, i32 %P2
@ -1073,9 +1117,23 @@ let test_builder () =
insist (not (is_tail_call ci));
set_tail_call true ci;
insist (is_tail_call ci);
add_instruction_param_attr ci 1 Attribute.Sext;
add_instruction_param_attr ci 2 Attribute.Noalias;
remove_instruction_param_attr ci 2 Attribute.Noalias;
let signext = create_enum_attr context "signext" 0L in
let zeroext = create_enum_attr context "zeroext" 0L in
let noalias = create_enum_attr context "noalias" 0L in
let noreturn = create_enum_attr context "noreturn" 0L in
let no_sse = create_string_attr context "no-sse" "" in
add_call_site_attr ci signext (AttrIndex.Param 0);
add_call_site_attr ci noalias (AttrIndex.Param 1);
insist ((call_site_attrs ci (AttrIndex.Param 1)) = [|noalias|]);
remove_enum_call_site_attr ci (enum_attr_kind "noalias") (AttrIndex.Param 1);
add_call_site_attr ci no_sse (AttrIndex.Param 1);
insist ((call_site_attrs ci (AttrIndex.Param 1)) = [|no_sse|]);
remove_string_call_site_attr ci "no-sse" (AttrIndex.Param 1);
insist ((call_site_attrs ci (AttrIndex.Param 1)) = [||]);
add_call_site_attr ci noreturn AttrIndex.Function;
add_call_site_attr ci zeroext AttrIndex.Return;
let inst46 = build_icmp Icmp.Eq p1 p2 "build_icmp" atentry in
ignore (build_select inst46 p1 p2 "build_select" atentry);
@ -1421,7 +1479,6 @@ let test_builder () =
end
(* End-of-file checks for things like metdata and attributes.
* CHECK: attributes #0 = {{.*}}uwtable{{.*}}
* CHECK: !llvm.module.flags = !{!0}
* CHECK: !0 = !{i32 1, !"Debug Info Version", i32 3}
* CHECK: !1 = !{i32 1, !"metadata test"}
@ -1479,6 +1536,7 @@ let _ =
suite "conversion" test_conversion;
suite "target" test_target;
suite "constants" test_constants;
suite "attributes" test_attributes;
suite "global values" test_global_values;
suite "global variables" test_global_variables;
suite "uses" test_uses;