[OCaml] Rework Llvm_executionengine using ctypes.

Since JIT->MCJIT migration, most of the ExecutionEngine interface
became deprecated and/or broken. This especially affected the OCaml
bindings, as runFunction is no longer available, and unlike in C,
it is not possible to coerce a pointer to a function and call it
in OCaml.

In practice, LLVM 3.5 shipped completely unusable
Llvm_executionengine.

The GenericValue interface and runFunction were essentially
a poor man's FFI. As such, this interface was removed and instead
a dependency on ctypes >=0.3 added, which handled platform-specific
aspects of accessing data and calling functions.

The new interface does not expose JIT (which is a shim around MCJIT),
as well as the interpreter (which can't handle a lot of valid IR).

Llvm_executionengine.add_global_mapping is currently unusable
due to PR20656.

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

bindings/ocaml/Makefile.ocaml

@@ -55,7 +55,8 @@ endif
 endif
 
 # Tools
-OCAMLCFLAGS += -I $(OcamlDir)
+OCAMLCFLAGS += -I $(OcamlDir) $(addprefix -package ,$(FindlibPackages))
+
 ifndef IS_CLEANING_TARGET
 ifneq ($(ObjectsO),)
 OCAMLAFLAGS += $(patsubst %,-cclib %, \

bindings/ocaml/executionengine/Makefile

@@ -15,5 +15,6 @@ LEVEL := ../../..
 LIBRARYNAME := llvm_executionengine
 UsedComponents := executionengine mcjit interpreter native
 UsedOcamlInterfaces := llvm llvm_target
+FindlibPackages := ctypes
 
 include ../Makefile.ocaml

bindings/ocaml/executionengine/executionengine_ocaml.c

@@ -27,118 +27,8 @@
 
 void llvm_raise(value Prototype, char *Message);
 
-/*--... Operations on generic values .......................................--*/
-
-#define Genericvalue_val(v)  (*(LLVMGenericValueRef *)(Data_custom_val(v)))
-
-static void llvm_finalize_generic_value(value GenVal) {
-  LLVMDisposeGenericValue(Genericvalue_val(GenVal));
-}
-
-static struct custom_operations generic_value_ops = {
-  (char *) "Llvm_executionengine.GenericValue.t",
-  llvm_finalize_generic_value,
-  custom_compare_default,
-  custom_hash_default,
-  custom_serialize_default,
-  custom_deserialize_default,
-  custom_compare_ext_default
-};
-
-static value alloc_generic_value(LLVMGenericValueRef Ref) {
-  value Val = alloc_custom(&generic_value_ops, sizeof(LLVMGenericValueRef), 0, 1);
-  Genericvalue_val(Val) = Ref;
-  return Val;
-}
-
-/* Llvm.lltype -> float -> t */
-CAMLprim value llvm_genericvalue_of_float(LLVMTypeRef Ty, value N) {
-  CAMLparam1(N);
-  CAMLreturn(alloc_generic_value(
-    LLVMCreateGenericValueOfFloat(Ty, Double_val(N))));
-}
-
-/* 'a -> t */
-CAMLprim value llvm_genericvalue_of_pointer(value V) {
-  CAMLparam1(V);
-  CAMLreturn(alloc_generic_value(LLVMCreateGenericValueOfPointer(Op_val(V))));
-}
-
-/* Llvm.lltype -> int -> t */
-CAMLprim value llvm_genericvalue_of_int(LLVMTypeRef Ty, value Int) {
-  return alloc_generic_value(LLVMCreateGenericValueOfInt(Ty, Int_val(Int), 1));
-}
-
-/* Llvm.lltype -> int32 -> t */
-CAMLprim value llvm_genericvalue_of_int32(LLVMTypeRef Ty, value Int32) {
-  CAMLparam1(Int32);
-  CAMLreturn(alloc_generic_value(
-    LLVMCreateGenericValueOfInt(Ty, Int32_val(Int32), 1)));
-}
-
-/* Llvm.lltype -> nativeint -> t */
-CAMLprim value llvm_genericvalue_of_nativeint(LLVMTypeRef Ty, value NatInt) {
-  CAMLparam1(NatInt);
-  CAMLreturn(alloc_generic_value(
-    LLVMCreateGenericValueOfInt(Ty, Nativeint_val(NatInt), 1)));
-}
-
-/* Llvm.lltype -> int64 -> t */
-CAMLprim value llvm_genericvalue_of_int64(LLVMTypeRef Ty, value Int64) {
-  CAMLparam1(Int64);
-  CAMLreturn(alloc_generic_value(
-    LLVMCreateGenericValueOfInt(Ty, Int64_val(Int64), 1)));
-}
-
-/* Llvm.lltype -> t -> float */
-CAMLprim value llvm_genericvalue_as_float(LLVMTypeRef Ty, value GenVal) {
-  CAMLparam1(GenVal);
-  CAMLreturn(copy_double(
-    LLVMGenericValueToFloat(Ty, Genericvalue_val(GenVal))));
-}
-
-/* t -> 'a */
-CAMLprim value llvm_genericvalue_as_pointer(value GenVal) {
-  return Val_op(LLVMGenericValueToPointer(Genericvalue_val(GenVal)));
-}
-
-/* t -> int */
-CAMLprim value llvm_genericvalue_as_int(value GenVal) {
-  assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 8 * sizeof(value)
-         && "Generic value too wide to treat as an int!");
-  return Val_int(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1));
-}
-
-/* t -> int32 */
-CAMLprim value llvm_genericvalue_as_int32(value GenVal) {
-  CAMLparam1(GenVal);
-  assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 32
-         && "Generic value too wide to treat as an int32!");
-  CAMLreturn(copy_int32(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1)));
-}
-
-/* t -> int64 */
-CAMLprim value llvm_genericvalue_as_int64(value GenVal) {
-  CAMLparam1(GenVal);
-  assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 64
-         && "Generic value too wide to treat as an int64!");
-  CAMLreturn(copy_int64(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1)));
-}
-
-/* t -> nativeint */
-CAMLprim value llvm_genericvalue_as_nativeint(value GenVal) {
-  CAMLparam1(GenVal);
-  assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 8 * sizeof(value)
-         && "Generic value too wide to treat as a nativeint!");
-  CAMLreturn(copy_nativeint(LLVMGenericValueToInt(Genericvalue_val(GenVal),1)));
-}
-
-
-/*--... Operations on execution engines ....................................--*/
-
 /* unit -> bool */
