diff options
author | Dimitry Andric <dim@FreeBSD.org> | 2015-01-18 16:17:27 +0000 |
---|---|---|
committer | Dimitry Andric <dim@FreeBSD.org> | 2015-01-18 16:17:27 +0000 |
commit | 67c32a98315f785a9ec9d531c1f571a0196c7463 (patch) | |
tree | 4abb9cbeecc7901726dd0b4a37369596c852e9ef /bindings/ocaml/llvm | |
parent | 9f61947910e6ab40de38e6b4034751ef1513200f (diff) |
Diffstat (limited to 'bindings/ocaml/llvm')
-rw-r--r-- | bindings/ocaml/llvm/CMakeLists.txt | 11 | ||||
-rw-r--r-- | bindings/ocaml/llvm/META.llvm.in | 11 | ||||
-rw-r--r-- | bindings/ocaml/llvm/Makefile | 9 | ||||
-rw-r--r-- | bindings/ocaml/llvm/llvm.ml | 81 | ||||
-rw-r--r-- | bindings/ocaml/llvm/llvm.mli | 204 | ||||
-rw-r--r-- | bindings/ocaml/llvm/llvm_ocaml.c | 255 |
6 files changed, 446 insertions, 125 deletions
diff --git a/bindings/ocaml/llvm/CMakeLists.txt b/bindings/ocaml/llvm/CMakeLists.txt new file mode 100644 index 000000000000..4956fa4dade3 --- /dev/null +++ b/bindings/ocaml/llvm/CMakeLists.txt @@ -0,0 +1,11 @@ +add_ocaml_library(llvm + OCAML llvm + C llvm_ocaml + LLVM core support) + +configure_file( + "${CMAKE_CURRENT_SOURCE_DIR}/META.llvm.in" + "${LLVM_LIBRARY_DIR}/ocaml/META.llvm") + +install(FILES "${LLVM_LIBRARY_DIR}/ocaml/META.llvm" + DESTINATION lib/ocaml) diff --git a/bindings/ocaml/llvm/META.llvm.in b/bindings/ocaml/llvm/META.llvm.in index edb84e0af0dc..92896e387a6c 100644 --- a/bindings/ocaml/llvm/META.llvm.in +++ b/bindings/ocaml/llvm/META.llvm.in @@ -4,7 +4,6 @@ description = "LLVM OCaml bindings" archive(byte) = "llvm.cma" archive(native) = "llvm.cmxa" directory = "." -linkopts = "-ccopt -lstdc++" package "analysis" ( requires = "llvm" @@ -31,7 +30,7 @@ package "bitwriter" ( ) package "executionengine" ( - requires = "llvm,llvm.target" + requires = "llvm,llvm.target,ctypes.foreign" version = "@PACKAGE_VERSION@" description = "JIT and Interpreter for LLVM" archive(byte) = "llvm_executionengine.cma" @@ -62,6 +61,14 @@ package "scalar_opts" ( archive(native) = "llvm_scalar_opts.cmxa" ) +package "transform_utils" ( + requires = "llvm" + version = "@PACKAGE_VERSION@" + description = "Transform utilities for LLVM" + archive(byte) = "llvm_transform_utils.cma" + archive(native) = "llvm_transform_utils.cmxa" +) + package "vectorize" ( requires = "llvm" version = "@PACKAGE_VERSION@" diff --git a/bindings/ocaml/llvm/Makefile b/bindings/ocaml/llvm/Makefile index 850f564a0c22..c0785a154d22 100644 --- a/bindings/ocaml/llvm/Makefile +++ b/bindings/ocaml/llvm/Makefile @@ -1,20 +1,21 @@ ##===- bindings/ocaml/llvm/Makefile ------------------------*- Makefile -*-===## -# +# # The LLVM Compiler Infrastructure # # This file is distributed under the University of Illinois Open Source # License. See LICENSE.TXT for details. -# +# ##===----------------------------------------------------------------------===## -# +# # This is the makefile for the Objective Caml Llvm interface. -# +# ##===----------------------------------------------------------------------===## LEVEL := ../../.. LIBRARYNAME := llvm UsedComponents := core UsedOcamlLibs := llvm +ExtraLibs := -lstdc++ include ../Makefile.ocaml diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml index 39875a5ed488..042edcba84ee 100644 --- a/bindings/ocaml/llvm/llvm.ml +++ b/bindings/ocaml/llvm/llvm.ml @@ -1,4 +1,4 @@ -(*===-- llvm/llvm.ml - LLVM Ocaml Interface --------------------------------===* +(*===-- llvm/llvm.ml - LLVM OCaml Interface -------------------------------===* * * The LLVM Compiler Infrastructure * @@ -66,6 +66,13 @@ module Visibility = struct | Protected end +module DLLStorageClass = struct + type t = + | Default + | DLLImport + | DLLExport +end + module CallConv = struct let c = 0 let fast = 8 @@ -278,8 +285,7 @@ end exception IoError of string -external register_exns : exn -> unit = "llvm_register_core_exns" -let _ = register_exns (IoError "") +let () = Callback.register_exception "Llvm.IoError" (IoError "") external install_fatal_error_handler : (string -> unit) -> unit = "llvm_install_fatal_error_handler" @@ -287,6 +293,8 @@ external reset_fatal_error_handler : unit -> unit = "llvm_reset_fatal_error_handler" external enable_pretty_stacktrace : unit -> unit = "llvm_enable_pretty_stacktrace" +external parse_command_line_options : ?overview:string -> string array -> unit + = "llvm_parse_command_line_options" type ('a, 'b) llpos = | At_end of 'a @@ -428,6 +436,7 @@ let fold_right_uses f v init = (*--... Operations on users ................................................--*) external operand : llvalue -> int -> llvalue = "llvm_operand" +external operand_use : llvalue -> int -> lluse = "llvm_operand_use" external set_operand : llvalue -> int -> llvalue -> unit = "llvm_set_operand" external num_operands : llvalue -> int = "llvm_num_operands" @@ -450,6 +459,7 @@ external clear_metadata : llvalue -> llmdkind -> unit = "llvm_clear_metadata" (*--... Operations on metadata .......,.....................................--*) external mdstring : llcontext -> string -> llvalue = "llvm_mdstring" external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode" +external mdnull : llcontext -> llvalue = "llvm_mdnull" external get_mdstring : llvalue -> string option = "llvm_get_mdstring" external get_named_metadata : llmodule -> string -> llvalue array = "llvm_get_namedmd" @@ -465,6 +475,8 @@ external int64_of_const : llvalue -> Int64.t option external const_int_of_string : lltype -> string -> int -> llvalue = "llvm_const_int_of_string" external const_float : lltype -> float -> llvalue = "llvm_const_float" +external float_of_const : llvalue -> float option + = "llvm_float_of_const" external const_float_of_string : lltype -> string -> llvalue = "llvm_const_float_of_string" @@ -479,6 +491,8 @@ external const_named_struct : lltype -> llvalue array -> llvalue external const_packed_struct : llcontext -> llvalue array -> llvalue = "llvm_const_packed_struct" external const_vector : llvalue array -> llvalue = "llvm_const_vector" +external string_of_const : llvalue -> string option = "llvm_string_of_const" +external const_element : llvalue -> int -> llvalue = "llvm_const_element" (*--... Constant expressions ...............................................--*) external align_of : lltype -> llvalue = "LLVMAlignOf" @@ -569,6 +583,8 @@ external section : llvalue -> string = "llvm_section" external set_section : string -> llvalue -> unit = "llvm_set_section" external visibility : llvalue -> Visibility.t = "llvm_visibility" external set_visibility : Visibility.t -> llvalue -> unit = "llvm_set_visibility" +external dll_storage_class : llvalue -> DLLStorageClass.t = "llvm_dll_storage_class" +external set_dll_storage_class : DLLStorageClass.t -> llvalue -> unit = "llvm_set_dll_storage_class" external alignment : llvalue -> int = "llvm_alignment" external set_alignment : int -> llvalue -> unit = "llvm_set_alignment" external is_global_constant : llvalue -> bool = "llvm_is_global_constant" @@ -952,6 +968,8 @@ external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode" external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate" +external fcmp_predicate : llvalue -> Fcmp.t option = "llvm_instr_fcmp_predicate" +external instr_clone : llvalue -> llvalue = "llvm_instr_clone" let rec iter_instrs_range f i e = if i = e then () else @@ -1019,6 +1037,63 @@ external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call" external is_volatile : llvalue -> bool = "llvm_is_volatile" external set_volatile : bool -> llvalue -> unit = "llvm_set_volatile" +(*--... Operations on terminators ..........................................--*) + +let is_terminator llv = + let open ValueKind in + let open Opcode in + match classify_value llv with + | Instruction (Br | IndirectBr | Invoke | Resume | Ret | Switch | Unreachable) + -> true + | _ -> false + +external successor : llvalue -> int -> llbasicblock = "llvm_successor" +external set_successor : llvalue -> int -> llbasicblock -> unit + = "llvm_set_successor" +external num_successors : llvalue -> int = "llvm_num_successors" + +let successors llv = + if not (is_terminator llv) then + raise (Invalid_argument "Llvm.successors can only be used on terminators") + else + Array.init (num_successors llv) (successor llv) + +let iter_successors f llv = + if not (is_terminator llv) then + raise (Invalid_argument "Llvm.iter_successors can only be used on terminators") + else + for i = 0 to num_successors llv - 1 do + f (successor llv i) + done + +let fold_successors f llv z = + if not (is_terminator llv) then + raise (Invalid_argument "Llvm.fold_successors can only be used on terminators") + else + let n = num_successors llv in + let rec aux i acc = + if i >= n then acc + else begin + let llb = successor llv i in + aux (i+1) (f llb acc) + end + in aux 0 z + + +(*--... Operations on branches .............................................--*) +external condition : llvalue -> llvalue = "llvm_condition" +external set_condition : llvalue -> llvalue -> unit + = "llvm_set_condition" +external is_conditional : llvalue -> bool = "llvm_is_conditional" + +let get_branch llv = + if classify_value llv <> ValueKind.Instruction Opcode.Br then + None + else if is_conditional llv then + Some (`Conditional (condition llv, successor llv 0, successor llv 1)) + else + Some (`Unconditional (successor llv 0)) + (*--... Operations on phi nodes ............................................--*) external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit = "llvm_add_incoming" diff --git a/bindings/ocaml/llvm/llvm.mli b/bindings/ocaml/llvm/llvm.mli index f5f5b53e84d5..8fdddd1895e5 100644 --- a/bindings/ocaml/llvm/llvm.mli +++ b/bindings/ocaml/llvm/llvm.mli @@ -105,6 +105,15 @@ module Visibility : sig | Protected end +(** The DLL storage class of a global value, accessed with {!dll_storage_class} and + {!set_dll_storage_class}. See [llvm::GlobalValue::DLLStorageClassTypes]. *) +module DLLStorageClass : sig + type t = + | Default + | DLLImport + | DLLExport +end + (** The following calling convention values may be accessed with {!function_call_conv} and {!set_function_call_conv}. Calling conventions are open-ended. *) @@ -157,16 +166,16 @@ end See the [llvm::ICmpInst::Predicate] enumeration. *) module Icmp : sig type t = - | Eq (* Equal *) - | Ne (* Not equal *) - | Ugt (* Unsigned greater than *) - | Uge (* Unsigned greater or equal *) - | Ult (* Unsigned less than *) - | Ule (* Unsigned less or equal *) - | Sgt (* Signed greater than *) - | Sge (* Signed greater or equal *) - | Slt (* Signed less than *) - | Sle (* Signed less or equal *) + | Eq (** Equal *) + | Ne (** Not equal *) + | Ugt (** Unsigned greater than *) + | Uge (** Unsigned greater or equal *) + | Ult (** Unsigned less than *) + | Ule (** Unsigned less or equal *) + | Sgt (** Signed greater than *) + | Sge (** Signed greater or equal *) + | Slt (** Signed less than *) + | Sle (** Signed less or equal *) end (** The predicate for a floating-point comparison ([fcmp]) instruction. @@ -175,38 +184,38 @@ end See the [llvm::FCmpInst::Predicate] enumeration. *) module Fcmp : sig type t = - | False (* Always false *) - | Oeq (* Ordered and equal *) - | Ogt (* Ordered and greater than *) - | Oge (* Ordered and greater or equal *) - | Olt (* Ordered and less than *) - | Ole (* Ordered and less or equal *) - | One (* Ordered and not equal *) - | Ord (* Ordered (no operand is NaN) *) - | Uno (* Unordered (one operand at least is NaN) *) - | Ueq (* Unordered and equal *) - | Ugt (* Unordered and greater than *) - | Uge (* Unordered and greater or equal *) - | Ult (* Unordered and less than *) - | Ule (* Unordered and less or equal *) - | Une (* Unordered and not equal *) - | True (* Always true *) + | False (** Always false *) + | Oeq (** Ordered and equal *) + | Ogt (** Ordered and greater than *) + | Oge (** Ordered and greater or equal *) + | Olt (** Ordered and less than *) + | Ole (** Ordered and less or equal *) + | One (** Ordered and not equal *) + | Ord (** Ordered (no operand is NaN) *) + | Uno (** Unordered (one operand at least is NaN) *) + | Ueq (** Unordered and equal *) + | Ugt (** Unordered and greater than *) + | Uge (** Unordered and greater or equal *) + | Ult (** Unordered and less than *) + | Ule (** Unordered and less or equal *) + | Une (** Unordered and not equal *) + | True (** Always true *) end (** The opcodes for LLVM instructions and constant expressions. *) module Opcode : sig type t = - | Invalid (* not an instruction *) - (* Terminator Instructions *) - | Ret + | Invalid (** Not an instruction *) + + | Ret (** Terminator Instructions *) | Br | Switch | IndirectBr | Invoke | Invalid2 | Unreachable - (* Standard Binary Operators *) - | Add + + | Add (** Standard Binary Operators *) | FAdd | Sub | FSub @@ -218,20 +227,20 @@ module Opcode : sig | URem | SRem | FRem - (* Logical Operators *) - | Shl + + | Shl (** Logical Operators *) | LShr | AShr | And | Or | Xor - (* Memory Operators *) - | Alloca + + | Alloca (** Memory Operators *) | Load | Store | GetElementPtr - (* Cast Operators *) - | Trunc + + | Trunc (** Cast Operators *) | ZExt | SExt | FPToUI @@ -243,8 +252,8 @@ module Opcode : sig | PtrToInt | IntToPtr | BitCast - (* Other Operators *) - | ICmp + + | ICmp (** Other Operators *) | FCmp | PHI | Call @@ -291,7 +300,7 @@ module AtomicOrdering : sig | NotAtomic | Unordered | Monotonic - | Invalid (* removed due to API changes *) + | Invalid (** removed due to API changes *) | Acquire | Release | AcqiureRelease @@ -381,6 +390,14 @@ val install_fatal_error_handler : (string -> unit) -> unit (** [reset_fatal_error_handler ()] resets LLVM's fatal error handler. *) val reset_fatal_error_handler : unit -> unit +(** [parse_command_line_options ?overview args] parses [args] using + the LLVM command line parser. Note that the only stable thing about this + function is its signature; you cannot rely on any particular set of command + line arguments being interpreted the same way across LLVM versions. + + See the function [llvm::cl::ParseCommandLineOptions()]. *) +val parse_command_line_options : ?overview:string -> string array -> unit + (** {6 Contexts} *) (** [create_context ()] creates a context for storing the "global" state in @@ -651,7 +668,7 @@ val x86_mmx_type : llcontext -> lltype val type_by_name : llmodule -> string -> lltype option -(* {6 Values} *) +(** {6 Values} *) (** [type_of v] returns the type of the value [v]. See the method [llvm::Value::getType]. *) @@ -682,7 +699,7 @@ val string_of_llvalue : llvalue -> string val replace_all_uses_with : llvalue -> llvalue -> unit -(* {6 Uses} *) +(** {6 Uses} *) (** [use_begin v] returns the first position in the use list for the value [v]. [use_begin] and [use_succ] can e used to iterate over the use list in order. @@ -714,12 +731,17 @@ val fold_left_uses : ('a -> lluse -> 'a) -> 'a -> llvalue -> 'a val fold_right_uses : (lluse -> 'a -> 'a) -> llvalue -> 'a -> 'a -(* {6 Users} *) +(** {6 Users} *) (** [operand v i] returns the operand at index [i] for the value [v]. See the method [llvm::User::getOperand]. *) val operand : llvalue -> int -> llvalue +(** [operand_use v i] returns the use of the operand at index [i] for the value [v]. See the + method [llvm::User::getOperandUse]. *) +val operand_use : llvalue -> int -> lluse + + (** [set_operand v i o] sets the operand of the value [v] at the index [i] to the value [o]. See the method [llvm::User::setOperand]. *) @@ -797,6 +819,9 @@ val mdstring : llcontext -> string -> llvalue See the method [llvm::MDNode::get]. *) val mdnode : llcontext -> llvalue array -> llvalue +(** [mdnull c ] returns a null MDNode in context [c]. *) +val mdnull : llcontext -> llvalue + (** [get_mdstring v] returns the MDString. See the method [llvm::MDString::getString] *) val get_mdstring : llvalue -> string option @@ -837,15 +862,19 @@ val const_int_of_string : lltype -> string -> int -> llvalue value [n]. See the method [llvm::ConstantFP::get]. *) val const_float : lltype -> float -> llvalue +(** [float_of_const c] returns the float value of the [c] constant float. + None is returned if this is not an float constant. + See the method [llvm::ConstantFP::getDoubleValue].*) +val float_of_const : llvalue -> float option + (** [const_float_of_string ty s] returns the floating point constant of type [ty] and value [n]. See the method [llvm::ConstantFP::get]. *) val const_float_of_string : lltype -> string -> llvalue - (** {7 Operations on composite constants} *) (** [const_string c s] returns the constant [i8] array with the values of the - characters in the string [s] in the context [c]. The array is not + characters in the string [s] in the context [c]. The array is not null-terminated (but see {!const_stringz}). This value can in turn be used as the initializer for a global variable. See the method [llvm::ConstantArray::get]. *) @@ -887,6 +916,14 @@ val const_packed_struct : llcontext -> llvalue array -> llvalue values [elts]. See the method [llvm::ConstantVector::get]. *) val const_vector : llvalue array -> llvalue +(** [string_of_const c] returns [Some str] if [c] is a string constant, + or [None] if this is not a string constant. *) +val string_of_const : llvalue -> string option + +(** [const_element c] returns a constant for a specified index's element. + See the method ConstantDataSequential::getElementAsConstant. *) +val const_element : llvalue -> int -> llvalue + (** {7 Constant expressions} *) @@ -1234,6 +1271,14 @@ val visibility : llvalue -> Visibility.t [v]. See the method [llvm::GlobalValue::setVisibility]. *) val set_visibility : Visibility.t -> llvalue -> unit +(** [dll_storage_class g] returns the DLL storage class of the global value [g]. + See the method [llvm::GlobalValue::getDLLStorageClass]. *) +val dll_storage_class : llvalue -> DLLStorageClass.t + +(** [set_dll_storage_class v g] sets the DLL storage class of the global value [g] to + [v]. See the method [llvm::GlobalValue::setDLLStorageClass]. *) +val set_dll_storage_class : DLLStorageClass.t -> llvalue -> unit + (** [alignment g] returns the required alignment of the global value [g]. See the method [llvm::GlobalValue::getAlignment]. *) val alignment : llvalue -> int @@ -1687,6 +1732,15 @@ val instr_opcode : llvalue -> Opcode.t instruction [i]. *) val icmp_predicate : llvalue -> Icmp.t option +(** [fcmp_predicate i] returns the [fcmp.t] corresponding to an [fcmp] + instruction [i]. *) +val fcmp_predicate : llvalue -> Fcmp.t option + +(** [inst_clone i] returns a copy of instruction [i], + The instruction has no parent, and no name. + See the method [llvm::Instruction::clone]. *) +val instr_clone : llvalue -> llvalue + (** {7 Operations on call sites} *) @@ -1741,6 +1795,52 @@ val is_volatile : llvalue -> bool [llvm::StoreInst::setVolatile]. *) val set_volatile : bool -> llvalue -> unit +(** {7 Operations on terminators} *) + +(** [is_terminator v] returns true if the instruction [v] is a terminator. *) +val is_terminator : llvalue -> bool + +(** [successor v i] returns the successor at index [i] for the value [v]. + See the method [llvm::TerminatorInst::getSuccessor]. *) +val successor : llvalue -> int -> llbasicblock + +(** [set_successor v i o] sets the successor of the value [v] at the index [i] to + the value [o]. + See the method [llvm::TerminatorInst::setSuccessor]. *) +val set_successor : llvalue -> int -> llbasicblock -> unit + +(** [num_successors v] returns the number of successors for the value [v]. + See the method [llvm::TerminatorInst::getNumSuccessors]. *) +val num_successors : llvalue -> int + +(** [successors v] returns the successors of [v]. *) +val successors : llvalue -> llbasicblock array + +(** [iter_successors f v] applies function f to each successor [v] in order. Tail recursive. *) +val iter_successors : (llbasicblock -> unit) -> llvalue -> unit + +(** [fold_successors f v init] is [f (... (f init vN) ...) v1] where [v1,...,vN] are the successors of [v]. Tail recursive. *) +val fold_successors : (llbasicblock -> 'a -> 'a) -> llvalue -> 'a -> 'a + +(** {7 Operations on branches} *) + +(** [is_conditional v] returns true if the branch instruction [v] is conditional. + See the method [llvm::BranchInst::isConditional]. *) +val is_conditional : llvalue -> bool + +(** [condition v] return the condition of the branch instruction [v]. + See the method [llvm::BranchInst::getCondition]. *) +val condition : llvalue -> llvalue + +(** [set_condition v c] sets the condition of the branch instruction [v] to the value [c]. + See the method [llvm::BranchInst::setCondition]. *) +val set_condition : llvalue -> llvalue -> unit + +(** [get_branch c] returns a description of the branch instruction [c]. *) +val get_branch : llvalue -> + [ `Conditional of llvalue * llbasicblock * llbasicblock + | `Unconditional of llbasicblock ] + option (** {7 Operations on phi nodes} *) @@ -2402,7 +2502,7 @@ module MemoryBuffer : sig path [p]. If the file could not be read, then [IoError msg] is raised. *) val of_file : string -> llmemorybuffer - + (** [of_stdin ()] is the memory buffer containing the contents of standard input. If standard input is empty, then [IoError msg] is raised. *) val of_stdin : unit -> llmemorybuffer @@ -2413,7 +2513,7 @@ module MemoryBuffer : sig (** [as_string mb] is the string containing the contents of memory buffer [mb]. *) val as_string : llmemorybuffer -> string - + (** Disposes of a memory buffer. *) val dispose : llmemorybuffer -> unit end @@ -2425,13 +2525,13 @@ module PassManager : sig (** *) type 'a t type any = [ `Module | `Function ] - + (** [PassManager.create ()] constructs a new whole-module pass pipeline. This type of pipeline is suitable for link-time optimization and whole-module transformations. See the constructor of [llvm::PassManager]. *) val create : unit -> [ `Module ] t - + (** [PassManager.create_function m] constructs a new function-by-function pass pipeline over the module [m]. It does not take ownership of [m]. This type of pipeline is suitable for code generation and JIT compilation @@ -2450,19 +2550,19 @@ module PassManager : sig the module, [false] otherwise. See the [llvm::FunctionPassManager::doInitialization] method. *) val initialize : [ `Function ] t -> bool - + (** [run_function f fpm] executes all of the function passes scheduled in the function pass manager [fpm] over the function [f]. Returns [true] if any of the passes modified [f], [false] otherwise. See the [llvm::FunctionPassManager::run] method. *) val run_function : llvalue -> [ `Function ] t -> bool - + (** [finalize fpm] finalizes all of the function passes scheduled in in the function pass manager [fpm]. Returns [true] if any of the passes modified the module, [false] otherwise. See the [llvm::FunctionPassManager::doFinalization] method. *) val finalize : [ `Function ] t -> bool - + (** Frees the memory of a pass pipeline. For function pipelines, does not free the module. See the destructor of [llvm::BasePassManager]. *) diff --git a/bindings/ocaml/llvm/llvm_ocaml.c b/bindings/ocaml/llvm/llvm_ocaml.c index d5ebdcd3e31a..1fa4d0f32d06 100644 --- a/bindings/ocaml/llvm/llvm_ocaml.c +++ b/bindings/ocaml/llvm/llvm_ocaml.c @@ -15,46 +15,33 @@ |* *| \*===----------------------------------------------------------------------===*/ +#include <assert.h> +#include <stdlib.h> +#include <string.h> #include "llvm-c/Core.h" #include "caml/alloc.h" #include "caml/custom.h" #include "caml/memory.h" #include "caml/fail.h" #include "caml/callback.h" -#include <assert.h> -#include <stdlib.h> -#include <string.h> - - -/* Can't use the recommended caml_named_value mechanism for backwards - compatibility reasons. This is largely equivalent. */ -static value llvm_ioerror_exn; -CAMLprim value llvm_register_core_exns(value IoError) { - llvm_ioerror_exn = Field(IoError, 0); - register_global_root(&llvm_ioerror_exn); +value llvm_string_of_message(char* Message) { + value String = caml_copy_string(Message); + LLVMDisposeMessage(Message); - return Val_unit; + return String; } -static void llvm_raise(value Prototype, char *Message) { +void llvm_raise(value Prototype, char *Message) { CAMLparam1(Prototype); - CAMLlocal1(CamlMessage); - - CamlMessage = copy_string(Message); - LLVMDisposeMessage(Message); - - raise_with_arg(Prototype, CamlMessage); - abort(); /* NOTREACHED */ -#ifdef CAMLnoreturn - CAMLnoreturn; /* Silences warnings, but is missing in some versions. */ -#endif + caml_raise_with_arg(Prototype, llvm_string_of_message(Message)); + CAMLnoreturn; } static value llvm_fatal_error_handler; static void llvm_fatal_error_trampoline(const char *Reason) { - callback(llvm_fatal_error_handler, copy_string(Reason)); + callback(llvm_fatal_error_handler, caml_copy_string(Reason)); } CAMLprim value llvm_install_fatal_error_handler(value Handler) { @@ -75,6 +62,17 @@ CAMLprim value llvm_enable_pretty_stacktrace(value Unit) { return Val_unit; } +CAMLprim value llvm_parse_command_line_options(value Overview, value Args) { + char *COverview; + if (Overview == Val_int(0)) { + COverview = NULL; + } else { + COverview = String_val(Field(Overview, 0)); + } + LLVMParseCommandLineOptions(Wosize_val(Args), (const char* const*) Op_val(Args), COverview); + return Val_unit; +} + static value alloc_variant(int tag, void *Value) { value Iter = alloc_small(1, tag); Field(Iter, 0) = Val_op(Value); @@ -157,7 +155,7 @@ CAMLprim value llvm_dispose_module(LLVMModuleRef M) { /* llmodule -> string */ CAMLprim value llvm_target_triple(LLVMModuleRef M) { - return copy_string(LLVMGetTarget(M)); + return caml_copy_string(LLVMGetTarget(M)); } /* string -> llmodule -> unit */ @@ -168,7 +166,7 @@ CAMLprim value llvm_set_target_triple(value Trip, LLVMModuleRef M) { /* llmodule -> string */ CAMLprim value llvm_data_layout(LLVMModuleRef M) { - return copy_string(LLVMGetDataLayout(M)); + return caml_copy_string(LLVMGetDataLayout(M)); } /* string -> llmodule -> unit */ @@ -186,22 +184,24 @@ CAMLprim value llvm_dump_module(LLVMModuleRef M) { /* string -> llmodule -> unit */ CAMLprim value llvm_print_module(value Filename, LLVMModuleRef M) { char* Message; - if(LLVMPrintModuleToFile(M, String_val(Filename), &Message)) { - llvm_raise(llvm_ioerror_exn, Message); - } + + if(LLVMPrintModuleToFile(M, String_val(Filename), &Message)) + llvm_raise(*caml_named_value("Llvm.IoError"), Message); return Val_unit; } /* llmodule -> string */ CAMLprim value llvm_string_of_llmodule(LLVMModuleRef M) { + CAMLparam0(); + CAMLlocal1(ModuleStr); char* ModuleCStr; - ModuleCStr = LLVMPrintModuleToString(M); - value ModuleStr = caml_copy_string(ModuleCStr); + ModuleCStr = LLVMPrintModuleToString(M); + ModuleStr = caml_copy_string(ModuleCStr); LLVMDisposeMessage(ModuleCStr); - return ModuleStr; + CAMLreturn(ModuleStr); } /* llmodule -> string -> unit */ @@ -234,13 +234,15 @@ CAMLprim value llvm_dump_type(LLVMTypeRef Val) { /* lltype -> string */ CAMLprim value llvm_string_of_lltype(LLVMTypeRef M) { + CAMLparam0(); + CAMLlocal1(TypeStr); char* TypeCStr; - TypeCStr = LLVMPrintTypeToString(M); - value TypeStr = caml_copy_string(TypeCStr); + TypeCStr = LLVMPrintTypeToString(M); + TypeStr = caml_copy_string(TypeCStr); LLVMDisposeMessage(TypeCStr); - return TypeStr; + CAMLreturn(TypeStr); } /*--... Operations on integer types ........................................--*/ @@ -537,7 +539,7 @@ CAMLprim value llvm_classify_value(LLVMValueRef Val) { /* llvalue -> string */ CAMLprim value llvm_value_name(LLVMValueRef Val) { - return copy_string(LLVMGetValueName(Val)); + return caml_copy_string(LLVMGetValueName(Val)); } /* string -> llvalue -> unit */ @@ -554,13 +556,15 @@ CAMLprim value llvm_dump_value(LLVMValueRef Val) { /* llvalue -> string */ CAMLprim value llvm_string_of_llvalue(LLVMValueRef M) { + CAMLparam0(); + CAMLlocal1(ValueStr); char* ValueCStr; - ValueCStr = LLVMPrintValueToString(M); - value ValueStr = caml_copy_string(ValueCStr); + ValueCStr = LLVMPrintValueToString(M); + ValueStr = caml_copy_string(ValueCStr); LLVMDisposeMessage(ValueCStr); - return ValueStr; + CAMLreturn(ValueStr); } /* llvalue -> llvalue -> unit */ @@ -577,6 +581,11 @@ CAMLprim LLVMValueRef llvm_operand(LLVMValueRef V, value I) { return LLVMGetOperand(V, Int_val(I)); } +/* llvalue -> int -> lluse */ +CAMLprim LLVMUseRef llvm_operand_use(LLVMValueRef V, value I) { + return LLVMGetOperandUse(V, Int_val(I)); +} + /* llvalue -> int -> llvalue -> unit */ CAMLprim value llvm_set_operand(LLVMValueRef U, value I, LLVMValueRef V) { LLVMSetOperand(U, Int_val(I), V); @@ -657,6 +666,11 @@ CAMLprim LLVMValueRef llvm_mdnode(LLVMContextRef C, value ElementVals) { Wosize_val(ElementVals)); } +/* llcontext -> llvalue */ +CAMLprim LLVMValueRef llvm_mdnull(LLVMContextRef C) { + return NULL; +} + /* llvalue -> string option */ CAMLprim value llvm_get_mdstring(LLVMValueRef V) { CAMLparam0(); @@ -695,7 +709,7 @@ CAMLprim value llvm_append_namedmd(LLVMModuleRef M, value Name, LLVMValueRef Val /* lltype -> int -> llvalue */ CAMLprim LLVMValueRef llvm_const_int(LLVMTypeRef IntTy, value N) { - return LLVMConstInt(IntTy, (long long) Int_val(N), 1); + return LLVMConstInt(IntTy, (long long) Long_val(N), 1); } /* lltype -> Int64.t -> bool -> llvalue */ @@ -729,6 +743,28 @@ CAMLprim LLVMValueRef llvm_const_float(LLVMTypeRef RealTy, value N) { return LLVMConstReal(RealTy, Double_val(N)); } + +/* llvalue -> float */ +CAMLprim value llvm_float_of_const(LLVMValueRef Const) +{ + CAMLparam0(); + CAMLlocal1(Option); + LLVMBool LosesInfo; + double Result; + + if (LLVMIsAConstantFP(Const)) { + Result = LLVMConstRealGetDouble(Const, &LosesInfo); + if (LosesInfo) + CAMLreturn(Val_int(0)); + + Option = alloc(1, 0); + Field(Option, 0) = caml_copy_double(Result); + CAMLreturn(Option); + } + + CAMLreturn(Val_int(0)); +} + /* lltype -> string -> llvalue */ CAMLprim LLVMValueRef llvm_const_float_of_string(LLVMTypeRef RealTy, value S) { return LLVMConstRealOfStringAndSize(RealTy, String_val(S), @@ -782,6 +818,31 @@ CAMLprim LLVMValueRef llvm_const_vector(value ElementVals) { Wosize_val(ElementVals)); } +/* llvalue -> string option */ +CAMLprim value llvm_string_of_const(LLVMValueRef Const) { + const char *S; + size_t Len; + CAMLparam0(); + CAMLlocal2(Option, Str); + + if(LLVMIsAConstantDataSequential(Const) && LLVMIsConstantString(Const)) { + S = LLVMGetAsString(Const, &Len); + Str = caml_alloc_string(Len); + memcpy(String_val(Str), S, Len); + + Option = alloc(1, 0); + Field(Option, 0) = Str; + CAMLreturn(Option); + } else { + CAMLreturn(Val_int(0)); + } +} + +/* llvalue -> int -> llvalue */ +CAMLprim LLVMValueRef llvm_const_element(LLVMValueRef Const, value N) { + return LLVMGetElementAsConstant(Const, Int_val(N)); +} + /*--... Constant expressions ...............................................--*/ /* Icmp.t -> llvalue -> llvalue -> llvalue */ @@ -881,7 +942,7 @@ CAMLprim value llvm_set_linkage(value Linkage, LLVMValueRef Global) { /* llvalue -> string */ CAMLprim value llvm_section(LLVMValueRef Global) { - return copy_string(LLVMGetSection(Global)); + return caml_copy_string(LLVMGetSection(Global)); } /* string -> llvalue -> unit */ @@ -901,6 +962,17 @@ CAMLprim value llvm_set_visibility(value Viz, LLVMValueRef Global) { return Val_unit; } +/* llvalue -> DLLStorageClass.t */ +CAMLprim value llvm_dll_storage_class(LLVMValueRef Global) { + return Val_int(LLVMGetDLLStorageClass(Global)); +} + +/* DLLStorageClass.t -> llvalue -> unit */ +CAMLprim value llvm_set_dll_storage_class(value Viz, LLVMValueRef Global) { + LLVMSetDLLStorageClass(Global, Int_val(Viz)); + return Val_unit; +} + /* llvalue -> int */ CAMLprim value llvm_alignment(LLVMValueRef Global) { return Val_int(LLVMGetAlignment(Global)); @@ -1151,10 +1223,10 @@ CAMLprim value llvm_gc(LLVMValueRef Fn) { const char *GC; CAMLparam0(); CAMLlocal2(Name, Option); - + if ((GC = LLVMGetGC(Fn))) { - Name = copy_string(GC); - + Name = caml_copy_string(GC); + Option = alloc(1, 0); Field(Option, 0) = Name; CAMLreturn(Option); @@ -1328,6 +1400,25 @@ CAMLprim value llvm_instr_icmp_predicate(LLVMValueRef Val) { CAMLreturn(Val_int(0)); } +/* llvalue -> FCmp.t option */ +CAMLprim value llvm_instr_fcmp_predicate(LLVMValueRef Val) { + CAMLparam0(); + int x = LLVMGetFCmpPredicate(Val); + if (x) { + value Option = alloc(1, 0); + Field(Option, 0) = Val_int(x - LLVMRealPredicateFalse); + CAMLreturn(Option); + } + CAMLreturn(Val_int(0)); +} + +/* llvalue -> llvalue */ +CAMLprim LLVMValueRef llvm_instr_clone(LLVMValueRef Inst) { + if (!LLVMIsAInstruction(Inst)) + failwith("Not an instruction"); + return LLVMInstructionClone(Inst); +} + /*--... Operations on call sites ...........................................--*/ @@ -1386,6 +1477,43 @@ CAMLprim value llvm_set_volatile(value IsVolatile, return Val_unit; } + +/*--.. Operations on terminators ...........................................--*/ + +/* llvalue -> int -> llbasicblock */ +CAMLprim LLVMBasicBlockRef llvm_successor(LLVMValueRef V, value I) { + return LLVMGetSuccessor(V, Int_val(I)); +} + +/* llvalue -> int -> llvalue -> unit */ +CAMLprim value llvm_set_successor(LLVMValueRef U, value I, LLVMBasicBlockRef B) { + LLVMSetSuccessor(U, Int_val(I), B); + return Val_unit; +} + +/* llvalue -> int */ +CAMLprim value llvm_num_successors(LLVMValueRef V) { + return Val_int(LLVMGetNumSuccessors(V)); +} + +/*--.. Operations on branch ................................................--*/ + +/* llvalue -> llvalue */ +CAMLprim LLVMValueRef llvm_condition(LLVMValueRef V) { + return LLVMGetCondition(V); +} + +/* llvalue -> llvalue -> unit */ +CAMLprim value llvm_set_condition(LLVMValueRef B, LLVMValueRef C) { + LLVMSetCondition(B, C); + return Val_unit; +} + +/* llvalue -> bool */ +CAMLprim value llvm_is_conditional(LLVMValueRef V) { + return Val_bool(LLVMIsConditional(V)); +} + /*--... Operations on phi nodes ............................................--*/ /* (llvalue * llbasicblock) -> llvalue -> unit */ @@ -1402,20 +1530,20 @@ CAMLprim value llvm_incoming(LLVMValueRef PhiNode) { unsigned I; CAMLparam0(); CAMLlocal3(Hd, Tl, Tmp); - + /* Build a tuple list of them. */ Tl = Val_int(0); for (I = LLVMCountIncoming(PhiNode); I != 0; ) { Hd = alloc(2, 0); Store_field(Hd, 0, (value) LLVMGetIncomingValue(PhiNode, --I)); Store_field(Hd, 1, (value) LLVMGetIncomingBlock(PhiNode, I)); - + Tmp = alloc(2, 0); Store_field(Tmp, 0, Hd); Store_field(Tmp, 1, Tl); Tl = Tmp; } - + CAMLreturn(Tl); } @@ -1434,15 +1562,13 @@ static void llvm_finalize_builder(value B) { } static struct custom_operations builder_ops = { - (char *) "LLVMIRBuilder", + (char *) "Llvm.llbuilder", llvm_finalize_builder, custom_compare_default, custom_hash_default, custom_serialize_default, - custom_deserialize_default -#ifdef custom_compare_ext_default - , custom_compare_ext_default -#endif + custom_deserialize_default, + custom_compare_ext_default }; static value alloc_builder(LLVMBuilderRef B) { @@ -1472,7 +1598,7 @@ CAMLprim value llvm_position_builder(value Pos, value B) { CAMLprim LLVMBasicBlockRef llvm_insertion_block(value B) { LLVMBasicBlockRef InsertBlock = LLVMGetInsertBlock(Builder_val(B)); if (!InsertBlock) - raise_not_found(); + caml_raise_not_found(); return InsertBlock; } @@ -2048,9 +2174,9 @@ CAMLprim LLVMValueRef llvm_build_fcmp(value Pred, CAMLprim LLVMValueRef llvm_build_phi(value Incoming, value Name, value B) { value Hd, Tl; LLVMValueRef FirstValue, PhiNode; - + assert(Incoming != Val_int(0) && "Empty list passed to Llvm.build_phi!"); - + Hd = Field(Incoming, 0); FirstValue = (LLVMValueRef) Field(Hd, 0); PhiNode = LLVMBuildPhi(Builder_val(B), LLVMTypeOf(FirstValue), @@ -2061,7 +2187,7 @@ CAMLprim LLVMValueRef llvm_build_phi(value Incoming, value Name, value B) { LLVMAddIncoming(PhiNode, (LLVMValueRef*) &Field(Hd, 0), (LLVMBasicBlockRef*) &Field(Hd, 1), 1); } - + return PhiNode; } @@ -2097,7 +2223,7 @@ CAMLprim LLVMValueRef llvm_build_insertelement(LLVMValueRef Vec, LLVMValueRef Element, LLVMValueRef Idx, value Name, value B) { - return LLVMBuildInsertElement(Builder_val(B), Vec, Element, Idx, + return LLVMBuildInsertElement(Builder_val(B), Vec, Element, Idx, String_val(Name)); } @@ -2149,11 +2275,11 @@ CAMLprim value llvm_memorybuffer_of_file(value Path) { CAMLparam1(Path); char *Message; LLVMMemoryBufferRef MemBuf; - + if (LLVMCreateMemoryBufferWithContentsOfFile(String_val(Path), &MemBuf, &Message)) - llvm_raise(llvm_ioerror_exn, Message); - + llvm_raise(*caml_named_value("Llvm.IoError"), Message); + CAMLreturn((value) MemBuf); } @@ -2162,22 +2288,23 @@ CAMLprim value llvm_memorybuffer_of_file(value Path) { CAMLprim LLVMMemoryBufferRef llvm_memorybuffer_of_stdin(value Unit) { char *Message; LLVMMemoryBufferRef MemBuf; - + if (LLVMCreateMemoryBufferWithSTDIN(&MemBuf, &Message)) - llvm_raise(llvm_ioerror_exn, Message); - + llvm_raise(*caml_named_value("Llvm.IoError"), Message); + return MemBuf; } /* ?name:string -> string -> llmemorybuffer */ CAMLprim LLVMMemoryBufferRef llvm_memorybuffer_of_string(value Name, value String) { + LLVMMemoryBufferRef MemBuf; const char *NameCStr; + if(Name == Val_int(0)) NameCStr = ""; else NameCStr = String_val(Field(Name, 0)); - LLVMMemoryBufferRef MemBuf; MemBuf = LLVMCreateMemoryBufferWithMemoryRangeCopy( String_val(String), caml_string_length(String), NameCStr); |