[OCaml] Add Target and TargetMachine bindings to Llvm_target

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

4 files changed, 516 insertions, 3 deletions

diff --git a/bindings/ocaml/target/llvm_target.ml b/bindings/ocaml/target/llvm_target.ml
index e43caef..974bd49 100644
--- a/bindings/ocaml/target/llvm_target.ml
+++ b/bindings/ocaml/target/llvm_target.ml
@@ -13,6 +13,43 @@ module Endian = struct
   | Little
 end
 
+module CodeGenOptLevel = struct
+  type t =
+  | None
+  | Less
+  | Default
+  | Aggressive
+end
+
+module RelocMode = struct
+  type t =
+  | Default
+  | Static
+  | PIC
+  | DynamicNoPIC
+end
+
+module CodeModel = struct
+  type t =
+  | Default
+  | JITDefault
+  | Small
+  | Kernel
+  | Medium
+  | Large
+end
+
+module CodeGenFileType = struct
+  type t =
+  | AssemblyFile
+  | ObjectFile
+end
+
+exception Error of string
+
+external register_exns : exn -> unit = "llvm_register_target_exns"
+let _ = register_exns (Error "")
+
 module DataLayout = struct
   type t
 
@@ -49,3 +86,53 @@ module DataLayout = struct
                              = "llvm_datalayout_offset_of_element"
 end
 
+module Target = struct
+  type t
+
+  external default_triple : unit -> string = "llvm_target_default_triple"
+  external first : unit -> t option = "llvm_target_first"
+  external succ : t -> t option = "llvm_target_succ"
+  external by_name : string -> t option = "llvm_target_by_name"
+  external by_triple : string -> t = "llvm_target_by_triple"
+  external name : t -> string = "llvm_target_name"
+  external description : t -> string = "llvm_target_description"
+  external has_jit : t -> bool = "llvm_target_has_jit"
+  external has_target_machine : t -> bool = "llvm_target_has_target_machine"
+  external has_asm_backend : t -> bool = "llvm_target_has_asm_backend"
+
+  let all () =
+    let rec step elem lst =
+      match elem with
+      | Some target -> step (succ target) (target :: lst)
+      | None        -> lst
+    in
+    step (first ()) []
+end
+
+module TargetMachine = struct
+  type t
+
+  external create : triple:string -> ?cpu:string -> ?features:string ->
+                    ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t ->
+                    ?code_model:CodeModel.t -> Target.t -> t
+                  = "llvm_create_targetmachine_bytecode"
+                    "llvm_create_targetmachine_native"
+  external target : t -> Target.t
+                  = "llvm_targetmachine_target"
+  external triple : t -> string
+                  = "llvm_targetmachine_triple"
+  external cpu : t -> string
+               = "llvm_targetmachine_cpu"
+  external features : t -> string
+                    = "llvm_targetmachine_features"
+  external data_layout : t -> DataLayout.t
+                       = "llvm_targetmachine_data_layout"
+  external set_verbose_asm : bool -> t -> unit
+                           = "llvm_targetmachine_set_verbose_asm"
+  external emit_to_file : Llvm.llmodule -> CodeGenFileType.t -> string ->
+                          t -> unit
+                        = "llvm_targetmachine_emit_to_file"
+  external emit_to_memory_buffer : Llvm.llmodule -> CodeGenFileType.t ->
+                                   t -> Llvm.llmemorybuffer
+                                 = "llvm_targetmachine_emit_to_memory_buffer"
+end
diff --git a/bindings/ocaml/target/llvm_target.mli b/bindings/ocaml/target/llvm_target.mli
index 168eef5..4f5e717 100644
--- a/bindings/ocaml/target/llvm_target.mli
+++ b/bindings/ocaml/target/llvm_target.mli
@@ -18,6 +18,44 @@ module Endian : sig
   | Little
 end
 
+module CodeGenOptLevel : sig
+  type t =
+  | None
+  | Less
+  | Default
+  | Aggressive
+end
+
+module RelocMode : sig
+  type t =
+  | Default
+  | Static
+  | PIC
+  | DynamicNoPIC
+end
+
+module CodeModel : sig
+  type t =
+  | Default
+  | JITDefault
+  | Small
+  | Kernel
+  | Medium
+  | Large
+end
+
+module CodeGenFileType : sig
+  type t =
+  | AssemblyFile
+  | ObjectFile
+end
+
+(** {6 Exceptions} *)
+
+exception Error of string
+
+(** {6 Data Layout} *)
+
 module DataLayout : sig
   type t
 