-CAMLprim value llvm_initialize_native_target(value Unit) {
-  LLVMLinkInInterpreter();
+CAMLprim value llvm_ee_initialize(value Unit) {
   LLVMLinkInMCJIT();
 
   return Val_bool(!LLVMInitializeNativeTarget() &&
@@ -146,48 +36,22 @@ CAMLprim value llvm_initialize_native_target(value Unit) {
                   !LLVMInitializeNativeAsmPrinter());
 }
 
-/* llmodule -> ExecutionEngine.t */
-CAMLprim LLVMExecutionEngineRef llvm_ee_create(LLVMModuleRef M) {
-  LLVMExecutionEngineRef Interp;
-  char *Error;
-  if (LLVMCreateExecutionEngineForModule(&Interp, M, &Error))
-    llvm_raise(*caml_named_value("Llvm_executionengine.Error"), Error);
-  return Interp;
-}
-
-/* llmodule -> ExecutionEngine.t */
-CAMLprim LLVMExecutionEngineRef
-llvm_ee_create_interpreter(LLVMModuleRef M) {
-  LLVMExecutionEngineRef Interp;
-  char *Error;
-  if (LLVMCreateInterpreterForModule(&Interp, M, &Error))
-    llvm_raise(*caml_named_value("Llvm_executionengine.Error"), Error);
-  return Interp;
-}
-
-/* llmodule -> int -> ExecutionEngine.t */
-CAMLprim LLVMExecutionEngineRef
-llvm_ee_create_jit(LLVMModuleRef M, value OptLevel) {
-  LLVMExecutionEngineRef JIT;
-  char *Error;
-  if (LLVMCreateJITCompilerForModule(&JIT, M, Int_val(OptLevel), &Error))
-    llvm_raise(*caml_named_value("Llvm_executionengine.Error"), Error);
-  return JIT;
-}
-
 /* llmodule -> llcompileroption -> ExecutionEngine.t */
-CAMLprim LLVMExecutionEngineRef
-llvm_ee_create_mcjit(LLVMModuleRef M, value OptRecord) {
+CAMLprim LLVMExecutionEngineRef llvm_ee_create(value OptRecordOpt, LLVMModuleRef M) {
+  value OptRecord;
   LLVMExecutionEngineRef MCJIT;
   char *Error;
   struct LLVMMCJITCompilerOptions Options;
 
   LLVMInitializeMCJITCompilerOptions(&Options, sizeof(Options));
-  Options.OptLevel = Int_val(Field(OptRecord, 0));
-  Options.CodeModel = Int_val(Field(OptRecord, 1));
-  Options.NoFramePointerElim = Int_val(Field(OptRecord, 2));
-  Options.EnableFastISel = Int_val(Field(OptRecord, 3));
-  Options.MCJMM = NULL;
+  if (OptRecordOpt != Val_int(0)) {
+    OptRecord = Field(OptRecordOpt, 0);
+    Options.OptLevel = Int_val(Field(OptRecord, 0));
+    Options.CodeModel = Int_val(Field(OptRecord, 1));
+    Options.NoFramePointerElim = Int_val(Field(OptRecord, 2));
+    Options.EnableFastISel = Int_val(Field(OptRecord, 3));
+    Options.MCJMM = NULL;
+  }
 
   if (LLVMCreateMCJITCompilerForModule(&MCJIT, M, &Options,
                                       sizeof(Options), &Error))
@@ -208,43 +72,12 @@ CAMLprim value llvm_ee_add_module(LLVMModuleRef M, LLVMExecutionEngineRef EE) {
 }
 
 /* llmodule -> ExecutionEngine.t -> llmodule */
-CAMLprim LLVMModuleRef llvm_ee_remove_module(LLVMModuleRef M,
-                                             LLVMExecutionEngineRef EE) {
+CAMLprim value llvm_ee_remove_module(LLVMModuleRef M, LLVMExecutionEngineRef EE) {
   LLVMModuleRef RemovedModule;
   char *Error;
   if (LLVMRemoveModule(EE, M, &RemovedModule, &Error))
     llvm_raise(*caml_named_value("Llvm_executionengine.Error"), Error);
-  return RemovedModule;
-}
-
-/* string -> ExecutionEngine.t -> llvalue option */
-CAMLprim value llvm_ee_find_function(value Name, LLVMExecutionEngineRef EE) {
-  CAMLparam1(Name);
-  CAMLlocal1(Option);
-  LLVMValueRef Found;
-  if (LLVMFindFunction(EE, String_val(Name), &Found))
-    CAMLreturn(Val_unit);
-  Option = alloc(1, 0);
-  Field(Option, 0) = Val_op(Found);
-  CAMLreturn(Option);
-}
-
-/* llvalue -> GenericValue.t array -> ExecutionEngine.t -> GenericValue.t */
-CAMLprim value llvm_ee_run_function(LLVMValueRef F, value Args,
-                                    LLVMExecutionEngineRef EE) {
-  unsigned NumArgs;
-  LLVMGenericValueRef Result, *GVArgs;
-  unsigned I;
-
-  NumArgs = Wosize_val(Args);
-  GVArgs = (LLVMGenericValueRef*) malloc(NumArgs * sizeof(LLVMGenericValueRef));
-  for (I = 0; I != NumArgs; ++I)
-    GVArgs[I] = Genericvalue_val(Field(Args, I));
-
-  Result = LLVMRunFunction(EE, F, NumArgs, GVArgs);
-
-  free(GVArgs);
-  return alloc_generic_value(Result);
+  return Val_unit;
 }
 
 /* ExecutionEngine.t -> unit */
@@ -259,66 +92,6 @@ CAMLprim value llvm_ee_run_static_dtors(LLVMExecutionEngineRef EE) {
   return Val_unit;
 }
 
-/* llvalue -> string array -> (string * string) array -> ExecutionEngine.t ->
-   int */
-CAMLprim value llvm_ee_run_function_as_main(LLVMValueRef F,
-                                            value Args, value Env,
-                                            LLVMExecutionEngineRef EE) {
-  CAMLparam2(Args, Env);
-  int I, NumArgs, NumEnv, EnvSize, Result;
-  const char **CArgs, **CEnv;
-  char *CEnvBuf, *Pos;
-
-  NumArgs = Wosize_val(Args);
-  NumEnv = Wosize_val(Env);
-
-  /* Build the environment. */
-  CArgs = (const char **) malloc(NumArgs * sizeof(char*));
-  for (I = 0; I != NumArgs; ++I)
-    CArgs[I] = String_val(Field(Args, I));
-
-  /* Compute the size of the environment string buffer. */
-  for (I = 0, EnvSize = 0; I != NumEnv; ++I) {
-    EnvSize += strlen(String_val(Field(Field(Env, I), 0))) + 1;
-    EnvSize += strlen(String_val(Field(Field(Env, I), 1))) + 1;
-  }
-
-  /* Build the environment. */
-  CEnv = (const char **) malloc((NumEnv + 1) * sizeof(char*));
-  CEnvBuf = (char*) malloc(EnvSize);
-  Pos = CEnvBuf;
-  for (I = 0; I != NumEnv; ++I) {
-    char *Name  = String_val(Field(Field(Env, I), 0)),
-         *Value = String_val(Field(Field(Env, I), 1));
-    int NameLen  = strlen(Name),
-        ValueLen = strlen(Value);
-
-    CEnv[I] = Pos;
-    memcpy(Pos, Name, NameLen);
-    Pos += NameLen;
-    *Pos++ = '=';
-    memcpy(Pos, Value, ValueLen);
-    Pos += ValueLen;
-    *Pos++ = '\0';
-  }
-  CEnv[NumEnv] = NULL;
-
-  Result = LLVMRunFunctionAsMain(EE, F, NumArgs, CArgs, CEnv);
-
-  free(CArgs);
-  free(CEnv);
-  free(CEnvBuf);
-
-  CAMLreturn(Val_int(Result));
-}
-
-/* llvalue -> ExecutionEngine.t -> unit */
-CAMLprim value llvm_ee_free_machine_code(LLVMValueRef F,
-                                         LLVMExecutionEngineRef EE) {
-  LLVMFreeMachineCodeForFunction(EE, F);
-  return Val_unit;
-}
-
 extern value llvm_alloc_data_layout(LLVMTargetDataRef TargetData);
 
 /* ExecutionEngine.t -> Llvm_target.DataLayout.t */
@@ -334,3 +107,16 @@ CAMLprim value llvm_ee_get_data_layout(LLVMExecutionEngineRef EE) {
 
   return DataLayout;
 }
+
+/* Llvm.llvalue -> int64 -> llexecutionengine -> unit */
+CAMLprim value llvm_ee_add_global_mapping(LLVMValueRef Global, value Ptr,
+                                          LLVMExecutionEngineRef EE) {
+  LLVMAddGlobalMapping(EE, Global, (void*) (Int64_val(Ptr)));
+  return Val_unit;
+}
+
+/* Llvm.llvalue -> llexecutionengine -> int64 */
+CAMLprim value llvm_ee_get_pointer_to_global(LLVMValueRef Global,
+                                             LLVMExecutionEngineRef EE) {
+  return caml_copy_int64((int64_t) LLVMGetPointerToGlobal(EE, Global));
+}

bindings/ocaml/executionengine/llvm_executionengine.ml

@@ -11,115 +11,50 @@ exception Error of string
 
 let () = Callback.register_exception "Llvm_executionengine.Error" (Error "")
 
-module CodeModel = struct
-  type t =
-  | Default
-  | JIT_default
-  | Small
-  | Kernel
-  | Medium
-  | Large
-end
-
-module GenericValue = struct
-  type t
-
-  external of_float: Llvm.lltype -> float -> t
-    = "llvm_genericvalue_of_float"
-  external of_pointer: 'a -> t
-    = "llvm_genericvalue_of_pointer"
-  external of_int32: Llvm.lltype -> int32 -> t
-    = "llvm_genericvalue_of_int32"
-  external of_int: Llvm.lltype -> int -> t
-    = "llvm_genericvalue_of_int"
-  external of_nativeint: Llvm.lltype -> nativeint -> t
-    = "llvm_genericvalue_of_nativeint"
-  external of_int64: Llvm.lltype -> int64 -> t
-    = "llvm_genericvalue_of_int64"
-
-  external as_float: Llvm.lltype -> t -> float
-    = "llvm_genericvalue_as_float"
-  external as_pointer: t -> 'a
-    = "llvm_genericvalue_as_pointer"
-  external as_int32: t -> int32
-    = "llvm_genericvalue_as_int32"
-  external as_int: t -> int
-    = "llvm_genericvalue_as_int"
-  external as_nativeint: t -> nativeint
-    = "llvm_genericvalue_as_nativeint"
-  external as_int64: t -> int64
-    = "llvm_genericvalue_as_int64"
-end
-
-
-module ExecutionEngine = struct
-  type t
-
-  type compileroptions = {
-    opt_level: int;
-    code_model: CodeModel.t;
-    no_framepointer_elim: bool;
-    enable_fast_isel: bool;
-  }
-
-  let default_compiler_options = {
-    opt_level = 0;
-    code_model = CodeModel.JIT_default;
-    no_framepointer_elim = false;
-    enable_fast_isel = false }
-
-  external create: Llvm.llmodule -> t
-    = "llvm_ee_create"
-  external create_interpreter: Llvm.llmodule -> t
-    = "llvm_ee_create_interpreter"
-  external create_jit: Llvm.llmodule -> int -> t
-    = "llvm_ee_create_jit"
-  external create_mcjit: Llvm.llmodule -> compileroptions -> t
-    = "llvm_ee_create_mcjit"
-  external dispose: t -> unit
-    = "llvm_ee_dispose"
-  external add_module: Llvm.llmodule -> t -> unit
-    = "llvm_ee_add_module"
-  external remove_module: Llvm.llmodule -> t -> Llvm.llmodule
-    = "llvm_ee_remove_module"
-  external find_function: string -> t -> Llvm.llvalue option
-    = "llvm_ee_find_function"
-  external run_function: Llvm.llvalue -> GenericValue.t array -> t ->
-                         GenericValue.t
-    = "llvm_ee_run_function"
-  external run_static_ctors: t -> unit
-    = "llvm_ee_run_static_ctors"
-  external run_static_dtors: t -> unit
-    = "llvm_ee_run_static_dtors"
-  external run_function_as_main: Llvm.llvalue -> string array ->
-                                 (string * string) array -> t -> int
-    = "llvm_ee_run_function_as_main"
-  external free_machine_code: Llvm.llvalue -> t -> unit
-    = "llvm_ee_free_machine_code"
-
-  external data_layout : t -> Llvm_target.DataLayout.t
-    = "llvm_ee_get_data_layout"
-
-  (* The following are not bound. Patches are welcome.
-
-  add_global_mapping: llvalue -> llgenericvalue -> t -> unit
-  clear_all_global_mappings: t -> unit
-  update_global_mapping: llvalue -> llgenericvalue -> t -> unit
-  get_pointer_to_global_if_available: llvalue -> t -> llgenericvalue
-  get_pointer_to_global: llvalue -> t -> llgenericvalue
-  get_pointer_to_function: llvalue -> t -> llgenericvalue
-  get_pointer_to_function_or_stub: llvalue -> t -> llgenericvalue
-  get_global_value_at_address: llgenericvalue -> t -> llvalue option
-  store_value_to_memory: llgenericvalue -> llgenericvalue -> lltype -> unit
-  initialize_memory: llvalue -> llgenericvalue -> t -> unit
-  recompile_and_relink_function: llvalue -> t -> llgenericvalue
-  get_or_emit_global_variable: llvalue -> t -> llgenericvalue
-  disable_lazy_compilation: t -> unit
-  lazy_compilation_enabled: t -> bool
-  install_lazy_function_creator: (string -> llgenericvalue) -> t -> unit
-
-   *)
-end
-
-external initialize_native_target : unit -> bool
-                                  = "llvm_initialize_native_target"
+external initialize : unit -> bool
+  = "llvm_ee_initialize"
+
+type llexecutionengine
+
+type llcompileroptions = {
+  opt_level: int;
+  code_model: Llvm_target.CodeModel.t;
+  no_framepointer_elim: bool;
+  enable_fast_isel: bool;
+}
+
+let default_compiler_options = {
+  opt_level = 0;
+  code_model = Llvm_target.CodeModel.JITDefault;
+  no_framepointer_elim = false;
+  enable_fast_isel = false }
+
+external create : ?options:llcompileroptions -> Llvm.llmodule -> llexecutionengine
+  = "llvm_ee_create"
+external dispose : llexecutionengine -> unit
+  = "llvm_ee_dispose"
+external add_module : Llvm.llmodule -> llexecutionengine -> unit
+  = "llvm_ee_add_module"
+external remove_module : Llvm.llmodule -> llexecutionengine -> unit
+  = "llvm_ee_remove_module"
+external run_static_ctors : llexecutionengine -> unit
+  = "llvm_ee_run_static_ctors"
+external run_static_dtors : llexecutionengine -> unit
+  = "llvm_ee_run_static_dtors"
+external data_layout : llexecutionengine -> Llvm_target.DataLayout.t
+  = "llvm_ee_get_data_layout"
+external add_global_mapping_ : Llvm.llvalue -> int64 -> llexecutionengine -> unit
+  = "llvm_ee_add_global_mapping"
+external get_pointer_to_global_ : Llvm.llvalue -> llexecutionengine -> int64
+  = "llvm_ee_get_pointer_to_global"
+
+let add_global_mapping llval ptr ee =
+  add_global_mapping_ llval (Ctypes.raw_address_of_ptr (Ctypes.to_voidp ptr)) ee
+
+let get_pointer_to_global llval typ ee =
+  Ctypes.coerce (let open Ctypes in ptr void) typ
+                (Ctypes.ptr_of_raw_address (get_pointer_to_global_ llval ee))
+
+(* The following are not bound. Patches are welcome.
+target_machine : llexecutionengine -> Llvm_target.TargetMachine.t
+ *)

bindings/ocaml/executionengine/llvm_executionengine.mli

@@ -14,176 +14,71 @@
 
 exception Error of string
 
-(** The JIT code model. See [llvm::CodeModel::Model]. *)
-module CodeModel : sig
-  type t =
-  | Default
-  | JIT_default
-  | Small
-  | Kernel
-  | Medium
-  | Large
-end
-
-module GenericValue: sig
-  (** [GenericValue.t] is a boxed union type used to portably pass arguments to
-      and receive values from the execution engine. It supports only a limited
-      selection of types; for more complex argument types, it is necessary to
-      generate a stub function by hand or to pass parameters by reference.
-      See the struct [llvm::GenericValue]. *)
-  type t
-
-  (** [of_float fpty n] boxes the float [n] in a float-valued generic value
-      according to the floating point type [fpty]. See the fields
-      [llvm::GenericValue::DoubleVal] and [llvm::GenericValue::FloatVal]. *)
-  val of_float : Llvm.lltype -> float -> t
-
-  (** [of_pointer v] boxes the pointer value [v] in a generic value. See the
-      field [llvm::GenericValue::PointerVal]. *)
-  val of_pointer : 'a -> t
-
-  (** [of_int32 n w] boxes the int32 [i] in a generic value with the bitwidth
-      [w]. See the field [llvm::GenericValue::IntVal]. *)
-  val of_int32 : Llvm.lltype -> int32 -> t
-
-  (** [of_int n w] boxes the int [i] in a generic value with the bitwidth
-      [w]. See the field [llvm::GenericValue::IntVal]. *)
-  val of_int : Llvm.lltype -> int -> t
-
-  (** [of_natint n w] boxes the native int [i] in a generic value with the
-      bitwidth [w]. See the field [llvm::GenericValue::IntVal]. *)
-  val of_nativeint : Llvm.lltype -> nativeint -> t
-
-  (** [of_int64 n w] boxes the int64 [i] in a generic value with the bitwidth
-      [w]. See the field [llvm::GenericValue::IntVal]. *)
-  val of_int64 : Llvm.lltype -> int64 -> t
-
-  (** [as_float fpty gv] unboxes the floating point-valued generic value [gv] of
-      floating point type [fpty]. See the fields [llvm::GenericValue::DoubleVal]
-      and [llvm::GenericValue::FloatVal]. *)
-  val as_float : Llvm.lltype -> t -> float
-
-  (** [as_pointer gv] unboxes the pointer-valued generic value [gv]. See the
-      field [llvm::GenericValue::PointerVal]. *)
-  val as_pointer : t -> 'a
-
-  (** [as_int32 gv] unboxes the integer-valued generic value [gv] as an [int32].
-      Is invalid if [gv] has a bitwidth greater than 32 bits. See the field
-      [llvm::GenericValue::IntVal]. *)
-  val as_int32 : t -> int32
-
-  (** [as_int gv] unboxes the integer-valued generic value [gv] as an [int].
-      Is invalid if [gv] has a bitwidth greater than the host bit width (but the
-      most significant bit may be lost). See the field
-      [llvm::GenericValue::IntVal]. *)
-  val as_int : t -> int
-
-  (** [as_natint gv] unboxes the integer-valued generic value [gv] as a
-      [nativeint]. Is invalid if [gv] has a bitwidth greater than
-      [nativeint]. See the field [llvm::GenericValue::IntVal]. *)
-  val as_nativeint : t -> nativeint
-
-  (** [as_int64 gv] returns the integer-valued generic value [gv] as an [int64].
-      Is invalid if [gv] has a bitwidth greater than [int64]. See the field
-      [llvm::GenericValue::IntVal]. *)
-  val as_int64 : t -> int64
-end
-
-
-module ExecutionEngine: sig
-  (** An execution engine is either a JIT compiler or an interpreter, capable of
-      directly loading an LLVM module and executing its functions without first
-      invoking a static compiler and generating a native executable. *)
-  type t
-
-  (** MCJIT compiler options. See [llvm::TargetOptions]. *)
-  type compileroptions = {
-    opt_level: int;
-    code_model: CodeModel.t;
-    no_framepointer_elim: bool;
-    enable_fast_isel: bool;
-  }
-
-  (** Default MCJIT compiler options:
-      [{ opt_level = 0; code_model = CodeModel.JIT_default;
-         no_framepointer_elim = false; enable_fast_isel = false }] *)
-  val default_compiler_options : compileroptions
-
-  (** [create m] creates a new execution engine, taking ownership of the
-      module [m] if successful. Creates a JIT if possible, else falls back to an
-      interpreter. Raises [Error msg] if an error occurrs. The execution engine
-      is not garbage collected and must be destroyed with [dispose ee].
-      See the function [llvm::EngineBuilder::create]. *)
-  val create : Llvm.llmodule -> t
-
-  (** [create_interpreter m] creates a new interpreter, taking ownership of the
-      module [m] if successful. Raises [Error msg] if an error occurrs. The
-      execution engine is not garbage collected and must be destroyed with
-      [dispose ee].
-      See the function [llvm::EngineBuilder::create]. *)
-  val create_interpreter : Llvm.llmodule -> t
-
-  (** [create_jit m optlevel] creates a new JIT (just-in-time compiler), taking
-      ownership of the module [m] if successful with the desired optimization
-      level [optlevel]. Raises [Error msg] if an error occurrs. The execution
-      engine is not garbage collected and must be destroyed with [dispose ee].
-      See the function [llvm::EngineBuilder::create].
-
-      Deprecated; use {!create_mcjit}. This function is a shim for {!create_mcjit}. *)
-  val create_jit : Llvm.llmodule -> int -> t
-
-  (** [create_jit m optlevel] creates a new JIT (just-in-time compiler), taking
-      ownership of the module [m] if successful with the desired optimization
-      level [optlevel]. Raises [Error msg] if an error occurrs. The execution
-      engine is not garbage collected and must be destroyed with [dispose ee].
-      See the function [llvm::EngineBuilder::create]. *)
-  val create_mcjit : Llvm.llmodule -> compileroptions -> t
-
-  (** [dispose ee] releases the memory used by the execution engine and must be
-      invoked to avoid memory leaks. *)
-  val dispose : t -> unit
-
-  (** [add_module m ee] adds the module [m] to the execution engine [ee]. *)
-  val add_module : Llvm.llmodule -> t -> unit
-
-  (** [remove_module m ee] removes the module [m] from the execution engine
-      [ee], disposing of [m] and the module referenced by [mp]. Raises
-      [Error msg] if an error occurs. *)
-  val remove_module : Llvm.llmodule -> t -> Llvm.llmodule
-
-  (** [find_function n ee] finds the function named [n] defined in any of the
-      modules owned by the execution engine [ee]. Returns [None] if the function
-      is not found and [Some f] otherwise. *)
-  val find_function : string -> t -> Llvm.llvalue option
-
-  (** [run_function f args ee] synchronously executes the function [f] with the
-      arguments [args], which must be compatible with the parameter types. *)
-  val run_function : Llvm.llvalue -> GenericValue.t array -> t ->
-                     GenericValue.t
-
-  (** [run_static_ctors ee] executes the static constructors of each module in
-      the execution engine [ee]. *)
-  val run_static_ctors : t -> unit
-
-  (** [run_static_dtors ee] executes the static destructors of each module in
-      the execution engine [ee]. *)
-  val run_static_dtors : t -> unit
-
-  (** [run_function_as_main f args env ee] executes the function [f] as a main
-      function, passing it [argv] and [argc] according to the string array
-      [args], and [envp] as specified by the array [env]. Returns the integer
-      return value of the function. *)
-  val run_function_as_main : Llvm.llvalue -> string array ->
-                                  (string * string) array -> t -> int
-
-  (** [free_machine_code f ee] releases the memory in the execution engine [ee]
-      used to store the machine code for the function [f]. *)
-  val free_machine_code : Llvm.llvalue -> t -> unit
-
-  (** [data_layout ee] is the data layout of the execution engine [ee]. *)
-  val data_layout : t -> Llvm_target.DataLayout.t
-end
-
-(** [initialize_native_target ()] initializes the native target corresponding
-    to the host. Returns [true] if initialization is {b not} done. *)
-val initialize_native_target : unit -> bool
+(** [initialize ()] initializes the backend corresponding to the host.
+    Returns [true] if initialization is successful; [false] indicates
+    that there is no such backend or it is unable to emit object code
+    via MCJIT. *)
+val initialize : unit -> bool
+
+(** An execution engine is either a JIT compiler or an interpreter, capable of
+    directly loading an LLVM module and executing its functions without first
+    invoking a static compiler and generating a native executable. *)
+type llexecutionengine
+
+(** MCJIT compiler options. See [llvm::TargetOptions]. *)
+type llcompileroptions = {
+  opt_level: int;
+  code_model: Llvm_target.CodeModel.t;
+  no_framepointer_elim: bool;
+  enable_fast_isel: bool;
+}
+
+(** Default MCJIT compiler options:
+    [{ opt_level = 0; code_model = CodeModel.JIT_default;
+       no_framepointer_elim = false; enable_fast_isel = false }] *)
+val default_compiler_options : llcompileroptions
+
+(** [create m optlevel] creates a new MCJIT just-in-time compiler, taking
+    ownership of the module [m] if successful with the desired optimization
+    level [optlevel]. Raises [Error msg] if an error occurrs. The execution
+    engine is not garbage collected and must be destroyed with [dispose ee].
+
+    Run {!initialize} before using this function.
+
+    See the function [llvm::EngineBuilder::create]. *)
+val create : ?options:llcompileroptions -> Llvm.llmodule -> llexecutionengine
+
+(** [dispose ee] releases the memory used by the execution engine and must be
+    invoked to avoid memory leaks. *)
+val dispose : llexecutionengine -> unit
+
+(** [add_module m ee] adds the module [m] to the execution engine [ee]. *)
+val add_module : Llvm.llmodule -> llexecutionengine -> unit
+
+(** [remove_module m ee] removes the module [m] from the execution engine
+    [ee]. Raises [Error msg] if an error occurs. *)
+val remove_module : Llvm.llmodule -> llexecutionengine -> unit
+
+(** [run_static_ctors ee] executes the static constructors of each module in
+    the execution engine [ee]. *)
+val run_static_ctors : llexecutionengine -> unit
+
+(** [run_static_dtors ee] executes the static destructors of each module in
+    the execution engine [ee]. *)
+val run_static_dtors : llexecutionengine -> unit
+
+(** [data_layout ee] is the data layout of the execution engine [ee]. *)
+val data_layout : llexecutionengine -> Llvm_target.DataLayout.t
+
+(** [add_global_mapping gv ptr ee] tells the execution engine [ee] that
+    the global [gv] is at the specified location [ptr], which must outlive
+    [gv] and [ee].
+    All uses of [gv] in the compiled code will refer to [ptr]. *)
+val add_global_mapping : Llvm.llvalue -> 'a Ctypes.ptr -> llexecutionengine -> unit
+
+(** [get_pointer_to_global gv typ ee] returns the value of the global
+    variable [gv] in the execution engine [ee] as type [typ], which may
+    be a pointer type (e.g. [int ptr typ]) for global variables or
+    a function (e.g. [(int -> int) typ]) type for functions, and which
+    will be live as long as [gv] and [ee] are. *)
+val get_pointer_to_global : Llvm.llvalue -> 'a Ctypes.typ -> llexecutionengine -> 'a

bindings/ocaml/llvm/META.llvm.in

@@ -31,7 +31,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"

test/Bindings/Ocaml/executionengine.ml

@@ -19,20 +19,17 @@ let i64_type = Llvm.i64_type context
 let double_type = Llvm.double_type context
 
 let () =
-  assert (Llvm_executionengine.initialize_native_target ())
+  assert (Llvm_executionengine.initialize ())
 
 let bomb msg =
   prerr_endline msg;
   exit 2
 
-let define_main_fn m retval =
-  let fn =
-    let str_arr_type = pointer_type (pointer_type i8_type) in
-    define_function "main" (function_type i32_type [| i32_type;
-                                                      str_arr_type;
-                                                      str_arr_type |]) m in
+let define_getglobal m pg =
+  let fn = define_function "getglobal" (function_type i32_type [||]) m in
   let b = builder_at_end (global_context ()) (entry_block fn) in
-  ignore (build_ret (const_int i32_type retval) b);
+  let g = build_call pg [||] "" b in
+  ignore (build_ret g b);
   fn
 
 let define_plus m =
@@ -40,94 +37,67 @@ let define_plus m =
                                                              i32_type |]) m in
   let b = builder_at_end (global_context ()) (entry_block fn) in
   let add = build_add (param fn 0) (param fn 1) "sum" b in
-  ignore (build_ret add b)
+  ignore (build_ret add b);
+  fn
 
-let test_genericvalue () =
-  let tu = (1, 2) in
-  let ptrgv = GenericValue.of_pointer tu in
-  assert (tu = GenericValue.as_pointer ptrgv);
+let test_executionengine () =
+  let open Ctypes in
 
-  let fpgv = GenericValue.of_float double_type 2. in
-  assert (2. = GenericValue.as_float double_type fpgv);
+  (* create *)
+  let m = create_module (global_context ()) "test_module" in
+  let ee = create m in
 
-  let intgv = GenericValue.of_int i32_type 3 in
-  assert (3  = GenericValue.as_int intgv);
+  (* add plus *)
+  let plus = define_plus m in
 
-  let i32gv = GenericValue.of_int32 i32_type (Int32.of_int 4) in
-  assert ((Int32.of_int 4) = GenericValue.as_int32 i32gv);
+  (* add module *)
+  let m2 = create_module (global_context ()) "test_module2" in
+  add_module m2 ee;
 
-  let nigv = GenericValue.of_nativeint i32_type (Nativeint.of_int 5) in
-  assert ((Nativeint.of_int 5) = GenericValue.as_nativeint nigv);
+  (* add global mapping *)
+  (* BROKEN: see PR20656 *)
+  (* let g = declare_function "g" (function_type i32_type [||]) m2 in
+  let cg = coerce (Foreign.funptr (void @-> returning int32_t)) (ptr void)
+                                  (fun () -> 42l) in
+  add_global_mapping g cg ee;
 
-  let i64gv = GenericValue.of_int64 i64_type (Int64.of_int 6) in
-  assert ((Int64.of_int 6) = GenericValue.as_int64 i64gv)
+  (* check g *)
+  let cg' = get_pointer_to_global g (ptr void) ee in
+  if 0 <> ptr_compare cg cg' then bomb "int pointers to g differ";
 
-let test_executionengine engine =
-  (* create *)
-  let m = create_module (global_context ()) "test_module" in
-  let main = define_main_fn m 42 in
+  (* add getglobal *)
+  let getglobal = define_getglobal m2 g in*)
 
-  let m2 = create_module (global_context ()) "test_module2" in
-  define_plus m2;
+  (* run_static_ctors *)
+  run_static_ctors ee;
 
-  let ee =
-    match engine with
-    | `Interpreter -> ExecutionEngine.create_interpreter m
-    | `JIT -> ExecutionEngine.create_jit m 0
-    | `MCJIT -> ExecutionEngine.create_mcjit m ExecutionEngine.default_compiler_options
-  in
-  ExecutionEngine.add_module m2 ee;
+  (* call plus *)
+  let cplusty = Foreign.funptr (int32_t @-> int32_t @-> returning int32_t) in
+  let cplus   = get_pointer_to_global plus cplusty ee in
+  if 4l <> cplus 2l 2l then bomb "plus didn't work";
 
-  (* run_static_ctors *)
-  ExecutionEngine.run_static_ctors ee;
-
-  (* run_function_as_main *)
-  let res = ExecutionEngine.run_function_as_main main [|"test"|] [||] ee in
-  if 42 != res then bomb "main did not return 42";
-
-  (* free_machine_code *)
-  ExecutionEngine.free_machine_code main ee;
-
-  (* find_function *)
-  match ExecutionEngine.find_function "dne" ee with
-  | Some _ -> raise (Failure "find_function 'dne' failed")
-  | None ->
-
-  match ExecutionEngine.find_function "plus" ee with
-  | None -> raise (Failure "find_function 'plus' failed")
-  | Some plus ->
-
-  begin match engine with
-  | `MCJIT -> () (* Currently can only invoke 0-ary functions *)
-  | `JIT -> () (* JIT is now a shim around MCJIT, jokes on you *)
-  | _ ->
-    (* run_function *)
-    let res = ExecutionEngine.run_function plus
-                                           [| GenericValue.of_int i32_type 2;
-                                              GenericValue.of_int i32_type 2 |]
-                                           ee in
-    if 4 != GenericValue.as_int res then bomb "plus did not work";
-  end;
+  (* call getglobal *)
+  (* let cgetglobalty = Foreign.funptr (void @-> returning int32_t) in
+  let cgetglobal   = get_pointer_to_global getglobal cgetglobalty ee in
+  if 42l <> cgetglobal () then bomb "getglobal didn't work"; *)
 
   (* remove_module *)
-  Llvm.dispose_module (ExecutionEngine.remove_module m2 ee);
+  remove_module m2 ee;
+  dispose_module m2;
 
   (* run_static_dtors *)
-  ExecutionEngine.run_static_dtors ee;
+  run_static_dtors ee;
 
   (* Show that the data layout binding links and runs.*)
-  let dl = ExecutionEngine.data_layout ee in
+  let dl = data_layout ee in
 
   (* Demonstrate that a garbage pointer wasn't returned. *)
   let ty = DataLayout.intptr_type context dl in
   if ty != i32_type && ty != i64_type then bomb "target_data did not work";
 
   (* dispose *)
-  ExecutionEngine.dispose ee
+  dispose ee
 
 let () =
-  test_genericvalue ();
-  test_executionengine `Interpreter;
-  test_executionengine `JIT;
-  test_executionengine `MCJIT;
-  ()
+  test_executionengine ();
+  Gc.compact ()