Skip to content

Commit 4dcf92a

Browse files
whitequarkwhitequark
committed
[OCaml] Adapt to the new attribute C API.
llvm-svn: 286705
1 parent ce9bb10 commit 4dcf92a

File tree

5 files changed

+355
-243
lines changed

5 files changed

+355
-243
lines changed

‎llvm/bindings/ocaml/llvm/llvm.ml

+95-112
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@ type llvalue
1515
type lluse
1616
type llbasicblock
1717
type llbuilder
18+
type llattrkind
19+
type llattribute
1820
type llmemorybuffer
1921
type llmdkind
2022

@@ -81,6 +83,25 @@ module CallConv = struct
8183
let x86_fastcall = 65
8284
end
8385

86+
module AttrRepr = struct
87+
type t =
88+
| Enum of llattrkind * int64
89+
| String of string * string
90+
end
91+
92+
module AttrIndex = struct
93+
type t =
94+
| Function
95+
| Return
96+
| Param of int
97+
98+
let to_int index =
99+
match index with
100+
| Function -> -1
101+
| Return -> 0
102+
| Param(n) -> 1 + n
103+
end
104+
84105
module Attribute = struct
85106
type t =
86107
| Zext
@@ -332,6 +353,47 @@ external dispose_context : llcontext -> unit = "llvm_dispose_context"
332353
external global_context : unit -> llcontext = "llvm_global_context"
333354
external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
334355

356+
(*===-- Attributes --------------------------------------------------------===*)
357+
exception UnknownAttribute of string
358+
359+
let () = Callback.register_exception "Llvm.UnknownAttribute"
360+
(UnknownAttribute "")
361+
362+
external enum_attr_kind : string -> llattrkind = "llvm_enum_attr_kind"
363+
external llvm_create_enum_attr : llcontext -> llattrkind -> int64 ->
364+
llattribute
365+
= "llvm_create_enum_attr_by_kind"
366+
external is_enum_attr : llattribute -> bool = "llvm_is_enum_attr"
367+
external get_enum_attr_kind : llattribute -> llattrkind
368+
= "llvm_get_enum_attr_kind"
369+
external get_enum_attr_value : llattribute -> int64
370+
= "llvm_get_enum_attr_value"
371+
external llvm_create_string_attr : llcontext -> string -> string ->
372+
llattribute
373+
= "llvm_create_string_attr"
374+
external is_string_attr : llattribute -> bool = "llvm_is_string_attr"
375+
external get_string_attr_kind : llattribute -> string
376+
= "llvm_get_string_attr_kind"
377+
external get_string_attr_value : llattribute -> string
378+
= "llvm_get_string_attr_value"
379+
380+
let create_enum_attr context name value =
381+
llvm_create_enum_attr context (enum_attr_kind name) value
382+
let create_string_attr context kind value =
383+
llvm_create_string_attr context kind value
384+
385+
let attr_of_repr context repr =
386+
match repr with
387+
| AttrRepr.Enum(kind, value) -> llvm_create_enum_attr context kind value
388+
| AttrRepr.String(key, value) -> llvm_create_string_attr context key value
389+
390+
let repr_of_attr attr =
391+
if is_enum_attr attr then
392+
AttrRepr.Enum(get_enum_attr_kind attr, get_enum_attr_value attr)
393+
else if is_string_attr attr then
394+
AttrRepr.String(get_string_attr_kind attr, get_string_attr_value attr)
395+
else assert false
396+
335397
(*===-- Modules -----------------------------------------------------------===*)
336398
external create_module : llcontext -> string -> llmodule = "llvm_create_module"
337399
external dispose_module : llmodule -> unit = "llvm_dispose_module"
@@ -760,99 +822,27 @@ let rec fold_right_function_range f i e init =
760822
let fold_right_functions f m init =
761823
fold_right_function_range f (function_end m) (At_start m) init
762824

