summaryrefslogtreecommitdiffstats
path: root/bindings/ocaml/llvm
diff options
context:
space:
mode:
Diffstat (limited to 'bindings/ocaml/llvm')
-rw-r--r--bindings/ocaml/llvm/META.llvm.in63
-rw-r--r--bindings/ocaml/llvm/Makefile21
-rw-r--r--bindings/ocaml/llvm/llvm.ml254
-rw-r--r--bindings/ocaml/llvm/llvm.mli213
-rw-r--r--bindings/ocaml/llvm/llvm_ocaml.c292
5 files changed, 786 insertions, 57 deletions
diff --git a/bindings/ocaml/llvm/META.llvm.in b/bindings/ocaml/llvm/META.llvm.in
new file mode 100644
index 0000000..29e7eb4
--- /dev/null
+++ b/bindings/ocaml/llvm/META.llvm.in
@@ -0,0 +1,63 @@
+name = "llvm"
+version = "@PACKAGE_VERSION@"
+description = "Low Level Virtual Machine OCaml bindings"
+archive(byte) = "llvm.cma"
+archive(native) = "llvm.cmxa"
+directory = "."
+linkopts = "-ccopt -lstdc++"
+
+package "analysis" (
+ requires = "llvm"
+ version = "@PACKAGE_VERSION@"
+ description = "Intermediate representation analysis for LLVM"
+ archive(byte) = "llvm_analysis.cma"
+ archive(native) = "llvm_analysis.cmxa"
+)
+
+package "bitreader" (
+ requires = "llvm"
+ version = "@PACKAGE_VERSION@"
+ description = "Bitcode reader for LLVM"
+ archive(byte) = "llvm_bitreader.cma"
+ archive(native) = "llvm_bitreader.cmxa"
+)
+
+package "bitwriter" (
+ requires = "llvm,unix"
+ version = "@PACKAGE_VERSION@"
+ description = "Bitcode writer for LLVM"
+ archive(byte) = "llvm_bitwriter.cma"
+ archive(native) = "llvm_bitwriter.cmxa"
+)
+
+package "executionengine" (
+ requires = "llvm,llvm.target"
+ version = "@PACKAGE_VERSION@"
+ description = "JIT and Interpreter for LLVM"
+ archive(byte) = "llvm_executionengine.cma"
+ archive(native) = "llvm_executionengine.cmxa"
+)
+
+package "ipo" (
+ requires = "llvm"
+ version = "@PACKAGE_VERSION@"
+ description = "IPO Transforms for LLVM"
+ archive(byte) = "llvm_ipo.cma"
+ archive(native) = "llvm_ipo.cmxa"
+)
+
+package "scalar_opts" (
+ requires = "llvm"
+ version = "@PACKAGE_VERSION@"
+ description = "Scalar Transforms for LLVM"
+ archive(byte) = "llvm_scalar_opts.cma"
+ archive(native) = "llvm_scalar_opts.cmxa"
+)
+
+package "target" (
+ requires = "llvm"
+ version = "@PACKAGE_VERSION@"
+ description = "Target Information for LLVM"
+ archive(byte) = "llvm_target.cma"
+ archive(native) = "llvm_target.cmxa"
+)
diff --git a/bindings/ocaml/llvm/Makefile b/bindings/ocaml/llvm/Makefile
index 99e347b..673eaa2 100644
--- a/bindings/ocaml/llvm/Makefile
+++ b/bindings/ocaml/llvm/Makefile
@@ -17,3 +17,24 @@ UsedComponents := core
UsedOcamLibs := llvm
include ../Makefile.ocaml
+
+all-local:: copy-meta
+install-local:: install-meta
+uninstall-local:: uninstall-meta
+
+DestMETA := $(PROJ_libocamldir)/META.llvm
+
+# Easy way of generating META in the objdir
+copy-meta: $(OcamlDir)/META.llvm
+
+$(OcamlDir)/META.llvm: META.llvm
+ $(Verb) $(CP) -f $< $@
+
+install-meta:: $(ObjDir)/META.llvm
+ $(Echo) "Install $(BuildMode) $(DestMETA)"
+ $(Verb) $(MKDIR) $(PROJ_libocamldir)
+ $(Verb) $(DataInstall) META.llvm "$(DestMETA)"
+
+uninstall-meta::
+ $(Echo) "Uninstalling $(DestMETA)"
+ -$(Verb) $(RM) -f "$(DestMETA)"
diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml
index a62ba37..40b0138 100644
--- 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
@@ -130,6 +133,101 @@ module Fcmp = struct
| True
end
+module Opcode = struct
+ type t =
+ | Invalid (* not an instruction *)
+ (* Terminator Instructions *)
+ | Ret
+ | Br
+ | Switch
+ | IndirectBr
+ | Invoke
+ | Invalid2
+ | Unreachable
+ (* Standard Binary Operators *)
+ | Add
+ | FAdd
+ | Sub
+ | FSub
+ | Mul
+ | FMul
+ | UDiv
+ | SDiv
+ | FDiv
+ | URem
+ | SRem
+ | FRem
+ (* Logical Operators *)
+ | Shl
+ | LShr
+ | AShr
+ | And
+ | Or
+ | Xor
+ (* Memory Operators *)
+ | Alloca
+ | Load
+ | Store
+ | GetElementPtr
+ (* Cast Operators *)
+ | Trunc
+ | ZExt
+ | SExt
+ | FPToUI
+ | FPToSI
+ | UIToFP
+ | SIToFP
+ | FPTrunc
+ | FPExt
+ | PtrToInt
+ | IntToPtr
+ | BitCast
+ (* Other Operators *)
+ | ICmp
+ | FCmp
+ | PHI
+ | Call
+ | Select
+ | UserOp1
+ | UserOp2
+ | VAArg
+ | ExtractElement
+ | InsertElement
+ | ShuffleVector
+ | ExtractValue
+ | InsertValue
+ | Fence
+ | AtomicCmpXchg
+ | AtomicRMW
+ | Resume
+ | LandingPad
+ | Unwind
+end
+
+module ValueKind = struct
+ type t =
+ | NullValue
+ | Argument
+ | BasicBlock
+ | InlineAsm
+ | MDNode
+ | MDString
+ | BlockAddress
+ | ConstantAggregateZero
+ | ConstantArray
+ | ConstantExpr
+ | ConstantFP
+ | ConstantInt
+ | ConstantPointerNull
+ | ConstantStruct
+ | ConstantVector
+ | Function
+ | GlobalAlias
+ | GlobalVariable
+ | UndefValue
+ | Instruction of Opcode.t
+end
+
exception IoError of string
external register_exns : exn -> unit = "llvm_register_core_exns"
@@ -163,10 +261,12 @@ external set_data_layout: string -> llmodule -> unit
external dump_module : llmodule -> unit = "llvm_dump_module"
external set_module_inline_asm : llmodule -> string -> unit
= "llvm_set_module_inline_asm"
+external module_context : llmodule -> llcontext = "LLVMGetModuleContext"
(*===-- Types -------------------------------------------------------------===*)
external classify_type : lltype -> TypeKind.t = "llvm_classify_type"
external type_context : lltype -> llcontext = "llvm_type_context"
+external type_is_sized : lltype -> bool = "llvm_type_is_sized"
(*--... Operations on integer types ........................................--*)
external i1_type : llcontext -> lltype = "llvm_i1_type"
@@ -197,9 +297,15 @@ external param_types : lltype -> lltype array = "llvm_param_types"
external struct_type : llcontext -> lltype array -> lltype = "llvm_struct_type"
external packed_struct_type : llcontext -> lltype array -> lltype
= "llvm_packed_struct_type"
+external struct_name : lltype -> string option = "llvm_struct_name"
+external named_struct_type : llcontext -> string -> lltype =
+ "llvm_named_struct_type"
+external struct_set_body : lltype -> lltype array -> bool -> unit =
+ "llvm_struct_set_body"
external struct_element_types : lltype -> lltype array
= "llvm_struct_element_types"
external is_packed : lltype -> bool = "llvm_is_packed"
+external is_opaque : lltype -> bool = "llvm_is_opaque"
(*--... Operations on pointer, vector, and array types .....................--*)
external array_type : lltype -> int -> lltype = "llvm_array_type"
@@ -216,7 +322,9 @@ external vector_size : lltype -> int = "llvm_vector_size"
(*--... Operations on other types ..........................................--*)
external void_type : llcontext -> lltype = "llvm_void_type"
external label_type : llcontext -> lltype = "llvm_label_type"
+external type_by_name : llmodule -> string -> lltype option = "llvm_type_by_name"
+external classify_value : llvalue -> ValueKind.t = "llvm_classify_value"
(*===-- Values ------------------------------------------------------------===*)
external type_of : llvalue -> lltype = "llvm_type_of"
external value_name : llvalue -> string = "llvm_value_name"
@@ -270,6 +378,7 @@ external const_pointer_null : lltype -> llvalue = "LLVMConstPointerNull"
external undef : lltype -> llvalue = "LLVMGetUndef"
external is_null : llvalue -> bool = "llvm_is_null"
external is_undef : llvalue -> bool = "llvm_is_undef"
+external constexpr_opcode : llvalue -> Opcode.t = "llvm_constexpr_get_opcode"
(*--... Operations on instructions .........................................--*)
external has_metadata : llvalue -> bool = "llvm_has_metadata"
@@ -280,11 +389,15 @@ external clear_metadata : llvalue -> int -> unit = "llvm_clear_metadata"
(*--... Operations on metadata .......,.....................................--*)
external mdstring : llcontext -> string -> llvalue = "llvm_mdstring"
external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode"
+external get_mdstring : llvalue -> string option = "llvm_get_mdstring"
+external get_named_metadata : llmodule -> string -> llvalue array = "llvm_get_namedmd"
(*--... Operations on scalar constants .....................................--*)
external const_int : lltype -> int -> llvalue = "llvm_const_int"
external const_of_int64 : lltype -> Int64.t -> bool -> llvalue
= "llvm_const_of_int64"
+external int64_of_const : llvalue -> Int64.t option
+ = "llvm_int64_of_const"
external const_int_of_string : lltype -> string -> int -> llvalue
= "llvm_const_int_of_string"
external const_float : lltype -> float -> llvalue = "llvm_const_float"
@@ -297,6 +410,8 @@ external const_stringz : llcontext -> string -> llvalue = "llvm_const_stringz"
external const_array : lltype -> llvalue array -> llvalue = "llvm_const_array"
external const_struct : llcontext -> llvalue array -> llvalue
= "llvm_const_struct"
+external const_named_struct : lltype -> llvalue array -> llvalue
+ = "llvm_const_named_struct"
external const_packed_struct : llcontext -> llvalue array -> llvalue
= "llvm_const_packed_struct"
external const_vector : llvalue array -> llvalue = "llvm_const_vector"
@@ -530,36 +645,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)
@@ -567,9 +727,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"
@@ -616,9 +780,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 =
@@ -650,6 +814,8 @@ external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos
= "llvm_block_end"
external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos
= "llvm_block_pred"
+external block_terminator : llbasicblock -> llvalue option =
+ "llvm_block_terminator"
let rec iter_block_range f i e =
if i = e then () else
@@ -702,6 +868,11 @@ external instr_end : llbasicblock -> (llbasicblock, llvalue) llrev_pos
external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos
= "llvm_instr_pred"
+external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode"
+external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate"
+
+external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate"
+
let rec iter_instrs_range f i e =
if i = e then () else
match i with
@@ -749,9 +920,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 =
@@ -769,6 +940,7 @@ external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit
= "llvm_add_incoming"
external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming"
+external delete_instruction : llvalue -> unit = "llvm_delete_instruction"
(*===-- Instruction builders ----------------------------------------------===*)
external builder : llcontext -> llbuilder = "llvm_builder"
@@ -811,8 +983,15 @@ external build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder ->
llvalue = "llvm_build_cond_br"
external build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue
= "llvm_build_switch"
+external build_malloc : lltype -> string -> llbuilder -> llvalue =
+ "llvm_build_malloc"
+external build_array_malloc : lltype -> llvalue -> string -> llbuilder ->
+ llvalue = "llvm_build_array_malloc"
+external build_free : llvalue -> llbuilder -> llvalue = "llvm_build_free"
external add_case : llvalue -> llvalue -> llbasicblock -> unit
= "llvm_add_case"
+external switch_default_dest : llvalue -> llbasicblock =
+ "LLVMGetSwitchDefaultDest"
external build_indirect_br : llvalue -> int -> llbuilder -> llvalue
= "llvm_build_indirect_br"
external add_destination : llvalue -> llbasicblock -> unit
@@ -820,7 +999,11 @@ external add_destination : llvalue -> llbasicblock -> unit
external build_invoke : llvalue -> llvalue array -> llbasicblock ->
llbasicblock -> string -> llbuilder -> llvalue
= "llvm_build_invoke_bc" "llvm_build_invoke_nat"
-external build_unwind : llbuilder -> llvalue = "llvm_build_unwind"
+external build_landingpad : lltype -> llvalue -> int -> string -> llbuilder ->
+ llvalue = "llvm_build_landingpad"
+external set_cleanup : llvalue -> bool -> unit = "llvm_set_cleanup"
+external add_clause : llvalue -> llvalue -> unit = "llvm_add_clause"
+external build_resume : llvalue -> llbuilder -> llvalue = "llvm_build_resume"
external build_unreachable : llbuilder -> llvalue = "llvm_build_unreachable"
(*--... Arithmetic .........................................................--*)
@@ -1022,7 +1205,14 @@ let rec string_of_lltype ty =
(* FIXME: stop infinite recursion! :) *)
match classify_type ty with
TypeKind.Integer -> "i" ^ string_of_int (integer_bitwidth ty)
- | TypeKind.Pointer -> (string_of_lltype (element_type ty)) ^ "*"
+ | TypeKind.Pointer ->
+ (let ety = element_type ty in
+ match classify_type ety with
+ | TypeKind.Struct ->
+ (match struct_name ety with
+ | None -> (string_of_lltype ety)
+ | Some s -> s) ^ "*"
+ | _ -> (string_of_lltype (element_type ty)) ^ "*")
| TypeKind.Struct ->
let s = "{ " ^ (concat2 ", " (
Array.map string_of_lltype (struct_element_types ty)
diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli
index 44f345f..33bbc74 100644
--- 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.
@@ -179,6 +182,103 @@ module Fcmp : sig
| True
end
+(** The opcodes for LLVM instructions and constant expressions. *)
+module Opcode : sig
+ type t =
+ | Invalid (* not an instruction *)
+ (* Terminator Instructions *)
+ | Ret
+ | Br
+ | Switch
+ | IndirectBr
+ | Invoke
+ | Invalid2
+ | Unreachable
+ (* Standard Binary Operators *)
+ | Add
+ | FAdd
+ | Sub
+ | FSub
+ | Mul
+ | FMul
+ | UDiv
+ | SDiv
+ | FDiv
+ | URem
+ | SRem
+ | FRem
+ (* Logical Operators *)
+ | Shl
+ | LShr
+ | AShr
+ | And
+ | Or
+ | Xor
+ (* Memory Operators *)
+ | Alloca
+ | Load
+ | Store
+ | GetElementPtr
+ (* Cast Operators *)
+ | Trunc
+ | ZExt
+ | SExt
+ | FPToUI
+ | FPToSI
+ | UIToFP
+ | SIToFP
+ | FPTrunc
+ | FPExt
+ | PtrToInt
+ | IntToPtr
+ | BitCast
+ (* Other Operators *)
+ | ICmp
+ | FCmp
+ | PHI
+ | Call
+ | Select
+ | UserOp1
+ | UserOp2
+ | VAArg
+ | ExtractElement
+ | InsertElement
+ | ShuffleVector
+ | ExtractValue
+ | InsertValue
+ | Fence
+ | AtomicCmpXchg
+ | AtomicRMW
+ | Resume
+ | LandingPad
+ | Unwind
+end
+
+(** The kind of an [llvalue], the result of [classify_value v].
+ * See the various [LLVMIsA*] functions. *)
+module ValueKind : sig
+ type t =
+ | NullValue
+ | Argument
+ | BasicBlock
+ | InlineAsm
+ | MDNode
+ | MDString
+ | BlockAddress
+ | ConstantAggregateZero
+ | ConstantArray
+ | ConstantExpr
+ | ConstantFP
+ | ConstantInt
+ | ConstantPointerNull
+ | ConstantStruct
+ | ConstantVector
+ | Function
+ | GlobalAlias
+ | GlobalVariable
+ | UndefValue
+ | Instruction of Opcode.t
+end
(** {6 Iteration} *)
@@ -263,7 +363,9 @@ val dump_module : llmodule -> unit
the method [llvm::Module::setModuleInlineAsm]. *)
val set_module_inline_asm : llmodule -> string -> unit
-
+(** [module_context m] returns the context of the specified module.
+ * See the method [llvm::Module::getContext] *)
+val module_context : llmodule -> llcontext
(** {6 Types} *)
@@ -271,6 +373,11 @@ val set_module_inline_asm : llmodule -> string -> unit
See the method [llvm::Type::getTypeID]. *)
val classify_type : lltype -> TypeKind.t
+(** [type_is_sized ty] returns whether the type has a size or not.
+ * If it doesn't then it is not safe to call the [TargetData::] methods on it.
+ * *)
+val type_is_sized : lltype -> bool
+
(** [type_context ty] returns the {!llcontext} corresponding to the type [ty].
See the method [llvm::Type::getContext]. *)
val type_context : lltype -> llcontext
@@ -339,7 +446,7 @@ val ppc_fp128_type : llcontext -> lltype
See the method [llvm::FunctionType::get]. *)
val function_type : lltype -> lltype array -> lltype
-(** [va_arg_function_type ret_ty param_tys] is just like
+(** [var_arg_function_type ret_ty param_tys] is just like
[function_type ret_ty param_tys] except that it returns the function type
which also takes a variable number of arguments.
See the method [llvm::FunctionType::get]. *)
@@ -372,6 +479,19 @@ val struct_type : llcontext -> lltype array -> lltype
[llvm::StructType::get]. *)
val packed_struct_type : llcontext -> lltype array -> lltype
+(** [struct_name ty] returns the name of the named structure type [ty],
+ * or None if the structure type is not named *)
+val struct_name : lltype -> string option
+
+(** [named_struct_type context name] returns the named structure type [name]
+ * in the context [context].
+ * See the method [llvm::StructType::get]. *)
+val named_struct_type : llcontext -> string -> lltype
+
+(** [struct_set_body ty elts ispacked] sets the body of the named struct [ty]
+ * to the [elts] elements.
+ * See the moethd [llvm::StructType::setBody]. *)
+val struct_set_body : lltype -> lltype array -> bool -> unit
(** [struct_element_types sty] returns the constituent types of the struct type
[sty]. See the method [llvm::StructType::getElementType]. *)
@@ -382,6 +502,9 @@ val struct_element_types : lltype -> lltype array
[false] otherwise. See the method [llvm::StructType::isPacked]. *)
val is_packed : lltype -> bool
+(** [is_opaque sty] returns [true] if the structure type [sty] is opaque.
+ [false] otherwise. See the method [llvm::StructType::isOpaque]. *)
+val is_opaque : lltype -> bool
(** {7 Operations on pointer, vector, and array types} *)
@@ -431,12 +554,19 @@ val void_type : llcontext -> lltype
[llvm::Type::LabelTy]. *)
val label_type : llcontext -> lltype
+(** [type_by_name m name] returns the specified type from the current module
+ * if it exists.
+ * See the method [llvm::Module::getTypeByName] *)
+val type_by_name : llmodule -> string -> lltype option
+
(* {6 Values} *)
(** [type_of v] returns the type of the value [v].
See the method [llvm::Value::getType]. *)
val type_of : llvalue -> lltype
+val classify_value : llvalue -> ValueKind.t
+
(** [value_name v] returns the name of the value [v]. For global values, this is
the symbol name. For instructions and basic blocks, it is the SSA register
name. It is meaningless for constants.
@@ -534,7 +664,7 @@ val is_null : llvalue -> bool
otherwise. Similar to [llvm::isa<UndefValue>]. *)
val is_undef : llvalue -> bool
-
+val constexpr_opcode : llvalue -> Opcode.t
(** {7 Operations on instructions} *)
(** [has_metadata i] returns whether or not the instruction [i] has any
@@ -567,6 +697,14 @@ val mdstring : llcontext -> string -> llvalue
See the method [llvm::MDNode::get]. *)
val mdnode : llcontext -> llvalue array -> llvalue
+(** [get_mdstring v] returns the MDString.
+ * See the method [llvm::MDString::getString] *)
+val get_mdstring : llvalue -> string option
+
+(** [get_named_metadata m name] return all the MDNodes belonging to the named
+ * metadata (if any).
+ * See the method [llvm::NamedMDNode::getOperand]. *)
+val get_named_metadata : llmodule -> string -> llvalue array
(** {7 Operations on scalar constants} *)
@@ -578,6 +716,10 @@ val const_int : lltype -> int -> llvalue
[i]. See the method [llvm::ConstantInt::get]. *)
val const_of_int64 : lltype -> Int64.t -> bool -> llvalue
+(** [int64_of_const c] returns the int64 value of the [c] constant integer.
+ * None is returned if this is not an integer constant, or bitwidth exceeds 64.
+ * See the method [llvm::ConstantInt::getSExtValue].*)
+val int64_of_const : llvalue -> Int64.t option
(** [const_int_of_string ty s r] returns the integer constant of type [ty] and
* value [s], with the radix [r]. See the method [llvm::ConstantInt::get]. *)
@@ -618,9 +760,14 @@ val const_array : lltype -> llvalue array -> llvalue
(** [const_struct context elts] returns the structured constant of type
[struct_type (Array.map type_of elts)] and containing the values [elts]
in the context [context]. This value can in turn be used as the initializer
- for a global variable. See the method [llvm::ConstantStruct::get]. *)
+ for a global variable. See the method [llvm::ConstantStruct::getAnon]. *)
val const_struct : llcontext -> llvalue array -> llvalue
+(** [const_named_struct namedty elts] returns the structured constant of type
+ [namedty] (which must be a named structure type) and containing the values [elts].
+ This value can in turn be used as the initializer
+ for a global variable. See the method [llvm::ConstantStruct::get]. *)
+val const_named_struct : lltype -> llvalue array -> llvalue
(** [const_packed_struct context elts] returns the structured constant of
type {!packed_struct_type} [(Array.map type_of elts)] and containing the
@@ -1231,6 +1378,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
@@ -1245,6 +1396,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
@@ -1359,6 +1515,7 @@ val block_end : llvalue -> (llvalue, llbasicblock) llrev_pos
See the method [llvm::Function::iterator::operator--]. *)
val block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos
+val block_terminator : llbasicblock -> llvalue option
(** [rev_iter_blocks f fn] applies function [f] to each of the basic blocks
of function [fn] in reverse order. Tail recursive. *)
@@ -1422,6 +1579,9 @@ val instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos
[f1,...,fN] are the instructions of basic block [bb]. Tail recursive. *)
val fold_right_instrs: (llvalue -> 'a -> 'a) -> llbasicblock -> 'a -> 'a
+val instr_opcode : llvalue -> Opcode.t
+
+val icmp_predicate : llvalue -> Icmp.t option
(** {7 Operations on call sites} *)
@@ -1473,7 +1633,9 @@ val add_incoming : (llvalue * llbasicblock) -> llvalue -> unit
See the method [llvm::PHINode::getIncomingValue]. *)
val incoming : llvalue -> (llvalue * llbasicblock) list
-
+(** [delete_instruction i] deletes the instruction [i].
+ * See the method [llvm::Instruction::eraseFromParent]. *)
+val delete_instruction : llvalue -> unit
(** {6 Instruction builders} *)
@@ -1587,12 +1749,30 @@ val build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder ->
See the method [llvm::LLVMBuilder::CreateSwitch]. *)
val build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue
+(** [build_malloc ty name b] creates an [malloc]
+ instruction at the position specified by the instruction builder [b].
+ See the method [llvm::CallInst::CreateMalloc]. *)
+val build_malloc : lltype -> string -> llbuilder -> llvalue
+
+(** [build_array_malloc ty val name b] creates an [array malloc]
+ instruction at the position specified by the instruction builder [b].
+ See the method [llvm::CallInst::CreateArrayMalloc]. *)
+val build_array_malloc : lltype -> llvalue -> string -> llbuilder -> llvalue
+
+(** [build_free p b] creates a [free]
+ instruction at the position specified by the instruction builder [b].
+ See the method [llvm::LLVMBuilder::CreateFree]. *)
+val build_free : llvalue -> llbuilder -> llvalue
(** [add_case sw onval bb] causes switch instruction [sw] to branch to [bb]
when its input matches the constant [onval].
See the method [llvm::SwitchInst::addCase]. **)
val add_case : llvalue -> llvalue -> llbasicblock -> unit
+(** [switch_default_dest sw] returns the default destination of the [switch]
+ * instruction.
+ * See the method [llvm:;SwitchInst::getDefaultDest]. **)
+val switch_default_dest : llvalue -> llbasicblock
(** [build_indirect_br addr count b] creates a
[indirectbr %addr]
@@ -1615,12 +1795,25 @@ val add_destination : llvalue -> llbasicblock -> unit
val build_invoke : llvalue -> llvalue array -> llbasicblock ->
llbasicblock -> string -> llbuilder -> llvalue
-
-(** [build_unwind b] creates an
- [unwind]
+(** [build_landingpad ty persfn numclauses name b] creates an
+ [landingpad]
instruction at the position specified by the instruction builder [b].
- See the method [llvm::LLVMBuilder::CreateUnwind]. *)
-val build_unwind : llbuilder -> llvalue
+ See the method [llvm::LLVMBuilder::CreateLandingPad]. *)
+val build_landingpad : lltype -> llvalue -> int -> string -> llbuilder ->
+ llvalue
+
+(** [set_cleanup lp] sets the cleanup flag in the [landingpad]instruction.
+ See the method [llvm::LandingPadInst::setCleanup]. *)
+val set_cleanup : llvalue -> bool -> unit
+
+(** [add_clause lp clause] adds the clause to the [landingpad]instruction.
+ See the method [llvm::LandingPadInst::addClause]. *)
+val add_clause : llvalue -> llvalue -> unit
+
+(* [build_resume exn b] builds a [resume exn] instruction
+ * at the position specified by the instruction builder [b].
+ * See the method [llvm::LLVMBuilder::CreateResume] *)
+val build_resume : llvalue -> llbuilder -> llvalue
(** [build_unreachable b] creates an
[unreachable]
diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c
index 455e191..86cc4bd 100644
--- a/bindings/ocaml/llvm/llvm_ocaml.c
+++ b/bindings/ocaml/llvm/llvm_ocaml.c
@@ -24,6 +24,7 @@
#include "llvm/Config/config.h"
#include <assert.h>
#include <stdlib.h>
+#include <string.h>
/* Can't use the recommended caml_named_value mechanism for backwards
@@ -171,6 +172,10 @@ CAMLprim value llvm_classify_type(LLVMTypeRef Ty) {
return Val_int(LLVMGetTypeKind(Ty));
}
+CAMLprim value llvm_type_is_sized(LLVMTypeRef Ty) {
+ return Val_bool(LLVMTypeIsSized(Ty));
+}
+
/* lltype -> llcontext */
CAMLprim LLVMContextRef llvm_type_context(LLVMTypeRef Ty) {
return LLVMGetTypeContext(Ty);
@@ -287,6 +292,34 @@ CAMLprim LLVMTypeRef llvm_packed_struct_type(LLVMContextRef C,
Wosize_val(ElementTypes), 1);
}
+/* llcontext -> string -> lltype */
+CAMLprim LLVMTypeRef llvm_named_struct_type(LLVMContextRef C,
+ value Name) {
+ return LLVMStructCreateNamed(C, String_val(Name));
+}
+
+CAMLprim value llvm_struct_set_body(LLVMTypeRef Ty,
+ value ElementTypes,
+ value Packed) {
+ LLVMStructSetBody(Ty, (LLVMTypeRef *) ElementTypes,
+ Wosize_val(ElementTypes), Bool_val(Packed));
+ return Val_unit;
+}
+
+/* lltype -> string option */
+CAMLprim value llvm_struct_name(LLVMTypeRef Ty)
+{
+ CAMLparam0();
+ const char *C = LLVMGetStructName(Ty);
+ if (C) {
+ CAMLlocal1(result);
+ result = caml_alloc_small(1, 0);
+ Store_field(result, 0, caml_copy_string(C));
+ CAMLreturn(result);
+ }
+ CAMLreturn(Val_int(0));
+}
+
/* lltype -> lltype array */
CAMLprim value llvm_struct_element_types(LLVMTypeRef StructTy) {
value Tys = alloc(LLVMCountStructElementTypes(StructTy), 0);
@@ -299,6 +332,11 @@ CAMLprim value llvm_is_packed(LLVMTypeRef StructTy) {
return Val_bool(LLVMIsPackedStruct(StructTy));
}
+/* lltype -> bool */
+CAMLprim value llvm_is_opaque(LLVMTypeRef StructTy) {
+ return Val_bool(LLVMIsOpaqueStruct(StructTy));
+}
+
/*--... Operations on array, pointer, and vector types .....................--*/
/* lltype -> int -> lltype */
@@ -349,6 +387,18 @@ CAMLprim LLVMTypeRef llvm_label_type(LLVMContextRef Context) {
return LLVMLabelTypeInContext(Context);
}
+CAMLprim value llvm_type_by_name(LLVMModuleRef M, value Name)
+{
+ CAMLparam1(Name);
+ LLVMTypeRef Ty = LLVMGetTypeByName(M, String_val(Name));
+ if (Ty) {
+ value Option = alloc(1, 0);
+ Field(Option, 0) = (value) Ty;
+ CAMLreturn(Option);
+ }
+ CAMLreturn(Val_int(0));
+}
+
/*===-- VALUES ------------------------------------------------------------===*/
/* llvalue -> lltype */
@@ -356,6 +406,69 @@ CAMLprim LLVMTypeRef llvm_type_of(LLVMValueRef Val) {
return LLVMTypeOf(Val);
}
+/* keep in sync with ValueKind.t */
+enum ValueKind {
+ NullValue=0,
+ Argument,
+ BasicBlock,
+ InlineAsm,
+ MDNode,
+ MDString,
+ BlockAddress,
+ ConstantAggregateZero,
+ ConstantArray,
+ ConstantExpr,
+ ConstantFP,
+ ConstantInt,
+ ConstantPointerNull,
+ ConstantStruct,
+ ConstantVector,
+ Function,
+ GlobalAlias,
+ GlobalVariable,
+ UndefValue,
+ Instruction
+};
+
+/* llvalue -> ValueKind.t */
+#define DEFINE_CASE(Val, Kind) \
+ do {if (LLVMIsA##Kind(Val)) CAMLreturn(Val_int(Kind));} while(0)
+
+CAMLprim value llvm_classify_value(LLVMValueRef Val) {
+ CAMLparam0();
+ if (!Val)
+ CAMLreturn(Val_int(NullValue));
+ if (LLVMIsAConstant(Val)) {
+ DEFINE_CASE(Val, BlockAddress);
+ DEFINE_CASE(Val, ConstantAggregateZero);
+ DEFINE_CASE(Val, ConstantArray);
+ DEFINE_CASE(Val, ConstantExpr);
+ DEFINE_CASE(Val, ConstantFP);
+ DEFINE_CASE(Val, ConstantInt);
+ DEFINE_CASE(Val, ConstantPointerNull);
+ DEFINE_CASE(Val, ConstantStruct);
+ DEFINE_CASE(Val, ConstantVector);
+ }
+ if (LLVMIsAInstruction(Val)) {
+ CAMLlocal1(result);
+ result = caml_alloc_small(1, 0);
+ Store_field(result, 0, Val_int(LLVMGetInstructionOpcode(Val)));
+ CAMLreturn(result);
+ }
+ if (LLVMIsAGlobalValue(Val)) {
+ DEFINE_CASE(Val, Function);
+ DEFINE_CASE(Val, GlobalAlias);
+ DEFINE_CASE(Val, GlobalVariable);
+ }
+ DEFINE_CASE(Val, Argument);
+ DEFINE_CASE(Val, BasicBlock);
+ DEFINE_CASE(Val, InlineAsm);
+ DEFINE_CASE(Val, MDNode);
+ DEFINE_CASE(Val, MDString);
+ DEFINE_CASE(Val, UndefValue);
+ failwith("Unknown Value class");
+}
+
/* llvalue -> string */
CAMLprim value llvm_value_name(LLVMValueRef Val) {
return copy_string(LLVMGetValueName(Val));
@@ -408,6 +521,12 @@ CAMLprim value llvm_is_undef(LLVMValueRef Val) {
return Val_bool(LLVMIsUndef(Val));
}
+/* llvalue -> Opcode.t */
+CAMLprim value llvm_constexpr_get_opcode(LLVMValueRef Val) {
+ return LLVMIsAConstantExpr(Val) ?
+ Val_int(LLVMGetConstOpcode(Val)) : Val_int(0);
+}
+
/*--... Operations on instructions .........................................--*/
/* llvalue -> bool */
@@ -454,6 +573,32 @@ CAMLprim LLVMValueRef llvm_mdnode(LLVMContextRef C, value ElementVals) {
Wosize_val(ElementVals));
}
+/* llvalue -> string option */
+CAMLprim value llvm_get_mdstring(LLVMValueRef V) {
+ CAMLparam0();
+ const char *S;
+ unsigned Len;
+
+ if ((S = LLVMGetMDString(V, &Len))) {
+ CAMLlocal2(Option, Str);
+
+ Str = caml_alloc_string(Len);
+ memcpy(String_val(Str), S, Len);
+ Option = alloc(1,0);
+ Store_field(Option, 0, Str);
+ CAMLreturn(Option);
+ }
+ CAMLreturn(Val_int(0));
+}
+
+CAMLprim value llvm_get_namedmd(LLVMModuleRef M, value name)
+{
+ CAMLparam1(name);
+ CAMLlocal1(Nodes);
+ Nodes = alloc(LLVMGetNamedMetadataNumOperands(M, String_val(name)), 0);
+ LLVMGetNamedMetadataOperands(M, String_val(name), (LLVMValueRef *) Nodes);
+ CAMLreturn(Nodes);
+}
/*--... Operations on scalar constants .....................................--*/
/* lltype -> int -> llvalue */
@@ -467,6 +612,19 @@ CAMLprim LLVMValueRef llvm_const_of_int64(LLVMTypeRef IntTy, value N,
return LLVMConstInt(IntTy, Int64_val(N), Bool_val(SExt));
}
+/* llvalue -> Int64.t */
+CAMLprim value llvm_int64_of_const(LLVMValueRef Const)
+{
+ CAMLparam0();
+ if (LLVMIsAConstantInt(Const) &&
+ LLVMGetIntTypeWidth(LLVMTypeOf(Const)) <= 64) {
+ value Option = alloc(1, 0);
+ Field(Option, 0) = caml_copy_int64(LLVMConstIntGetSExtValue(Const));
+ CAMLreturn(Option);
+ }
+ CAMLreturn(Val_int(0));
+}
+
/* lltype -> string -> int -> llvalue */
CAMLprim LLVMValueRef llvm_const_int_of_string(LLVMTypeRef IntTy, value S,
value Radix) {
@@ -514,6 +672,11 @@ CAMLprim LLVMValueRef llvm_const_struct(LLVMContextRef C, value ElementVals) {
Wosize_val(ElementVals), 0);
}
+/* lltype -> llvalue array -> llvalue */
+CAMLprim LLVMValueRef llvm_const_named_struct(LLVMTypeRef Ty, value ElementVals) {
+ return LLVMConstNamedStruct(Ty, (LLVMValueRef *) Op_val(ElementVals), Wosize_val(ElementVals));
+}
+
/* llcontext -> llvalue array -> llvalue */
CAMLprim LLVMValueRef llvm_const_packed_struct(LLVMContextRef C,
value ElementVals) {
@@ -883,15 +1046,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 ...........................................--*/
@@ -903,6 +1073,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);
@@ -910,15 +1087,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;
}
@@ -933,6 +1110,19 @@ CAMLprim value llvm_set_param_alignment(LLVMValueRef Arg, value align) {
DEFINE_ITERATORS(
block, BasicBlock, LLVMValueRef, LLVMBasicBlockRef, LLVMGetBasicBlockParent)
+/* llbasicblock -> llvalue option */
+CAMLprim value llvm_block_terminator(LLVMBasicBlockRef Block)
+{
+ CAMLparam0();
+ LLVMValueRef Term = LLVMGetBasicBlockTerminator(Block);
+ if (Term) {
+ value Option = alloc(1, 0);
+ Field(Option, 0) = (value) Term;
+ CAMLreturn(Option);
+ }
+ CAMLreturn(Val_int(0));
+}
+
/* llvalue -> llbasicblock array */
CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) {
value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0);
@@ -968,6 +1158,28 @@ CAMLprim value llvm_value_is_block(LLVMValueRef Val) {
DEFINE_ITERATORS(instr, Instruction, LLVMBasicBlockRef, LLVMValueRef,
LLVMGetInstructionParent)
+/* llvalue -> Opcode.t */
+CAMLprim value llvm_instr_get_opcode(LLVMValueRef Inst) {
+ LLVMOpcode o;
+ if (!LLVMIsAInstruction(Inst))
+ failwith("Not an instruction");
+ o = LLVMGetInstructionOpcode(Inst);
+ assert (o <= LLVMUnwind );
+ return Val_int(o);
+}
+
+/* llvalue -> ICmp.t */
+CAMLprim value llvm_instr_icmp_predicate(LLVMValueRef Val) {
+ CAMLparam0();
+ int x = LLVMGetICmpPredicate(Val);
+ if (x) {
+ value Option = alloc(1, 0);
+ Field(Option, 0) = Val_int(x - LLVMIntEQ);
+ CAMLreturn(Option);
+ }
+ CAMLreturn(Val_int(0));
+}
+
/*--... Operations on call sites ...........................................--*/
@@ -982,19 +1194,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;
}
@@ -1045,6 +1257,11 @@ CAMLprim value llvm_incoming(LLVMValueRef PhiNode) {
CAMLreturn(Tl);
}
+/* llvalue -> unit */
+CAMLprim value llvm_delete_instruction(LLVMValueRef Instruction) {
+ LLVMInstructionEraseFromParent(Instruction);
+ return Val_unit;
+}
/*===-- Instruction builders ----------------------------------------------===*/
@@ -1172,6 +1389,27 @@ CAMLprim LLVMValueRef llvm_build_switch(LLVMValueRef Of,
return LLVMBuildSwitch(Builder_val(B), Of, Else, Int_val(EstimatedCount));
}
+/* lltype -> string -> llbuilder -> llvalue */
+CAMLprim LLVMValueRef llvm_build_malloc(LLVMTypeRef Ty, value Name,
+ value B)
+{
+ return LLVMBuildMalloc(Builder_val(B), Ty, String_val(Name));
+}
+
+/* lltype -> llvalue -> string -> llbuilder -> llvalue */
+CAMLprim LLVMValueRef llvm_build_array_malloc(LLVMTypeRef Ty,
+ LLVMValueRef Val,
+ value Name, value B)
+{
+ return LLVMBuildArrayMalloc(Builder_val(B), Ty, Val, String_val(Name));
+}
+
+/* llvalue -> llbuilder -> llvalue */
+CAMLprim LLVMValueRef llvm_build_free(LLVMValueRef P, value B)
+{
+ return LLVMBuildFree(Builder_val(B), P);
+}
+
/* llvalue -> llvalue -> llbasicblock -> unit */
CAMLprim value llvm_add_case(LLVMValueRef Switch, LLVMValueRef OnVal,
LLVMBasicBlockRef Dest) {
@@ -1212,9 +1450,33 @@ CAMLprim LLVMValueRef llvm_build_invoke_bc(value Args[], int NumArgs) {
Args[4], Args[5]);
}
-/* llbuilder -> llvalue */
-CAMLprim LLVMValueRef llvm_build_unwind(value B) {
- return LLVMBuildUnwind(Builder_val(B));
+/* lltype -> llvalue -> int -> string -> llbuilder -> llvalue */
+CAMLprim LLVMValueRef llvm_build_landingpad(LLVMTypeRef Ty, LLVMValueRef PersFn,
+ value NumClauses, value Name,
+ value B) {
+ return LLVMBuildLandingPad(Builder_val(B), Ty, PersFn, Int_val(NumClauses),
+ String_val(Name));
+}
+
+/* llvalue -> llvalue -> unit */
+CAMLprim value llvm_add_clause(LLVMValueRef LandingPadInst, LLVMValueRef ClauseVal)
+{
+ LLVMAddClause(LandingPadInst, ClauseVal);
+ return Val_unit;
+}
+
+
+/* llvalue -> bool -> unit */
+CAMLprim value llvm_set_cleanup(LLVMValueRef LandingPadInst, value flag)
+{
+ LLVMSetCleanup(LandingPadInst, Bool_val(flag));
+ return Val_unit;
+}
+
+/* llvalue -> llbuilder -> llvalue */
+CAMLprim LLVMValueRef llvm_build_resume(LLVMValueRef Exn, value B)
+{
+ return LLVMBuildResume(Builder_val(B), Exn);
}
/* llbuilder -> llvalue */
OpenPOWER on IntegriCloud