llvm.org GIT mirror llvm / 18c0ee2
[OCaml] Adapt to the new attribute C API. git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@286705 91177308-0d34-0410-b5e6-96231b3b80d8 whitequark 2 years ago
5 changed file(s) with 371 addition(s) and 259 deletion(s). Raw diff Collapse all Expand all
1414 type lluse
1515 type llbasicblock
1616 type llbuilder
17 type llattrkind
18 type llattribute
1719 type llmemorybuffer
1820 type llmdkind
1921
7880 let cold = 9
7981 let x86_stdcall = 64
8082 let x86_fastcall = 65
83 end
84
85 module AttrRepr = struct
86 type t =
87 | Enum of llattrkind * int64
88 | String of string * string
89 end
90
91 module AttrIndex = struct
92 type t =
93 | Function
94 | Return
95 | Param of int
96
97 let to_int index =
98 match index with
99 | Function -> -1
100 | Return -> 0
101 | Param(n) -> 1 + n
81102 end
82103
83104 module Attribute = struct
330351 external dispose_context : llcontext -> unit = "llvm_dispose_context"
331352 external global_context : unit -> llcontext = "llvm_global_context"
332353 external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
354
355 (*===-- Attributes --------------------------------------------------------===*)
356 exception UnknownAttribute of string
357
358 let () = Callback.register_exception "Llvm.UnknownAttribute"
359 (UnknownAttribute "")
360
361 external enum_attr_kind : string -> llattrkind = "llvm_enum_attr_kind"
362 external llvm_create_enum_attr : llcontext -> llattrkind -> int64 ->
363 llattribute
364 = "llvm_create_enum_attr_by_kind"
365 external is_enum_attr : llattribute -> bool = "llvm_is_enum_attr"
366 external get_enum_attr_kind : llattribute -> llattrkind
367 = "llvm_get_enum_attr_kind"
368 external get_enum_attr_value : llattribute -> int64
369 = "llvm_get_enum_attr_value"
370 external llvm_create_string_attr : llcontext -> string -> string ->
371 llattribute
372 = "llvm_create_string_attr"
373 external is_string_attr : llattribute -> bool = "llvm_is_string_attr"
374 external get_string_attr_kind : llattribute -> string
375 = "llvm_get_string_attr_kind"
376 external get_string_attr_value : llattribute -> string
377 = "llvm_get_string_attr_value"
378
379 let create_enum_attr context name value =
380 llvm_create_enum_attr context (enum_attr_kind name) value
381 let create_string_attr context kind value =
382 llvm_create_string_attr context kind value
383
384 let attr_of_repr context repr =
385 match repr with
386 | AttrRepr.Enum(kind, value) -> llvm_create_enum_attr context kind value
387 | AttrRepr.String(key, value) -> llvm_create_string_attr context key value
388
389 let repr_of_attr attr =
390 if is_enum_attr attr then
391 AttrRepr.Enum(get_enum_attr_kind attr, get_enum_attr_value attr)
392 else if is_string_attr attr then
393 AttrRepr.String(get_string_attr_kind attr, get_string_attr_value attr)
394 else assert false
333395
334396 (*===-- Modules -----------------------------------------------------------===*)
335397 external create_module : llcontext -> string -> llmodule = "llvm_create_module"
759821 let fold_right_functions f m init =
760822 fold_right_function_range f (function_end m) (At_start m) init
761823
762 external llvm_add_function_attr : llvalue -> int32 -> unit
824 external llvm_add_function_attr : llvalue -> llattribute -> int -> unit
763825 = "llvm_add_function_attr"
764 external llvm_remove_function_attr : llvalue -> int32 -> unit
765 = "llvm_remove_function_attr"
766 external llvm_function_attr : llvalue -> int32 = "llvm_function_attr"
767
768 let pack_attr (attr:Attribute.t) : int32 =
769 match attr with
770 Attribute.Zext -> Int32.shift_left 1l 0
771 | Attribute.Sext -> Int32.shift_left 1l 1
772 | Attribute.Noreturn -> Int32.shift_left 1l 2
773 | Attribute.Inreg -> Int32.shift_left 1l 3
774 | Attribute.Structret -> Int32.shift_left 1l 4
775 | Attribute.Nounwind -> Int32.shift_left 1l 5
776 | Attribute.Noalias -> Int32.shift_left 1l 6
777 | Attribute.Byval -> Int32.shift_left 1l 7
778 | Attribute.Nest -> Int32.shift_left 1l 8
779 | Attribute.Readnone -> Int32.shift_left 1l 9
780 | Attribute.Readonly -> Int32.shift_left 1l 10
781 | Attribute.Noinline -> Int32.shift_left 1l 11
782 | Attribute.Alwaysinline -> Int32.shift_left 1l 12
783 | Attribute.Optsize -> Int32.shift_left 1l 13
784 | Attribute.Ssp -> Int32.shift_left 1l 14
785 | Attribute.Sspreq -> Int32.shift_left 1l 15
786 | Attribute.Alignment n -> Int32.shift_left (Int32.of_int n) 16
787 | Attribute.Nocapture -> Int32.shift_left 1l 21
788 | Attribute.Noredzone -> Int32.shift_left 1l 22
789 | Attribute.Noimplicitfloat -> Int32.shift_left 1l 23
790 | Attribute.Naked -> Int32.shift_left 1l 24
791 | Attribute.Inlinehint -> Int32.shift_left 1l 25
792 | Attribute.Stackalignment n -> Int32.shift_left (Int32.of_int n) 26
793 | Attribute.ReturnsTwice -> Int32.shift_left 1l 29
794 | Attribute.UWTable -> Int32.shift_left 1l 30
795 | Attribute.NonLazyBind -> Int32.shift_left 1l 31
796
797 let unpack_attr (a : int32) : Attribute.t list =
798 let l = ref [] in
799 let check attr =
800 Int32.logand (pack_attr attr) a in
801 let checkattr attr =
802 if (check attr) <> 0l then begin
803 l := attr :: !l
804 end
805 in
806 checkattr Attribute.Zext;
807 checkattr Attribute.Sext;
808 checkattr Attribute.Noreturn;
809 checkattr Attribute.Inreg;
810 checkattr Attribute.Structret;
811 checkattr Attribute.Nounwind;
812 checkattr Attribute.Noalias;
813 checkattr Attribute.Byval;
814 checkattr Attribute.Nest;
815 checkattr Attribute.Readnone;
816 checkattr Attribute.Readonly;
817 checkattr Attribute.Noinline;
818 checkattr Attribute.Alwaysinline;
819 checkattr Attribute.Optsize;
820 checkattr Attribute.Ssp;
821 checkattr Attribute.Sspreq;
822 let align = Int32.logand (Int32.shift_right_logical a 16) 31l in
823 if align <> 0l then
824 l := Attribute.Alignment (Int32.to_int align) :: !l;
825 checkattr Attribute.Nocapture;
826 checkattr Attribute.Noredzone;
827 checkattr Attribute.Noimplicitfloat;
828 checkattr Attribute.Naked;
829 checkattr Attribute.Inlinehint;
830 let stackalign = Int32.logand (Int32.shift_right_logical a 26) 7l in
831 if stackalign <> 0l then
832 l := Attribute.Stackalignment (Int32.to_int stackalign) :: !l;
833 checkattr Attribute.ReturnsTwice;
834 checkattr Attribute.UWTable;
835 checkattr Attribute.NonLazyBind;
836 !l;;
837
838 let add_function_attr llval attr =
839 llvm_add_function_attr llval (pack_attr attr)
840
841 external add_target_dependent_function_attr
842 : llvalue -> string -> string -> unit
843 = "llvm_add_target_dependent_function_attr"
844
845 let remove_function_attr llval attr =
846 llvm_remove_function_attr llval (pack_attr attr)
847
848 let function_attr f = unpack_attr (llvm_function_attr f)
826 external llvm_function_attrs : llvalue -> int -> llattribute array
827 = "llvm_function_attrs"
828 external llvm_remove_enum_function_attr : llvalue -> llattrkind -> int -> unit
829 = "llvm_remove_enum_function_attr"
830 external llvm_remove_string_function_attr : llvalue -> string -> int -> unit
831 = "llvm_remove_string_function_attr"
832
833 let add_function_attr f a i =
834 llvm_add_function_attr f a (AttrIndex.to_int i)
835 let function_attrs f i =
836 llvm_function_attrs f (AttrIndex.to_int i)
837 let remove_enum_function_attr f k i =
838 llvm_remove_enum_function_attr f k (AttrIndex.to_int i)
839 let remove_string_function_attr f k i =
840 llvm_remove_string_function_attr f k (AttrIndex.to_int i)
849841
850842 (*--... Operations on params ...............................................--*)
851843 external params : llvalue -> llvalue array = "llvm_params"
852844 external param : llvalue -> int -> llvalue = "llvm_param"
853 external llvm_param_attr : llvalue -> int32 = "llvm_param_attr"
854 let param_attr p = unpack_attr (llvm_param_attr p)
855845 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
856846 external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin"
857847 external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ"
897887
898888 let fold_right_params f fn init =
899889 fold_right_param_range f init (param_end fn) (At_start fn)
900
901 external llvm_add_param_attr : llvalue -> int32 -> unit
902 = "llvm_add_param_attr"
903 external llvm_remove_param_attr : llvalue -> int32 -> unit
904 = "llvm_remove_param_attr"
905
906 let add_param_attr llval attr =
907 llvm_add_param_attr llval (pack_attr attr)
908
909 let remove_param_attr llval attr =
910 llvm_remove_param_attr llval (pack_attr attr)
911
912 external set_param_alignment : llvalue -> int -> unit
913 = "llvm_set_param_alignment"
914890
915891 (*--... Operations on basic blocks .........................................--*)
916892 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
10431019 external set_instruction_call_conv: int -> llvalue -> unit
10441020 = "llvm_set_instruction_call_conv"
10451021
1046 external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit
1047 = "llvm_add_instruction_param_attr"
1048 external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit
1049 = "llvm_remove_instruction_param_attr"
1050
1051 let add_instruction_param_attr llval i attr =
1052 llvm_add_instruction_param_attr llval i (pack_attr attr)
1053
1054 let remove_instruction_param_attr llval i attr =
1055 llvm_remove_instruction_param_attr llval i (pack_attr attr)
1022 external llvm_add_call_site_attr : llvalue -> llattribute -> int -> unit
1023 = "llvm_add_call_site_attr"
1024 external llvm_call_site_attrs : llvalue -> int -> llattribute array
1025 = "llvm_call_site_attrs"
1026 external llvm_remove_enum_call_site_attr : llvalue -> llattrkind -> int -> unit
1027 = "llvm_remove_enum_call_site_attr"
1028 external llvm_remove_string_call_site_attr : llvalue -> string -> int -> unit
1029 = "llvm_remove_string_call_site_attr"
1030
1031 let add_call_site_attr f a i =
1032 llvm_add_call_site_attr f a (AttrIndex.to_int i)
1033 let call_site_attrs f i =
1034 llvm_call_site_attrs f (AttrIndex.to_int i)
1035 let remove_enum_call_site_attr f k i =
1036 llvm_remove_enum_call_site_attr f k (AttrIndex.to_int i)
1037 let remove_string_call_site_attr f k i =
1038 llvm_remove_string_call_site_attr f k (AttrIndex.to_int i)
10561039
10571040 (*--... Operations on call instructions (only) .............................--*)
10581041 external is_tail_call : llvalue -> bool = "llvm_is_tail_call"
4242 (** Used to generate instructions in the LLVM IR. See the [llvm::LLVMBuilder]
4343 class. *)
4444 type llbuilder
45
46 (** Used to represent attribute kinds. *)
47 type llattrkind
48
49 (** An attribute in LLVM IR. See the [llvm::Attribute] class. *)
50 type llattribute
4551
4652 (** Used to efficiently handle large buffers of read-only binary data.
4753 See the [llvm::MemoryBuffer] class. *)
129135 convention from C. *)
130136 end
131137
132 (** The attribute kind of a function parameter, result or the function itself.
133 See [llvm::Attribute::AttrKind]. *)
134 module Attribute : sig
138 (** The logical representation of an attribute. *)
139 module AttrRepr : sig
135140 type t =
136 | Zext
137 | Sext
138 | Noreturn
139 | Inreg
140 | Structret
141 | Nounwind
142 | Noalias
143 | Byval
144 | Nest
145 | Readnone
146 | Readonly
147 | Noinline
148 | Alwaysinline
149 | Optsize
150 | Ssp
151 | Sspreq
152 | Alignment of int
153 | Nocapture
154 | Noredzone
155 | Noimplicitfloat
156 | Naked
157 | Inlinehint
158 | Stackalignment of int
159 | ReturnsTwice
160 | UWTable
161 | NonLazyBind
141 | Enum of llattrkind * int64
142 | String of string * string
143 end
144
145 (** The position of an attribute. See [LLVMAttributeIndex]. *)
146 module AttrIndex : sig
147 type t =
148 | Function
149 | Return
150 | Param of int
162151 end
163152
164153 (** The predicate for an integer comparison ([icmp]) instruction.
442431 val mdkind_id : llcontext -> string -> llmdkind
443432
444433
434 (** {6 Attributes} *)
435
436 (** [UnknownAttribute attr] is raised when a enum attribute name [name]
437 is not recognized by LLVM. *)
438 exception UnknownAttribute of string
439
440 (** [enum_attr_kind name] returns the kind of enum attributes named [name].
441 May raise [UnknownAttribute]. *)
442 val enum_attr_kind : string -> llattrkind
443
444 (** [create_enum_attr context value kind] creates an enum attribute
445 with the supplied [kind] and [value] in [context]; if the value
446 is not required (as for the majority of attributes), use [0L].
447 May raise [UnknownAttribute].
448 See the constructor [llvm::Attribute::get]. *)
449 val create_enum_attr : llcontext -> string -> int64 -> llattribute
450
451 (** [create_string_attr context kind value] creates a string attribute
452 with the supplied [kind] and [value] in [context].
453 See the constructor [llvm::Attribute::get]. *)
454 val create_string_attr : llcontext -> string -> string -> llattribute
455
456 (** [attr_of_repr context repr] creates an attribute with the supplied
457 representation [repr] in [context]. *)
458 val attr_of_repr : llcontext -> AttrRepr.t -> llattribute
459
460 (** [repr_of_attr attr] describes the representation of attribute [attr]. *)
461 val repr_of_attr : llattribute -> AttrRepr.t
462
463
445464 (** {6 Modules} *)
446465
447466 (** [create_module context id] creates a module with the supplied module ID in
15461565 [gc]. See the method [llvm::Function::setGC]. *)
15471566 val set_gc : string option -> llvalue -> unit
15481567
1549 (** [add_function_attr f a] adds attribute [a] to the return type of function
1550 [f]. *)
1551 val add_function_attr : llvalue -> Attribute.t -> unit
1552
1553 (** [add_target_dependent_function_attr f a] adds target-dependent attribute
1554 [a] to function [f]. *)
1555 val add_target_dependent_function_attr : llvalue -> string -> string -> unit
1556
1557 (** [function_attr f] returns the function attribute for the function [f].
1558 See the method [llvm::Function::getAttributes] *)
1559 val function_attr : llvalue -> Attribute.t list
1560
1561 (** [remove_function_attr f a] removes attribute [a] from the return type of
1562 function [f]. *)
1563 val remove_function_attr : llvalue -> Attribute.t -> unit
1568 (** [add_function_attr f a i] adds attribute [a] to the function [f]
1569 at position [i]. *)
1570 val add_function_attr : llvalue -> llattribute -> AttrIndex.t -> unit
1571
1572 (** [function_attrs f i] returns the attributes for the function [f]
1573 at position [i]. *)
1574 val function_attrs : llvalue -> AttrIndex.t -> llattribute array
1575
1576 (** [remove_enum_function_attr f k i] removes enum attribute with kind [k]
1577 from the function [f] at position [i]. *)
1578 val remove_enum_function_attr : llvalue -> llattrkind -> AttrIndex.t -> unit
1579
1580 (** [remove_string_function_attr f k i] removes string attribute with kind [k]
1581 from the function [f] at position [i]. *)
1582 val remove_string_function_attr : llvalue -> string -> AttrIndex.t -> unit
15641583
15651584
15661585 (** {7 Operations on params} *)
15721591 (** [param f n] returns the [n]th parameter of function [f].
15731592 See the method [llvm::Function::getArgumentList]. *)
15741593 val param : llvalue -> int -> llvalue
1575
1576 (** [param_attr p] returns the attributes of parameter [p].
1577 See the methods [llvm::Function::getAttributes] and
1578 [llvm::Attributes::getParamAttributes] *)
1579 val param_attr : llvalue -> Attribute.t list
15801594
15811595 (** [param_parent p] returns the parent function that owns the parameter.
15821596 See the method [llvm::Argument::getParent]. *)
16181632 (** [fold_right_params f fn init] is [f (... (f init bN) ...) b1] where
16191633 [b1,...,bN] are the parameters of function [fn]. Tail recursive. *)
16201634 val fold_right_params : (llvalue -> 'a -> 'a) -> llvalue -> 'a -> 'a
1621
1622 (** [add_param p a] adds attribute [a] to parameter [p]. *)
1623 val add_param_attr : llvalue -> Attribute.t -> unit
1624
1625 (** [remove_param_attr p a] removes attribute [a] from parameter [p]. *)
1626 val remove_param_attr : llvalue -> Attribute.t -> unit
1627
1628 (** [set_param_alignment p a] set the alignment of parameter [p] to [a]. *)
1629 val set_param_alignment : llvalue -> int -> unit
16301635
16311636
16321637 (** {7 Operations on basic blocks} *)
17961801 and [llvm::InvokeInst::setCallingConv]. *)
17971802 val set_instruction_call_conv: int -> llvalue -> unit
17981803
1799 (** [add_instruction_param_attr ci i a] adds attribute [a] to the [i]th
1800 parameter of the call or invoke instruction [ci]. [i]=0 denotes the return
1801 value. *)
1802 val add_instruction_param_attr : llvalue -> int -> Attribute.t -> unit
1803
1804 (** [remove_instruction_param_attr ci i a] removes attribute [a] from the
1805 [i]th parameter of the call or invoke instruction [ci]. [i]=0 denotes the
1806 return value. *)
1807 val remove_instruction_param_attr : llvalue -> int -> Attribute.t -> unit
1804 (** [add_call_site_attr f a i] adds attribute [a] to the call instruction [ci]
1805 at position [i]. *)
1806 val add_call_site_attr : llvalue -> llattribute -> AttrIndex.t -> unit
1807
1808 (** [call_site_attr f i] returns the attributes for the call instruction [ci]
1809 at position [i]. *)
1810 val call_site_attrs : llvalue -> AttrIndex.t -> llattribute array
1811
1812 (** [remove_enum_call_site_attr f k i] removes enum attribute with kind [k]
1813 from the call instruction [ci] at position [i]. *)
1814 val remove_enum_call_site_attr : llvalue -> llattrkind -> AttrIndex.t -> unit
1815
1816 (** [remove_string_call_site_attr f k i] removes string attribute with kind [k]
1817 from the call instruction [ci] at position [i]. *)
1818 val remove_string_call_site_attr : llvalue -> string -> AttrIndex.t -> unit
18081819
18091820
18101821 (** {7 Operations on call instructions (only)} *)
184184 return Val_int(MDKindID);
185185 }
186186
187 /*===-- Attributes --------------------------------------------------------===*/
188
189 /* string -> llattrkind */
190 CAMLprim value llvm_enum_attr_kind(value Name) {
191 unsigned Kind = LLVMGetEnumAttributeKindForName(
192 String_val(Name), caml_string_length(Name));
193 if(Kind == 0)
194 caml_raise_with_arg(*caml_named_value("Llvm.UnknownAttribute"), Name);
195 return Val_int(Kind);
196 }
197
198 /* llcontext -> int -> int64 -> llattribute */
199 CAMLprim LLVMAttributeRef
200 llvm_create_enum_attr_by_kind(LLVMContextRef C, value Kind, value Value) {
201 return LLVMCreateEnumAttribute(C, Int_val(Kind), Int64_val(Value));
202 }
203
204 /* llattribute -> bool */
205 CAMLprim value llvm_is_enum_attr(LLVMAttributeRef A) {
206 return Val_int(LLVMIsEnumAttribute(A));
207 }
208
209 /* llattribute -> llattrkind */
210 CAMLprim value llvm_get_enum_attr_kind(LLVMAttributeRef A) {
211 return Val_int(LLVMGetEnumAttributeKind(A));
212 }
213
214 /* llattribute -> int64 */
215 CAMLprim value llvm_get_enum_attr_value(LLVMAttributeRef A) {
216 return caml_copy_int64(LLVMGetEnumAttributeValue(A));
217 }
218
219 /* llcontext -> kind:string -> name:string -> llattribute */
220 CAMLprim LLVMAttributeRef llvm_create_string_attr(LLVMContextRef C,
221 value Kind, value Value) {
222 return LLVMCreateStringAttribute(C,
223 String_val(Kind), caml_string_length(Kind),
224 String_val(Value), caml_string_length(Value));
225 }
226
227 /* llattribute -> bool */
228 CAMLprim value llvm_is_string_attr(LLVMAttributeRef A) {
229 return Val_int(LLVMIsStringAttribute(A));
230 }
231
232 /* llattribute -> string */
233 CAMLprim value llvm_get_string_attr_kind(LLVMAttributeRef A) {
234 unsigned Length;
235 const char *String = LLVMGetStringAttributeKind(A, &Length);
236 value Result = caml_alloc_string(Length);
237 memcpy(String_val(Result), String, Length);
238 return Result;
239 }
240
241 /* llattribute -> string */
242 CAMLprim value llvm_get_string_attr_value(LLVMAttributeRef A) {
243 unsigned Length;
244 const char *String = LLVMGetStringAttributeValue(A, &Length);
245 value Result = caml_alloc_string(Length);
246 memcpy(String_val(Result), String, Length);
247 return Result;
248 }
249
187250 /*===-- Modules -----------------------------------------------------------===*/
188251
189252 /* llcontext -> string -> llmodule */
13071370 return Val_unit;
13081371 }
13091372
1310 /* llvalue -> int32 -> unit */
1311 CAMLprim value llvm_add_function_attr(LLVMValueRef Arg, value PA) {
1312 LLVMAddFunctionAttr(Arg, Int32_val(PA));
1313 return Val_unit;
1314 }
1315
1316 /* llvalue -> string -> string -> unit */
1317 CAMLprim value llvm_add_target_dependent_function_attr(
1318 LLVMValueRef Arg, value A, value V) {
1319 LLVMAddTargetDependentFunctionAttr(Arg, String_val(A), String_val(V));
1320 return Val_unit;
1321 }
1322
1323 /* llvalue -> int32 */
1324 CAMLprim value llvm_function_attr(LLVMValueRef Fn)
1325 {
1326 CAMLparam0();
1327 CAMLreturn(caml_copy_int32(LLVMGetFunctionAttr(Fn)));
1328 }
1329
1330 /* llvalue -> int32 -> unit */
1331 CAMLprim value llvm_remove_function_attr(LLVMValueRef Arg, value PA) {
1332 LLVMRemoveFunctionAttr(Arg, Int32_val(PA));
1333 return Val_unit;
1334 }
1373 /* llvalue -> llattribute -> int -> unit */
1374 CAMLprim value llvm_add_function_attr(LLVMValueRef F, LLVMAttributeRef A,
1375 value Index) {
1376 LLVMAddAttributeAtIndex(F, Int_val(Index), A);
1377 return Val_unit;
1378 }
1379
1380 /* llvalue -> int -> llattribute array */
1381 CAMLprim value llvm_function_attrs(LLVMValueRef F, value Index) {
1382 unsigned Length = LLVMGetAttributeCountAtIndex(F, Int_val(Index));
1383 value Array = caml_alloc(Length, 0);
1384 LLVMGetAttributesAtIndex(F, Int_val(Index),
1385 (LLVMAttributeRef *) Op_val(Array));
1386 return Array;
1387 }
1388
1389 /* llvalue -> llattrkind -> int -> unit */
1390 CAMLprim value llvm_remove_enum_function_attr(LLVMValueRef F, value Kind,
1391 value Index) {
1392 LLVMRemoveEnumAttributeAtIndex(F, Int_val(Index), Int_val(Kind));
1393 return Val_unit;
1394 }
1395
1396 /* llvalue -> string -> int -> unit */
1397 CAMLprim value llvm_remove_string_function_attr(LLVMValueRef F, value Kind,
1398 value Index) {
1399 LLVMRemoveStringAttributeAtIndex(F, Int_val(Index), String_val(Kind),
1400 caml_string_length(Kind));
1401 return Val_unit;
1402 }
1403
13351404 /*--... Operations on parameters ...........................................--*/
13361405
13371406 DEFINE_ITERATORS(param, Param, LLVMValueRef, LLVMValueRef, LLVMGetParamParent)
13391408 /* llvalue -> int -> llvalue */
13401409 CAMLprim LLVMValueRef llvm_param(LLVMValueRef Fn, value Index) {
13411410 return LLVMGetParam(Fn, Int_val(Index));
1342 }
1343
1344 /* llvalue -> int */
1345 CAMLprim value llvm_param_attr(LLVMValueRef Param)
1346 {
1347 CAMLparam0();
1348 CAMLreturn(caml_copy_int32(LLVMGetAttribute(Param)));
13491411 }
13501412
13511413 /* llvalue -> llvalue */
13531415 value Params = alloc(LLVMCountParams(Fn), 0);
13541416 LLVMGetParams(Fn, (LLVMValueRef *) Op_val(Params));
13551417 return Params;
1356 }
1357
1358 /* llvalue -> int32 -> unit */
1359 CAMLprim value llvm_add_param_attr(LLVMValueRef Arg, value PA) {
1360 LLVMAddAttribute(Arg, Int32_val(PA));
1361 return Val_unit;
1362 }
1363
1364 /* llvalue -> int32 -> unit */
1365 CAMLprim value llvm_remove_param_attr(LLVMValueRef Arg, value PA) {
1366 LLVMRemoveAttribute(Arg, Int32_val(PA));
1367 return Val_unit;
1368 }
1369
1370 /* llvalue -> int -> unit */
1371 CAMLprim value llvm_set_param_alignment(LLVMValueRef Arg, value align) {
1372 LLVMSetParamAlignment(Arg, Int_val(align));
1373 return Val_unit;
13741418 }
13751419
13761420 /*--... Operations on basic blocks .........................................--*/
14991543 return Val_unit;
15001544 }
15011545
1502 /* llvalue -> int -> int32 -> unit */
1503 CAMLprim value llvm_add_instruction_param_attr(LLVMValueRef Instr,
1504 value index,
1505 value PA) {
1506 LLVMAddInstrAttribute(Instr, Int_val(index), Int32_val(PA));
1507 return Val_unit;
1508 }
1509
1510 /* llvalue -> int -> int32 -> unit */
1511 CAMLprim value llvm_remove_instruction_param_attr(LLVMValueRef Instr,
1512 value index,
1513 value PA) {
1514 LLVMRemoveInstrAttribute(Instr, Int_val(index), Int32_val(PA));
1546 /* llvalue -> llattribute -> int -> unit */
1547 CAMLprim value llvm_add_call_site_attr(LLVMValueRef F, LLVMAttributeRef A,
1548 value Index) {
1549 LLVMAddCallSiteAttribute(F, Int_val(Index), A);
1550 return Val_unit;
1551 }
1552
1553 /* llvalue -> int -> llattribute array */
1554 CAMLprim value llvm_call_site_attrs(LLVMValueRef F, value Index) {
1555 unsigned Count = LLVMGetCallSiteAttributeCount(F, Int_val(Index));
1556 value Array = caml_alloc(Count, 0);
1557 LLVMGetCallSiteAttributes(F, Int_val(Index),
1558 (LLVMAttributeRef *)Op_val(Array));
1559 return Array;
1560 }
1561
1562 /* llvalue -> llattrkind -> int -> unit */
1563 CAMLprim value llvm_remove_enum_call_site_attr(LLVMValueRef F, value Kind,
1564 value Index) {
1565 LLVMRemoveCallSiteEnumAttribute(F, Int_val(Index), Int_val(Kind));
1566 return Val_unit;
1567 }
1568
1569 /* llvalue -> string -> int -> unit */
1570 CAMLprim value llvm_remove_string_call_site_attr(LLVMValueRef F, value Kind,
1571 value Index) {
1572 LLVMRemoveCallSiteStringAttribute(F, Int_val(Index), String_val(Kind),
1573 caml_string_length(Kind));
15151574 return Val_unit;
15161575 }
15171576
9797 Changes to the OCaml bindings
9898 -----------------------------
9999
100 During this release ...
100 * The attribute API was completely overhauled, following the changes
101 to the C API.
101102
102103
103104 External Open Source Projects Using LLVM 4.0.0
403403 end
404404
405405
406 (*===-- Attributes --------------------------------------------------------===*)
407
408 let test_attributes () =
409 group "enum attrs";
410 let nonnull_kind = enum_attr_kind "nonnull" in
411 let dereferenceable_kind = enum_attr_kind "dereferenceable" in
412 insist (nonnull_kind = (enum_attr_kind "nonnull"));
413 insist (nonnull_kind <> dereferenceable_kind);
414
415 let nonnull =
416 create_enum_attr context "nonnull" 0L in
417 let dereferenceable_4 =
418 create_enum_attr context "dereferenceable" 4L in
419 let dereferenceable_8 =
420 create_enum_attr context "dereferenceable" 8L in
421 insist (nonnull <> dereferenceable_4);
422 insist (dereferenceable_4 <> dereferenceable_8);
423 insist (nonnull = (create_enum_attr context "nonnull" 0L));
424 insist ((repr_of_attr nonnull) =
425 AttrRepr.Enum(nonnull_kind, 0L));
426 insist ((repr_of_attr dereferenceable_4) =
427 AttrRepr.Enum(dereferenceable_kind, 4L));
428 insist ((attr_of_repr context (repr_of_attr nonnull)) =
429 nonnull);
430 insist ((attr_of_repr context (repr_of_attr dereferenceable_4)) =
431 dereferenceable_4);
432
433 group "string attrs";
434 let foo_bar = create_string_attr context "foo" "bar" in
435 let foo_baz = create_string_attr context "foo" "baz" in
436 insist (foo_bar <> foo_baz);
437 insist (foo_bar = (create_string_attr context "foo" "bar"));
438 insist ((repr_of_attr foo_bar) = AttrRepr.String("foo", "bar"));
439 insist ((attr_of_repr context (repr_of_attr foo_bar)) = foo_bar);
440 ()
441
406442 (*===-- Global Values -----------------------------------------------------===*)
407443
408444 let test_global_values () =
746782 let p2 = param f 1 in
747783 set_value_name "One" p1;
748784 set_value_name "Two" p2;
749 add_param_attr p1 Attribute.Sext;
750 add_param_attr p2 Attribute.Noalias;
751 remove_param_attr p2 Attribute.Noalias;
752 add_function_attr f Attribute.Nounwind;
753 add_function_attr f Attribute.Noreturn;
754 remove_function_attr f Attribute.Noreturn;
755785
756786 insist (Before p1 = param_begin f);
757787 insist (Before p2 = param_succ p1);
959989
960990 group "function attribute";
961991 begin
962 ignore (add_function_attr fn Attribute.UWTable);
963 (* CHECK: X7{{.*}}#0{{.*}}personality{{.*}}@__gxx_personality_v0
964 * #0 is uwtable, defined at EOF.
965 *)
966 insist ([Attribute.UWTable] = function_attr fn);
992 let signext = create_enum_attr context "signext" 0L in
993 let zeroext = create_enum_attr context "zeroext" 0L in
994 let noalias = create_enum_attr context "noalias" 0L in
995 let nounwind = create_enum_attr context "nounwind" 0L in
996 let no_sse = create_string_attr context "no-sse" "" in
997
998 add_function_attr fn signext (AttrIndex.Param 0);
999 add_function_attr fn noalias (AttrIndex.Param 1);
1000 insist ((function_attrs fn (AttrIndex.Param 1)) = [|noalias|]);
1001 remove_enum_function_attr fn (enum_attr_kind "noalias") (AttrIndex.Param 1);
1002 add_function_attr fn no_sse (AttrIndex.Param 1);
1003 insist ((function_attrs fn (AttrIndex.Param 1)) = [|no_sse|]);
1004 remove_string_function_attr fn "no-sse" (AttrIndex.Param 1);
1005 insist ((function_attrs fn (AttrIndex.Param 1)) = [||]);
1006 add_function_attr fn nounwind AttrIndex.Function;
1007 add_function_attr fn zeroext AttrIndex.Return;
1008
1009 (* CHECK: define zeroext i32 @X7(i32 signext %P1, i32 %P2)
1010 *)
9671011 end;
9681012
9691013 group "casts"; begin
10561100 end;
10571101
10581102 group "miscellaneous"; begin
1059 (* CHECK: %build_call = tail call cc63 i32 @{{.*}}(i32 signext %P2, i32 %P1)
1103 (* CHECK: %build_call = tail call cc63 zeroext i32 @{{.*}}(i32 signext %P2, i32 %P1)
10601104 * CHECK: %build_select = select i1 %build_icmp, i32 %P1, i32 %P2
10611105 * CHECK: %build_va_arg = va_arg i8** null, i32
10621106 * CHECK: %build_extractelement = extractelement <4 x i32> %Vec1, i32 %P2
10721116 insist (not (is_tail_call ci));
10731117 set_tail_call true ci;
10741118 insist (is_tail_call ci);
1075 add_instruction_param_attr ci 1 Attribute.Sext;
1076 add_instruction_param_attr ci 2 Attribute.Noalias;
1077 remove_instruction_param_attr ci 2 Attribute.Noalias;
1119
1120 let signext = create_enum_attr context "signext" 0L in
1121 let zeroext = create_enum_attr context "zeroext" 0L in
1122 let noalias = create_enum_attr context "noalias" 0L in
1123 let noreturn = create_enum_attr context "noreturn" 0L in
1124 let no_sse = create_string_attr context "no-sse" "" in
1125
1126 add_call_site_attr ci signext (AttrIndex.Param 0);
1127 add_call_site_attr ci noalias (AttrIndex.Param 1);
1128 insist ((call_site_attrs ci (AttrIndex.Param 1)) = [|noalias|]);
1129 remove_enum_call_site_attr ci (enum_attr_kind "noalias") (AttrIndex.Param 1);
1130 add_call_site_attr ci no_sse (AttrIndex.Param 1);
1131 insist ((call_site_attrs ci (AttrIndex.Param 1)) = [|no_sse|]);
1132 remove_string_call_site_attr ci "no-sse" (AttrIndex.Param 1);
1133 insist ((call_site_attrs ci (AttrIndex.Param 1)) = [||]);
1134 add_call_site_attr ci noreturn AttrIndex.Function;
1135 add_call_site_attr ci zeroext AttrIndex.Return;
10781136
10791137 let inst46 = build_icmp Icmp.Eq p1 p2 "build_icmp" atentry in
10801138 ignore (build_select inst46 p1 p2 "build_select" atentry);
14201478 end
14211479
14221480 (* End-of-file checks for things like metdata and attributes.
1423 * CHECK: attributes #0 = {{.*}}uwtable{{.*}}
14241481 * CHECK: !llvm.module.flags = !{!0}
14251482 * CHECK: !0 = !{i32 1, !"Debug Info Version", i32 3}
14261483 * CHECK: !1 = !{i32 1, !"metadata test"}
14781535 suite "conversion" test_conversion;
14791536 suite "target" test_target;
14801537 suite "constants" test_constants;
1538 suite "attributes" test_attributes;
14811539 suite "global values" test_global_values;
14821540 suite "global variables" test_global_variables;
14831541 suite "uses" test_uses;