diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index 513fe0c9687..399fd2d27c2 100644 --- a/bindings/ocaml/llvm/llvm.ml +++ b/bindings/ocaml/llvm/llvm.ml @@ -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" diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index 0f973000f75..4068126e2cb 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -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)} *) diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index f968db8efd0..af04ea25c8a 100644 --- a/bindings/ocaml/llvm/llvm_ocaml.c +++ b/bindings/ocaml/llvm/llvm_ocaml.c @@ -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; } diff --git a/docs/ReleaseNotes.rst b/docs/ReleaseNotes.rst index 6b75a79aa5c..95c2302855f 100644 --- a/docs/ReleaseNotes.rst +++ b/docs/ReleaseNotes.rst @@ -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 diff --git a/test/Bindings/OCaml/core.ml b/test/Bindings/OCaml/core.ml index ee8281f111a..105f1bc4f73 100644 --- a/test/Bindings/OCaml/core.ml +++ b/test/Bindings/OCaml/core.ml @@ -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;