763-
external llvm_add_function_attr : llvalue -> int32 -> unit
825+
external llvm_add_function_attr : llvalue -> llattribute -> int -> unit
764826
= "llvm_add_function_attr"
765-
external llvm_remove_function_attr : llvalue -> int32 -> unit
766-
= "llvm_remove_function_attr"
767-
external llvm_function_attr : llvalue -> int32 = "llvm_function_attr"
768-
769-
let pack_attr (attr:Attribute.t) : int32 =
770-
match attr with
771-
Attribute.Zext -> Int32.shift_left 1l 0
772-
| Attribute.Sext -> Int32.shift_left 1l 1
773-
| Attribute.Noreturn -> Int32.shift_left 1l 2
774-
| Attribute.Inreg -> Int32.shift_left 1l 3
775-
| Attribute.Structret -> Int32.shift_left 1l 4
776-
| Attribute.Nounwind -> Int32.shift_left 1l 5
777-
| Attribute.Noalias -> Int32.shift_left 1l 6
778-
| Attribute.Byval -> Int32.shift_left 1l 7
779-
| Attribute.Nest -> Int32.shift_left 1l 8
780-
| Attribute.Readnone -> Int32.shift_left 1l 9
781-
| Attribute.Readonly -> Int32.shift_left 1l 10
782-
| Attribute.Noinline -> Int32.shift_left 1l 11
783-
| Attribute.Alwaysinline -> Int32.shift_left 1l 12
784-
| Attribute.Optsize -> Int32.shift_left 1l 13
785-
| Attribute.Ssp -> Int32.shift_left 1l 14
786-
| Attribute.Sspreq -> Int32.shift_left 1l 15
787-
| Attribute.Alignment n -> Int32.shift_left (Int32.of_int n) 16
788-
| Attribute.Nocapture -> Int32.shift_left 1l 21
789-
| Attribute.Noredzone -> Int32.shift_left 1l 22
790-
| Attribute.Noimplicitfloat -> Int32.shift_left 1l 23
791-
| Attribute.Naked -> Int32.shift_left 1l 24
792-
| Attribute.Inlinehint -> Int32.shift_left 1l 25
793-
| Attribute.Stackalignment n -> Int32.shift_left (Int32.of_int n) 26
794-
| Attribute.ReturnsTwice -> Int32.shift_left 1l 29
795-
| Attribute.UWTable -> Int32.shift_left 1l 30
796-
| Attribute.NonLazyBind -> Int32.shift_left 1l 31
797-
798-
let unpack_attr (a : int32) : Attribute.t list =
799-
let l = ref [] in
800-
let check attr =
801-
Int32.logand (pack_attr attr) a in
802-
let checkattr attr =
803-
if (check attr) <> 0l then begin
804-
l := attr :: !l
805-
end
806-
in
807-
checkattr Attribute.Zext;
808-
checkattr Attribute.Sext;
809-
checkattr Attribute.Noreturn;
810-
checkattr Attribute.Inreg;
811-
checkattr Attribute.Structret;
812-
checkattr Attribute.Nounwind;
813-
checkattr Attribute.Noalias;
814-
checkattr Attribute.Byval;
815-
checkattr Attribute.Nest;
816-
checkattr Attribute.Readnone;
817-
checkattr Attribute.Readonly;
818-
checkattr Attribute.Noinline;
819-
checkattr Attribute.Alwaysinline;
820-
checkattr Attribute.Optsize;
821-
checkattr Attribute.Ssp;
822-
checkattr Attribute.Sspreq;
823-
let align = Int32.logand (Int32.shift_right_logical a 16) 31l in
824-
if align <> 0l then
825-
l := Attribute.Alignment (Int32.to_int align) :: !l;
826-
checkattr Attribute.Nocapture;
827-
checkattr Attribute.Noredzone;
828-
checkattr Attribute.Noimplicitfloat;
829-
checkattr Attribute.Naked;
830-
checkattr Attribute.Inlinehint;
831-
let stackalign = Int32.logand (Int32.shift_right_logical a 26) 7l in
832-
if stackalign <> 0l then
833-
l := Attribute.Stackalignment (Int32.to_int stackalign) :: !l;
834-
checkattr Attribute.ReturnsTwice;
835-
checkattr Attribute.UWTable;
836-
checkattr Attribute.NonLazyBind;
837-
!l;;
838-
839-
let add_function_attr llval attr =
840-
llvm_add_function_attr llval (pack_attr attr)
841-
842-
external add_target_dependent_function_attr
843-
: llvalue -> string -> string -> unit
844-
= "llvm_add_target_dependent_function_attr"
845-
846-
let remove_function_attr llval attr =
847-
llvm_remove_function_attr llval (pack_attr attr)
848-
849-
let function_attr f = unpack_attr (llvm_function_attr f)
827+
external llvm_function_attrs : llvalue -> int -> llattribute array
828+
= "llvm_function_attrs"
829+
external llvm_remove_enum_function_attr : llvalue -> llattrkind -> int -> unit
830+
= "llvm_remove_enum_function_attr"
831+
external llvm_remove_string_function_attr : llvalue -> string -> int -> unit
832+
= "llvm_remove_string_function_attr"
833+
834+
let add_function_attr f a i =
835+
llvm_add_function_attr f a (AttrIndex.to_int i)
836+
let function_attrs f i =
837+
llvm_function_attrs f (AttrIndex.to_int i)
838+
let remove_enum_function_attr f k i =
839+
llvm_remove_enum_function_attr f k (AttrIndex.to_int i)
840+
let remove_string_function_attr f k i =
841+
llvm_remove_string_function_attr f k (AttrIndex.to_int i)
850842