@@ -93,3 +131,92 @@ module DataLayout : sig
       See the method [llvm::StructLayout::getElementContainingOffset]. *)
   val offset_of_element : Llvm.lltype -> int -> t -> Int64.t
 end
+
+(** {6 Target} *)
+
+module Target : sig
+  type t
+
+  (** [default_triple ()] returns the default target triple for current
+      platform. *)
+  val default_triple : unit -> string
+
+  (** [first ()] returns the first target in the registered targets
+      list, or [None]. *)
+  val first : unit -> t option
+
+  (** [succ t] returns the next target after [t], or [None]
+      if [t] was the last target. *)
+  val succ : t -> t option
+
+  (** [all ()] returns a list of known targets. *)
+  val all : unit -> t list
+
+  (** [by_name name] returns [Some t] if a target [t] named [name] is
+      registered, or [None] otherwise. *)
+  val by_name : string -> t option
+
+  (** [by_triple triple] returns a target for a triple [triple], or raises
+      [Error] if [triple] does not correspond to a registered target. *)
+  val by_triple : string -> t
+
+  (** Returns the name of a target. See [llvm::Target::getName]. *)
+  val name : t -> string
+
+  (** Returns the description of a target.
+      See [llvm::Target::getDescription]. *)
+  val description : t -> string
+
+  (** Returns [true] if the target has a JIT. *)
+  val has_jit : t -> bool
+
+  (** Returns [true] if the target has a target machine associated. *)
+  val has_target_machine : t -> bool
+
+  (** Returns [true] if the target has an ASM backend (required for
+      emitting output). *)
+  val has_asm_backend : t -> bool
+end
+
+(** {6 Target Machine} *)
+
+module TargetMachine : sig
+  type t
+
+  (** Creates a new target machine.
+      See [llvm::Target::createTargetMachine]. *)
+  val create : triple:string -> ?cpu:string -> ?features:string ->
+               ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t ->
+               ?code_model:CodeModel.t -> Target.t -> t
+
+  (** Returns the Target used in a TargetMachine *)
+  val target : t -> Target.t
+
+  (** Returns the triple used while creating this target machine. See
+      [llvm::TargetMachine::getTriple]. *)
+  val triple : t -> string
+
+  (** Returns the CPU used while creating this target machine. See
+      [llvm::TargetMachine::getCPU]. *)
+  val cpu : t -> string
+
+  (** Returns the feature string used while creating this target machine. See
+      [llvm::TargetMachine::getFeatureString]. *)
+  val features : t -> string
+
+  (** Returns the data layout of this target machine. *)
+  val data_layout : t -> DataLayout.t
+
+  (** Sets the assembly verbosity of this target machine.
+      See [llvm::TargetMachine::setAsmVerbosity]. *)
+  val set_verbose_asm : bool -> t -> unit
+
+  (** Emits assembly or object data for the given module to the given
+      file or raise [Error]. *)
+  val emit_to_file : Llvm.llmodule -> CodeGenFileType.t -> string -> t -> unit
+
+  (** Emits assembly or object data for the given module to a fresh memory
+      buffer or raise [Error]. *)
+  val emit_to_memory_buffer : Llvm.llmodule -> CodeGenFileType.t -> t ->
+                              Llvm.llmemorybuffer
+end
diff --git a/bindings/ocaml/target/target_ocaml.c b/bindings/ocaml/target/target_ocaml.c
index 8bf8e6c..9e8778a 100644
--- a/bindings/ocaml/target/target_ocaml.c
+++ b/bindings/ocaml/target/target_ocaml.c
@@ -16,9 +16,45 @@
 \*===----------------------------------------------------------------------===*/
 
 #include "llvm-c/Target.h"
+#include "llvm-c/TargetMachine.h"
 #include "caml/alloc.h"
+#include "caml/fail.h"
+#include "caml/memory.h"
 #include "caml/custom.h"
 
