OCaml bindings: fix attributes to use all 32 bits

OCaml's int is limited to 31 bits on 32-bit architectures, so use Int32
explicitly.
Also add an unpack_attr, and {function,param,instr}_attr functions to read
the attributes.

git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@141996 91177308-0d34-0410-b5e6-96231b3b80d8

diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml
index 0b24fd5..2f4b4ae 100644 (file)
--- a/bindings/ocaml/llvm/llvm.ml
+++ b/bindings/ocaml/llvm/llvm.ml
@@ -94,6 +94,9 @@ module Attribute = struct
   | Naked
   | Inlinehint
   | Stackalignment of int
+  | ReturnsTwice
+  | UWTable
+  | NonLazyBind
 end
 
 module Icmp = struct
@@ -640,36 +643,81 @@ 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 -> int -> unit
+external llvm_add_function_attr : llvalue -> int32 -> unit
                                 = "llvm_add_function_attr"
-external llvm_remove_function_attr : llvalue -> int -> unit
+external llvm_remove_function_attr : llvalue -> int32 -> unit
                                    = "llvm_remove_function_attr"
+external llvm_function_attr : llvalue -> int32 = "llvm_function_attr"
 
-let pack_attr (attr:Attribute.t) : int =
+let pack_attr (attr:Attribute.t) : int32 =
   match attr with
-      Attribute.Zext              -> 1 lsl 0
-    | Attribute.Sext              -> 1 lsl 1
-    | Attribute.Noreturn          -> 1 lsl 2
-    | Attribute.Inreg             -> 1 lsl 3
-    | Attribute.Structret         -> 1 lsl 4
-    | Attribute.Nounwind          -> 1 lsl 5
-    | Attribute.Noalias           -> 1 lsl 6
-    | Attribute.Byval             -> 1 lsl 7
-    | Attribute.Nest              -> 1 lsl 8
-    | Attribute.Readnone          -> 1 lsl 9
-    | Attribute.Readonly          -> 1 lsl 10
-    | Attribute.Noinline          -> 1 lsl 11
-    | Attribute.Alwaysinline      -> 1 lsl 12
-    | Attribute.Optsize           -> 1 lsl 13
-    | Attribute.Ssp               -> 1 lsl 14
-    | Attribute.Sspreq            -> 1 lsl 15
-    | Attribute.Alignment n       -> n lsl 16
-    | Attribute.Nocapture         -> 1 lsl 21
-    | Attribute.Noredzone         -> 1 lsl 22
-    | Attribute.Noimplicitfloat   -> 1 lsl 23
-    | Attribute.Naked             -> 1 lsl 24
-    | Attribute.Inlinehint        -> 1 lsl 25
-    | Attribute.Stackalignment n  -> n lsl 26
+  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)
@@ -677,9 +725,13 @@ let add_function_attr llval 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)
+
 (*--... 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"
@@ -726,9 +778,9 @@ 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 -> int -> unit
+external llvm_add_param_attr : llvalue -> int32 -> unit
                                 = "llvm_add_param_attr"
-external llvm_remove_param_attr : llvalue -> int -> unit
+external llvm_remove_param_attr : llvalue -> int32 -> unit
                                 = "llvm_remove_param_attr"
 
 let add_param_attr llval attr =
@@ -864,9 +916,9 @@ 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 -> int -> unit
+external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit
                                          = "llvm_add_instruction_param_attr"
-external llvm_remove_instruction_param_attr : llvalue -> int -> int -> unit
+external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit
                                          = "llvm_remove_instruction_param_attr"
 
 let add_instruction_param_attr llval i attr =

diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli
index f5538f4..a90a72b 100644 (file)
--- a/bindings/ocaml/llvm/llvm.mli
+++ b/bindings/ocaml/llvm/llvm.mli
@@ -139,6 +139,9 @@ module Attribute : sig
   | Naked
   | Inlinehint
   | Stackalignment of int
+  | ReturnsTwice
+  | UWTable
+  | NonLazyBind
 end
 
 (** The predicate for an integer comparison ([icmp]) instruction.
@@ -1368,6 +1371,10 @@ val set_gc : string option -> llvalue -> unit
     [f]. *)
 val add_function_attr : llvalue -> Attribute.t -> unit
 
+(** [function_attr f] returns the function attribute for the function [f].
+ * See the method [llvm::Function::getAttributes] *)
+val function_attr : llvalue -> Attribute.t list
+
 (** [remove_function_attr f a] removes attribute [a] from the return type of
     function [f]. *)
 val remove_function_attr : llvalue -> Attribute.t -> unit
@@ -1382,6 +1389,11 @@ 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

diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c
index be6e808..5090bf8 100644 (file)
--- a/bindings/ocaml/llvm/llvm_ocaml.c
+++ b/bindings/ocaml/llvm/llvm_ocaml.c
@@ -1034,15 +1034,22 @@ CAMLprim value llvm_set_gc(value GC, LLVMValueRef Fn) {
   return Val_unit;
 }
 
-/* llvalue -> Attribute.t -> unit */
+/* llvalue -> int32 -> unit */
 CAMLprim value llvm_add_function_attr(LLVMValueRef Arg, value PA) {
-  LLVMAddFunctionAttr(Arg, Int_val(PA));
+  LLVMAddFunctionAttr(Arg, Int32_val(PA));
   return Val_unit;
 }
 
-/* llvalue -> Attribute.t -> 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, Int_val(PA));
+  LLVMRemoveFunctionAttr(Arg, Int32_val(PA));
   return Val_unit;
 }
 /*--... Operations on parameters ...........................................--*/
@@ -1054,6 +1061,13 @@ 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);
@@ -1061,15 +1075,15 @@ CAMLprim value llvm_params(LLVMValueRef Fn) {
   return Params;
 }
 
-/* llvalue -> Attribute.t -> unit */
+/* llvalue -> int32 -> unit */
 CAMLprim value llvm_add_param_attr(LLVMValueRef Arg, value PA) {
-  LLVMAddAttribute(Arg, Int_val(PA));
+  LLVMAddAttribute(Arg, Int32_val(PA));
   return Val_unit;
 }
 
-/* llvalue -> Attribute.t -> unit */
+/* llvalue -> int32 -> unit */
 CAMLprim value llvm_remove_param_attr(LLVMValueRef Arg, value PA) {
-  LLVMRemoveAttribute(Arg, Int_val(PA));
+  LLVMRemoveAttribute(Arg, Int32_val(PA));
   return Val_unit;
 }
 
@@ -1155,19 +1169,19 @@ CAMLprim value llvm_set_instruction_call_conv(value CC, LLVMValueRef Inst) {
   return Val_unit;
 }
 
-/* llvalue -> int -> Attribute.t -> unit */
+/* llvalue -> int -> int32 -> unit */
 CAMLprim value llvm_add_instruction_param_attr(LLVMValueRef Instr,
                                                value index,
                                                value PA) {
-  LLVMAddInstrAttribute(Instr, Int_val(index), Int_val(PA));
+  LLVMAddInstrAttribute(Instr, Int_val(index), Int32_val(PA));
   return Val_unit;
 }
 
-/* llvalue -> int -> Attribute.t -> unit */
+/* llvalue -> int -> int32 -> unit */
 CAMLprim value llvm_remove_instruction_param_attr(LLVMValueRef Instr,
                                                   value index,
                                                   value PA) {
-  LLVMRemoveInstrAttribute(Instr, Int_val(index), Int_val(PA));
+  LLVMRemoveInstrAttribute(Instr, Int_val(index), Int32_val(PA));
   return Val_unit;
 }