851843
(*--... Operations on params ...............................................--*)
852844
external params : llvalue -> llvalue array = "llvm_params"
853845
external param : llvalue -> int -> llvalue = "llvm_param"
854-
external llvm_param_attr : llvalue -> int32 = "llvm_param_attr"
855-
let param_attr p = unpack_attr (llvm_param_attr p)
856846
external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
857847
external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin"
858848
external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ"
@@ -899,20 +889,6 @@ let rec fold_right_param_range f init i e =
899889
let fold_right_params f fn init =
900890
fold_right_param_range f init (param_end fn) (At_start fn)
901891

902-
external llvm_add_param_attr : llvalue -> int32 -> unit
903-
= "llvm_add_param_attr"
904-
external llvm_remove_param_attr : llvalue -> int32 -> unit
905-
= "llvm_remove_param_attr"
906-
907-
let add_param_attr llval attr =
908-
llvm_add_param_attr llval (pack_attr attr)
909-
910-
let remove_param_attr llval attr =
911-
llvm_remove_param_attr llval (pack_attr attr)
912-
913-
external set_param_alignment : llvalue -> int -> unit
914-
= "llvm_set_param_alignment"
915-
916892
(*--... Operations on basic blocks .........................................--*)
917893
external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
918894
external value_is_block : llvalue -> bool = "llvm_value_is_block"
@@ -1044,16 +1020,23 @@ external instruction_call_conv: llvalue -> int
10441020
external set_instruction_call_conv: int -> llvalue -> unit
10451021
= "llvm_set_instruction_call_conv"
10461022

1047-
external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit
1048-
= "llvm_add_instruction_param_attr"
1049-
external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit
1050-
= "llvm_remove_instruction_param_attr"
1051-
1052-
let add_instruction_param_attr llval i attr =
1053-
llvm_add_instruction_param_attr llval i (pack_attr attr)
1054-
1055-
let remove_instruction_param_attr llval i attr =
1056-
llvm_remove_instruction_param_attr llval i (pack_attr attr)
1023+
external llvm_add_call_site_attr : llvalue -> llattribute -> int -> unit
1024+
= "llvm_add_call_site_attr"
1025+
external llvm_call_site_attrs : llvalue -> int -> llattribute array
1026+
= "llvm_call_site_attrs"
1027+
external llvm_remove_enum_call_site_attr : llvalue -> llattrkind -> int -> unit
1028+
= "llvm_remove_enum_call_site_attr"
1029+
external llvm_remove_string_call_site_attr : llvalue -> string -> int -> unit
1030+
= "llvm_remove_string_call_site_attr"
1031+
1032+
let add_call_site_attr f a i =
1033+
llvm_add_call_site_attr f a (AttrIndex.to_int i)
1034+
let call_site_attrs f i =
1035+
llvm_call_site_attrs f (AttrIndex.to_int i)
1036+
let remove_enum_call_site_attr f k i =
1037+
llvm_remove_enum_call_site_attr f k (AttrIndex.to_int i)
1038+
let remove_string_call_site_attr f k i =
1039+
llvm_remove_string_call_site_attr f k (AttrIndex.to_int i)
10571040

10581041
(*--... Operations on call instructions (only) .............................--*)
10591042
external is_tail_call : llvalue -> bool = "llvm_is_tail_call"

0 commit comments

Comments
 (0)