Fix OCaml bindings crash, PR8847.

See http://caml.inria.fr/mantis/view.php?id=4166
If we call only external functions from a module, then its 'let _' bindings
don't get executed, which means that the exceptions don't get registered for use
in the C code.
This in turn causes llvm_raise to call raise_with_arg() with a NULL pointer and
cause a segmentation fault.

The workaround is to declare all 'external' functions as 'val' in these .mli
files.

Also added a separate testcase (the testcase must call only external functions
for the bug to occur).


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

bindings/ocaml/bitreader/llvm_bitreader.mli

@@ -18,12 +18,12 @@ exception Error of string
     memory buffer [mb] in the context [context].  Returns [m] if successful, or
     raises [Error msg] otherwise, where [msg] is a description of the error
     encountered. See the function [llvm::getBitcodeModule]. *)
-external get_module : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
+val get_module : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
-                    = "llvm_get_module"
+
 
 (** [parse_bitcode context mb] parses the bitcode for a new module [m] from the
     memory buffer [mb] in the context [context]. Returns [m] if successful, or
 	 	raises [Error msg] otherwise, where [msg] is a description of the error
 	 	encountered. See the function [llvm::ParseBitcodeFile]. *)
-external parse_bitcode : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
+val parse_bitcode : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
-                       = "llvm_parse_bitcode"
+

bindings/ocaml/executionengine/llvm_executionengine.mli

@@ -25,58 +25,58 @@ module GenericValue: sig
   (** [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]. *)
-  external of_float : Llvm.lltype -> float -> t = "llvm_genericvalue_of_float"
+  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]. *)
-  external of_pointer : 'a -> t = "llvm_genericvalue_of_pointer"
+  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]. *)
-  external of_int32 : Llvm.lltype -> int32 -> t = "llvm_genericvalue_of_int32"
+  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]. *)
-  external of_int : Llvm.lltype -> int -> t = "llvm_genericvalue_of_int"
+  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]. *)
-  external of_nativeint : Llvm.lltype -> nativeint -> t
+  val of_nativeint : Llvm.lltype -> nativeint -> t
-                        = "llvm_genericvalue_of_nativeint"
+
 
   (** [of_int64 n w] boxes the int64 [i] in a generic value with the bitwidth
       [w]. See the field [llvm::GenericValue::IntVal]. *)
-  external of_int64 : Llvm.lltype -> int64 -> t = "llvm_genericvalue_of_int64"
+  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]. *)
-  external as_float : Llvm.lltype -> t -> float = "llvm_genericvalue_as_float"
+  val as_float : Llvm.lltype -> t -> float
   
   (** [as_pointer gv] unboxes the pointer-valued generic value [gv]. See the
       field [llvm::GenericValue::PointerVal]. *)
-  external as_pointer : t -> 'a = "llvm_genericvalue_as_pointer"
+  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]. *)
-  external as_int32 : t -> int32 = "llvm_genericvalue_as_int32"
+  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]. *)
-  external as_int : t -> int = "llvm_genericvalue_as_int"
+  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]. *)
-  external as_nativeint : t -> nativeint = "llvm_genericvalue_as_nativeint"
+  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]. *)
-  external as_int64 : t -> int64 = "llvm_genericvalue_as_int64"
+  val as_int64 : t -> int64
 end
 
 
@@ -91,73 +91,73 @@ module ExecutionEngine: sig
       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]. *)
-  external create : Llvm.llmodule -> t = "llvm_ee_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]. *)
-  external create_interpreter : Llvm.llmodule -> t = "llvm_ee_create_interpreter"
+  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]. *)
-  external create_jit : Llvm.llmodule -> int -> t = "llvm_ee_create_jit"
+  val create_jit : Llvm.llmodule -> int -> t
 
   (** [dispose ee] releases the memory used by the execution engine and must be
       invoked to avoid memory leaks. *)
-  external dispose : t -> unit = "llvm_ee_dispose"
+  val dispose : t -> unit
   
   (** [add_module m ee] adds the module [m] to the execution engine [ee]. *)
-  external add_module : Llvm.llmodule -> t -> unit = "llvm_ee_add_module"
+  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. *)
-  external remove_module : Llvm.llmodule -> t -> Llvm.llmodule
+  val remove_module : Llvm.llmodule -> t -> Llvm.llmodule
-                         = "llvm_ee_remove_module"
+
   
   (** [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. *)
-  external find_function : string -> t -> Llvm.llvalue option
+  val find_function : string -> t -> Llvm.llvalue option
-                         = "llvm_ee_find_function"
+
   
   (** [run_function f args ee] synchronously executes the function [f] with the
       arguments [args], which must be compatible with the parameter types. *)
-  external run_function : Llvm.llvalue -> GenericValue.t array -> t ->
+  val run_function : Llvm.llvalue -> GenericValue.t array -> t ->
                      GenericValue.t
-                   = "llvm_ee_run_function"
+
   
   (** [run_static_ctors ee] executes the static constructors of each module in
       the execution engine [ee]. *)
-  external run_static_ctors : t -> unit = "llvm_ee_run_static_ctors"
+  val run_static_ctors : t -> unit
   
   (** [run_static_dtors ee] executes the static destructors of each module in
       the execution engine [ee]. *)
-  external run_static_dtors : t -> unit = "llvm_ee_run_static_dtors"
+  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. *)
-  external run_function_as_main : Llvm.llvalue -> string array ->
+  val run_function_as_main : Llvm.llvalue -> string array ->
                                   (string * string) array -> t -> int
-                                = "llvm_ee_run_function_as_main"
+
   
   (** [free_machine_code f ee] releases the memory in the execution engine [ee]
       used to store the machine code for the function [f]. *)
-  external free_machine_code : Llvm.llvalue -> t -> unit
+  val free_machine_code : Llvm.llvalue -> t -> unit
-                             = "llvm_ee_free_machine_code"
+
 
   (** [target_data ee] is the target data owned by the execution engine
       [ee]. *)
-  external target_data : t -> Llvm_target.TargetData.t
+  val target_data : t -> Llvm_target.TargetData.t
-                       = "LLVMGetExecutionEngineTargetData"
+
 end
 
-external initialize_native_target : unit -> bool
+val initialize_native_target : unit -> bool
-                                  = "llvm_initialize_native_target"
+

test/Bindings/Ocaml/ext_exc.ml

@@ -0,0 +1,16 @@
+(* RUN: %ocamlopt -warn-error A llvm.cmxa llvm_bitreader.cmxa llvm_executionengine.cmxa %s -o %t
+ * RUN: %t </dev/null
+ *)
+let context = Llvm.global_context ()
+(* this used to crash, we must not use 'external' in .mli files, but 'val' if we
+ * want the let _ bindings executed, see http://caml.inria.fr/mantis/view.php?id=4166 *)
+let _ =
+    try
+        ignore (Llvm_bitreader.get_module context (Llvm.MemoryBuffer.of_stdin ()))
+    with
+    Llvm_bitreader.Error _ -> ();;
+let _ =
+    try
+        ignore (Llvm.MemoryBuffer.of_file "/path/to/nonexistent/file")
+    with
+    Llvm.IoError _ -> ();;