+/*===---- Exceptions ------------------------------------------------------===*/
+
+static value llvm_target_error_exn;
+
+CAMLprim value llvm_register_target_exns(value Error) {
+  llvm_target_error_exn = Field(Error, 0);
+  register_global_root(&llvm_target_error_exn);
+  return Val_unit;
+}
+
+static 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
+}
+
+static value llvm_string_of_message(char* Message) {
+  value String = caml_copy_string(Message);
+  LLVMDisposeMessage(Message);
+
+  return String;
+}
+
+/*===---- Data Layout -----------------------------------------------------===*/
+
 #define DataLayout_val(v)  (*(LLVMTargetDataRef *)(Data_custom_val(v)))
 
 static void llvm_finalize_data_layout(value DataLayout) {
@@ -38,7 +74,8 @@ static struct custom_operations llvm_data_layout_ops = {
 };
 
 value llvm_alloc_data_layout(LLVMTargetDataRef DataLayout) {
-  value V = alloc_custom(&llvm_data_layout_ops, sizeof(LLVMTargetDataRef), 0, 1);
+  value V = alloc_custom(&llvm_data_layout_ops, sizeof(LLVMTargetDataRef),
+                         0, 1);
   DataLayout_val(V) = DataLayout;
   return V;
 }
@@ -139,3 +176,215 @@ CAMLprim value llvm_datalayout_offset_of_element(LLVMTypeRef Ty, value Index,
   return caml_copy_int64(LLVMOffsetOfElement(DataLayout_val(DL), Ty,
                                              Int_val(Index)));
 }
+
+/*===---- Target ----------------------------------------------------------===*/
+
+static value llvm_target_option(LLVMTargetRef Target) {
+  if(Target != NULL) {
+    value Result = caml_alloc_small(1, 0);
+    Store_field(Result, 0, (value) Target);
+    return Result;
+  }
+
+  return Val_int(0);
+}
+
+/* unit -> string */
+CAMLprim value llvm_target_default_triple(value Unit) {
+  char *TripleCStr = LLVMGetDefaultTargetTriple();
+  value TripleStr = caml_copy_string(TripleCStr);
+  LLVMDisposeMessage(TripleCStr);
+
+  return TripleStr;
+}
+
+/* unit -> Target.t option */
+CAMLprim value llvm_target_first(value Unit) {
+  return llvm_target_option(LLVMGetFirstTarget());
+}
+
+/* Target.t -> Target.t option */
+CAMLprim value llvm_target_succ(LLVMTargetRef Target) {
+  return llvm_target_option(LLVMGetNextTarget(Target));
+}
+
+/* string -> Target.t option */
+CAMLprim value llvm_target_by_name(value Name) {
+  return llvm_target_option(LLVMGetTargetFromName(String_val(Name)));
+}
+
+/* string -> Target.t */
+CAMLprim LLVMTargetRef llvm_target_by_triple(value Triple) {
+  LLVMTargetRef T;
+  char *Error;
+
+  if(LLVMGetTargetFromTriple(String_val(Triple), &T, &Error))
+    llvm_raise(llvm_target_error_exn, Error);
+
+  return T;
+}
+
+/* Target.t -> string */
+CAMLprim value llvm_target_name(LLVMTargetRef Target) {
+  return caml_copy_string(LLVMGetTargetName(Target));
+}
+
+/* Target.t -> string */
+CAMLprim value llvm_target_description(LLVMTargetRef Target) {
+  return caml_copy_string(LLVMGetTargetDescription(Target));
+}
+
+/* Target.t -> bool */
+CAMLprim value llvm_target_has_jit(LLVMTargetRef Target) {
+  return Val_bool(LLVMTargetHasJIT(Target));
+}
+
+/* Target.t -> bool */
+CAMLprim value llvm_target_has_target_machine(LLVMTargetRef Target) {
+  return Val_bool(LLVMTargetHasTargetMachine(Target));
+}
+
+/* Target.t -> bool */
+CAMLprim value llvm_target_has_asm_backend(LLVMTargetRef Target) {
+  return Val_bool(LLVMTargetHasAsmBackend(Target));
+}
+
+/*===---- Target Machine --------------------------------------------------===*/
+
+#define TargetMachine_val(v)  (*(LLVMTargetMachineRef *)(Data_custom_val(v)))
+
+static void llvm_finalize_target_machine(value Machine) {
+  LLVMDisposeTargetMachine(TargetMachine_val(Machine));
+}
+
+static struct custom_operations llvm_target_machine_ops = {
+  (char *) "LLVMTargetMachine",
+  llvm_finalize_target_machine,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+#ifdef custom_compare_ext_default
+  , custom_compare_ext_default
+#endif
+};
+
+static value llvm_alloc_targetmachine(LLVMTargetMachineRef Machine) {
+  value V = alloc_custom(&llvm_target_machine_ops, sizeof(LLVMTargetMachineRef),
+                         0, 1);
+  TargetMachine_val(V) = Machine;
+  return V;
+}
+
+/* triple:string -> ?cpu:string -> ?features:string
+   ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t
+   ?code_model:CodeModel.t -> Target.t -> TargetMachine.t */
+CAMLprim value llvm_create_targetmachine_native(value Triple, value CPU,
+                  value Features, value OptLevel, value RelocMode,
+                  value CodeModel, LLVMTargetRef Target) {
+  LLVMTargetMachineRef Machine;
+  const char *CPUStr = "", *FeaturesStr = "";
+  LLVMCodeGenOptLevel OptLevelEnum = LLVMCodeGenLevelDefault;
+  LLVMRelocMode RelocModeEnum = LLVMRelocDefault;
+  LLVMCodeModel CodeModelEnum = LLVMCodeModelDefault;
+
+  if(CPU != Val_int(0))
+    CPUStr = String_val(Field(CPU, 0));
+  if(Features != Val_int(0))
+    FeaturesStr = String_val(Field(Features, 0));
+  if(OptLevel != Val_int(0))
+    OptLevelEnum = Int_val(Field(OptLevel, 0));
+  if(RelocMode != Val_int(0))
+    RelocModeEnum = Int_val(Field(RelocMode, 0));
+  if(CodeModel != Val_int(0))
+    CodeModelEnum = Int_val(Field(CodeModel, 0));
+
+  Machine = LLVMCreateTargetMachine(Target, String_val(Triple), CPUStr,
+                FeaturesStr, OptLevelEnum, RelocModeEnum, CodeModelEnum);
+
+  return llvm_alloc_targetmachine(Machine);
+}
+
+CAMLprim value llvm_create_targetmachine_bytecode(value *argv, int argn) {
+  return llvm_create_targetmachine_native(argv[0], argv[1], argv[2], argv[3],
+                                    argv[4], argv[5], (LLVMTargetRef) argv[6]);
+}
+
+/* TargetMachine.t -> Target.t */
+CAMLprim LLVMTargetRef llvm_targetmachine_target(value Machine) {
+  return LLVMGetTargetMachineTarget(TargetMachine_val(Machine));
+}
+
+/* TargetMachine.t -> string */
+CAMLprim value llvm_targetmachine_triple(value Machine) {
+  return llvm_string_of_message(LLVMGetTargetMachineTriple(
+                                TargetMachine_val(Machine)));
+}
+
+/* TargetMachine.t -> string */
+CAMLprim value llvm_targetmachine_cpu(value Machine) {
+  return llvm_string_of_message(LLVMGetTargetMachineCPU(
+                                TargetMachine_val(Machine)));
+}
+
+/* TargetMachine.t -> string */
+CAMLprim value llvm_targetmachine_features(value Machine) {
+  return llvm_string_of_message(LLVMGetTargetMachineFeatureString(
+                                TargetMachine_val(Machine)));
+}
+
+/* TargetMachine.t -> DataLayout.t */
+CAMLprim value llvm_targetmachine_data_layout(value Machine) {
+  CAMLparam1(Machine);
+  CAMLlocal1(DataLayout);
+
+  /* LLVMGetTargetMachineData returns a pointer owned by the TargetMachine,
+     so it is impossible to wrap it with llvm_alloc_target_data, which assumes
+     that OCaml owns the pointer. */
+  LLVMTargetDataRef OrigDataLayout;
+  OrigDataLayout = LLVMGetTargetMachineData(TargetMachine_val(Machine));
+
+  char* TargetDataCStr;
+  TargetDataCStr = LLVMCopyStringRepOfTargetData(OrigDataLayout);
+  DataLayout = llvm_alloc_data_layout(LLVMCreateTargetData(TargetDataCStr));
+  LLVMDisposeMessage(TargetDataCStr);
+
+  CAMLreturn(DataLayout);
+}
+
+/* TargetMachine.t -> bool -> unit */
+CAMLprim value llvm_targetmachine_set_verbose_asm(value Machine, value Verb) {
+  LLVMSetTargetMachineAsmVerbosity(TargetMachine_val(Machine), Bool_val(Verb));
+  return Val_unit;
+}
+
+/* Llvm.llmodule -> CodeGenFileType.t -> string -> TargetMachine.t -> unit */
+CAMLprim value llvm_targetmachine_emit_to_file(LLVMModuleRef Module,
+                            value FileType, value FileName, value Machine) {
+  char* ErrorMessage;
+
+  if(LLVMTargetMachineEmitToFile(TargetMachine_val(Machine), Module,
+                                 String_val(FileName), Int_val(FileType),
+                                 &ErrorMessage)) {
+    llvm_raise(llvm_target_error_exn, ErrorMessage);
+  }
+
+  return Val_unit;
+}
+
+/* Llvm.llmodule -> CodeGenFileType.t -> TargetMachine.t ->
+   Llvm.llmemorybuffer */
+CAMLprim LLVMMemoryBufferRef llvm_targetmachine_emit_to_memory_buffer(
+                                LLVMModuleRef Module, value FileType,
+                                value Machine) {
+  char* ErrorMessage;
+  LLVMMemoryBufferRef Buffer;
+
+  if(LLVMTargetMachineEmitToMemoryBuffer(TargetMachine_val(Machine), Module,
+                                         Int_val(FileType), &ErrorMessage,
+                                         &Buffer)) {
+    llvm_raise(llvm_target_error_exn, ErrorMessage);
+  }
+
+  return Buffer;
+}
diff --git a/test/Bindings/Ocaml/target.ml b/test/Bindings/Ocaml/target.ml
index 65c696b..990714c 100644
--- a/test/Bindings/Ocaml/target.ml
+++ b/test/Bindings/Ocaml/target.ml
@@ -1,7 +1,7 @@
 (* RUN: rm -rf %t.builddir
  * RUN: mkdir -p %t.builddir
  * RUN: cp %s %t.builddir
- * RUN: %ocamlopt -g -warn-error A llvm.cmxa llvm_target.cmxa %t.builddir/target.ml -o %t
+ * RUN: %ocamlopt -g -warn-error A llvm.cmxa llvm_target.cmxa llvm_X86.cmxa %t.builddir/target.ml -o %t
  * RUN: %t %t.bc
  * XFAIL: vg_leak
  *)
@@ -13,6 +13,7 @@
 open Llvm
 open Llvm_target
 
+let _ = Llvm_X86.initialize ()
 
 let context = global_context ()
 let i32_type = Llvm.i32_type context
@@ -33,8 +34,15 @@ let assert_equal a b =
 let filename = Sys.argv.(1)
 let m = create_module context filename
 
+let target =
+  match Target.by_name "x86" with
+  | Some t -> t
+  | None -> failwith "need a target"
 
-(*===-- Target Data -------------------------------------------------------===*)
+let machine =
+  TargetMachine.create ~triple:"i686-linux-gnu" ~cpu:"core2" target
+
+(*===-- Data Layout -------------------------------------------------------===*)
 
 let test_target_data () =
   let module DL = DataLayout in
@@ -63,8 +71,50 @@ let test_target_data () =
   ignore (DL.add_to_pass_manager pm dl)
 
 
+(*===-- Target ------------------------------------------------------------===*)
+
+let test_target () =
+  let module T = Target in
+  ignore (T.succ target);
+  assert_equal (T.name target) "x86";
+  assert_equal (T.description target) "32-bit X86: Pentium-Pro and above";
+  assert_equal (T.has_jit target) true;
+  assert_equal (T.has_target_machine target) true;
+  assert_equal (T.has_asm_backend target) true
+
+
+(*===-- Target Machine ----------------------------------------------------===*)
+
+let test_target_machine () =
+  let module TM = TargetMachine in
+  assert_equal (TM.target machine) target;
+  assert_equal (TM.triple machine) "i686-linux-gnu";
+  assert_equal (TM.cpu machine) "core2";
+  assert_equal (TM.features machine) "";
+  ignore (TM.data_layout machine)
+
+
+(*===-- Code Emission -----------------------------------------------------===*)
+
+let test_code_emission () =
+  TargetMachine.emit_to_file m CodeGenFileType.ObjectFile filename machine;
+  try
+    TargetMachine.emit_to_file m CodeGenFileType.ObjectFile
+                               "/nonexistent/file" machine;
+    failwith "must raise"
+  with Llvm_target.Error _ ->
+    ();
+
+  let buf = TargetMachine.emit_to_memory_buffer m CodeGenFileType.ObjectFile
+                                                machine in
+  Llvm.MemoryBuffer.dispose buf
+
+
 (*===-- Driver ------------------------------------------------------------===*)
 
 let _ =
   test_target_data ();
+  test_target ();
+  test_target_machine ();
+  (* test_code_emission (); *) (* broken without AsmParser support *)
   dispose_module m