[OCaml] Expose Llvm.parse_command_line_options.

[oota-llvm.git] / bindings / ocaml / llvm / llvm.ml

diff --git a/bindings/ocaml/llvm/llvm.ml b/bindings/ocaml/llvm/llvm.ml
index d36f360bf65f932bb669db74614f3b1a611141de..567fa2fc9d906669ec0ecff277d07b8a9fc0834d 100644 (file)
--- 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
  *
@@ -16,6 +16,7 @@ type lluse
 type llbasicblock
 type llbuilder
 type llmemorybuffer
+type llmdkind
 
 module TypeKind = struct
   type t =
@@ -277,8 +278,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"
@@ -286,6 +286,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
@@ -299,7 +301,7 @@ type ('a, 'b) llrev_pos =
 external create_context : unit -> llcontext = "llvm_create_context"
 external dispose_context : llcontext -> unit = "llvm_dispose_context"
 external global_context : unit -> llcontext = "llvm_global_context"
-external mdkind_id : llcontext -> string -> int = "llvm_mdkind_id"
+external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
 
 (*===-- Modules -----------------------------------------------------------===*)
 external create_module : llcontext -> string -> llmodule = "llvm_create_module"
@@ -427,6 +429,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"
 
@@ -442,9 +445,9 @@ external constexpr_opcode : llvalue -> Opcode.t = "llvm_constexpr_get_opcode"
 
 (*--... Operations on instructions .........................................--*)
 external has_metadata : llvalue -> bool = "llvm_has_metadata"
-external metadata : llvalue -> int -> llvalue option = "llvm_metadata"
-external set_metadata : llvalue -> int -> llvalue -> unit = "llvm_set_metadata"
-external clear_metadata : llvalue -> int -> unit = "llvm_clear_metadata"
+external metadata : llvalue -> llmdkind -> llvalue option = "llvm_metadata"
+external set_metadata : llvalue -> llmdkind -> llvalue -> unit = "llvm_set_metadata"
+external clear_metadata : llvalue -> llmdkind -> unit = "llvm_clear_metadata"
 
 (*--... Operations on metadata .......,.....................................--*)
 external mdstring : llcontext -> string -> llvalue = "llvm_mdstring"
@@ -464,6 +467,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"
 
@@ -478,6 +483,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"
@@ -951,6 +958,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
@@ -1018,6 +1027,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"