Registration of C threads from callbacks

.depend

@@ -231,11 +231,15 @@ _build/src/ctypes-top/ctypes_printers.cmx : _build/src/ctypes/unsigned.cmx \
 _build/src/ctypes-foreign-threaded/foreign.cmi : \
     _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/dl.cmi \
     _build/src/ctypes/ctypes.cmi
+_build/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.cmo :
+_build/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.cmx :
 _build/src/ctypes-foreign-threaded/foreign.cmo : \
+    _build/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.cmo \
     _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmo \
     _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi \
     _build/src/ctypes-foreign-threaded/foreign.cmi
 _build/src/ctypes-foreign-threaded/foreign.cmx : \
+    _build/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.cmx \
     _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmx \
     _build/src/ctypes-foreign-base/ctypes_closure_properties.cmx \
     _build/src/ctypes-foreign-threaded/foreign.cmi

Makefile

@@ -1,7 +1,7 @@
 .SECONDEXPANSION:
 
 BEST:=$(shell if ocamlopt > /dev/null 2>&1; then echo native; else echo byte; fi)
-DEBUG=false
+DEBUG=true
 COVERAGE=false
 OCAML=ocaml
 OCAMLFIND=ocamlfind

src/ctypes-foreign-base/ctypes_ffi.ml

@@ -174,6 +174,7 @@ struct
   let build_function ?name ~abi ~release_runtime_lock ~check_errno fn =
     let c = Ctypes_ffi_stubs.allocate_callspec ~check_errno
       ~runtime_lock:release_runtime_lock
+      ~thread_registration:false
     in
     let e = build_ccallspec ~abi ~check_errno fn c in
     invoke name e [] c
@@ -185,10 +186,11 @@ struct
     let f = build_function ?name ~abi ~check_errno ~release_runtime_lock fn in
     fun (Static_funptr p) -> f p
 
-  let pointer_of_function ~abi ~acquire_runtime_lock fn =
+  let pointer_of_function ~abi ~acquire_runtime_lock ~thread_registration fn =
     let cs' = Ctypes_ffi_stubs.allocate_callspec
       ~check_errno:false
       ~runtime_lock:acquire_runtime_lock
+      ~thread_registration
     in
     let cs = box_function abi fn cs' in
     fun f ->

src/ctypes-foreign-base/ctypes_ffi.mli

@@ -30,8 +30,9 @@ sig
   (** Build an OCaml function from a type specification and a pointer to a C
       function. *)
 
-  val pointer_of_function : abi:abi -> acquire_runtime_lock:bool -> ('a -> 'b) fn ->
-    ('a -> 'b) -> ('a -> 'b) static_funptr
+  val pointer_of_function : abi:abi -> acquire_runtime_lock:bool ->
+    thread_registration:bool ->
+    ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) static_funptr
   (** Build an C function from a type specification and an OCaml function.
 
       The C function pointer returned is callable as long as the OCaml function

src/ctypes-foreign-base/ctypes_ffi_stubs.ml

@@ -41,7 +41,8 @@ external ffi_type_of_struct_type : struct_ffitype -> _ ffitype
 type callspec
 
 (* Allocate a new C call specification *)
-external allocate_callspec : check_errno:bool -> runtime_lock:bool -> callspec
+external allocate_callspec : check_errno:bool -> runtime_lock:bool ->
+  thread_registration:bool -> callspec
   = "ctypes_allocate_callspec"
 
 (* Add an argument to the C buffer specification *)

src/ctypes-foreign-base/ctypes_foreign_basis.ml

@@ -15,17 +15,17 @@ struct
   exception CallToExpiredClosure = Ctypes_ffi_stubs.CallToExpiredClosure
 
   let funptr ?(abi=Libffi_abi.default_abi) ?name ?(check_errno=false)
-      ?(runtime_lock=false) fn =
+      ?(runtime_lock=false) ?(thread_registration=false) fn =
     let open Ffi in
     let read = function_of_pointer
       ~abi ~check_errno ~release_runtime_lock:runtime_lock ?name fn
-    and write = pointer_of_function
-      ~abi ~acquire_runtime_lock:runtime_lock fn in
+    and write = pointer_of_function fn
+      ~abi ~acquire_runtime_lock:runtime_lock ~thread_registration in
     Ctypes_static.(view ~read ~write (static_funptr fn))
 
-  let funptr_opt ?abi ?name ?check_errno ?runtime_lock fn =
+  let funptr_opt ?abi ?name ?check_errno ?runtime_lock ?thread_registration fn =
     Ctypes_std_views.nullable_funptr_view
-      (funptr ?abi ?name ?check_errno ?runtime_lock fn) fn
+      (funptr ?abi ?name ?check_errno ?runtime_lock ?thread_registration fn) fn
 
   let funptr_of_raw_ptr p = 
     Ctypes.funptr_of_raw_address (Ctypes_ptr.Raw.to_nativeint p)

src/ctypes-foreign-base/ffi_call_stubs.c

@@ -28,6 +28,18 @@
 /* TODO: support callbacks that raise exceptions?  e.g. using
    caml_callback_exn etc.  */
 
+/* Register a C thread with the OCaml runtime.  By default this simply
+   fails.  The ctypes.foreign.threaded subpackage overrides it to call
+   [caml_c_thread_register].
+ */
+static int ctypes_thread_register_fail(void)
+{
+  caml_failwith("ctypes_thread_register unavailable: "
+		"please link with the threads library");
+}
+int (*ctypes_thread_register)(void) = ctypes_thread_register_fail;
+
+
 /* An OCaml function that converts resolves identifiers to OCaml functions */
 static value retrieve_closure_;
 
@@ -128,8 +140,9 @@ static struct callspec {
   /* The context in which the call should run: whether errno is
      checked, whether the runtime lock is released, and so on. */
   struct call_context {
-    int check_errno;
-    int runtime_lock;
+    int check_errno:1;
+    int runtime_lock:1;
+    int thread_registration:1;
   } context;
 
   /* The libffi call interface structure.  It would be nice for this member to
@@ -206,11 +219,13 @@ static void populate_arg_array(struct callspec *callspec,
 
 /* Allocate a new C call specification */
 /* allocate_callspec : check_errno:bool -> runtime_lock:bool -> callspec */
-value ctypes_allocate_callspec(value check_errno, value runtime_lock)
+value ctypes_allocate_callspec(value check_errno, value runtime_lock,
+                               value thread_registration)
 {
   struct call_context context = {
     Int_val(check_errno),
     Int_val(runtime_lock),
+    Int_val(thread_registration),
   };
 
   value block = caml_alloc_custom(&callspec_custom_ops,
@@ -489,6 +504,11 @@ static void callback_handler(ffi_cif *cif,
 {
   closure *closure = user_data;
 
+  if (closure->context.thread_registration)
+  {
+    ctypes_thread_register();
+  }
+
   if (closure->context.runtime_lock)
   {
     caml_acquire_runtime_system();

src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.ml

@@ -0,0 +1,9 @@
+(*
+ * Copyright (c) 2016 Jeremy Yallop.
+ *
+ * This file is distributed under the terms of the MIT License.
+ * See the file LICENSE for details.
+ *)
+
+external setup_thread_registration : unit -> unit
+  = "ctypes_setup_thread_registration"

src/ctypes-foreign-threaded/foreign.ml

@@ -6,3 +6,10 @@
  *)
 
 include Ctypes_foreign_basis.Make(Ctypes_closure_properties.Make(Mutex))
+
+let () = begin
+  (* Initialize the Thread library and set up the hook for registering C
+     threads with the OCaml runtime *)
+  let (_ : Thread.t) = Thread.self () in
+  Ctypes_foreign_threaded_stubs.setup_thread_registration ()
+end

src/ctypes-foreign-threaded/foreign.mli

@@ -51,6 +51,7 @@ val funptr :
   ?name:string ->
   ?check_errno:bool ->
   ?runtime_lock:bool ->
+  ?thread_registration:bool ->
   ('a -> 'b) Ctypes.fn ->
   ('a -> 'b) Ctypes.typ
 (** Construct a function pointer type from a function type.
@@ -81,6 +82,7 @@ val funptr_opt :
   ?name:string ->
   ?check_errno:bool ->
   ?runtime_lock:bool ->
+  ?thread_registration:bool ->
   ('a -> 'b) Ctypes.fn ->
   ('a -> 'b) option Ctypes.typ
 (** Construct a function pointer type from a function type.

src/ctypes-foreign-threaded/foreign_threaded_stubs.c

@@ -0,0 +1,56 @@
+/*
+ * Copyright (c) 2016 Jeremy Yallop.
+ *
+ * This file is distributed under the terms of the MIT License.
+ * See the file LICENSE for details.
+ */
+
+#include <caml/mlvalues.h>
+#include <caml/threads.h>
+
+#ifdef _WIN32
+value ctypes_setup_thread_registration(value _)
+{
+  /* Don't override the hook on systems without pthreads. */
+  return Val_unit;
+}
+#else
+#include <pthread.h>
+
+extern int (*ctypes_thread_register)(void);
+
+static pthread_key_t cleanup_key;
+
+static void ctypes_thread_unregister(void* _)
+{
+  caml_c_thread_unregister();
+  pthread_setspecific(cleanup_key, NULL);
+}
+
+static int ctypes_thread_actually_register(void)
+{
+  int rv = caml_c_thread_register();
+
+  if (rv != 0) {
+    /* Register a destructor function for a TLS key that unregisters
+       this thread from the OCaml runtime when the thread exits. */
+
+    /* Assumption: caml_c_thread_unregister is not called in this
+       thread, except by the destructor, so caml_c_thread_register()
+       will always succeed.  Consequently, there is no need to protect
+       the TLS-creation code with pthread_once.  (And at worst, if the
+       assumption is violated then caml_c_thread_unregister will be
+       called multiple times, which is harmless.) */ 
+    pthread_key_create(&cleanup_key, ctypes_thread_unregister);
+    pthread_setspecific(cleanup_key, &cleanup_key);
+  }
+
+  return rv;
+}
+
+value ctypes_setup_thread_registration(value _)
+{
+  ctypes_thread_register = ctypes_thread_actually_register;
+  return Val_unit;
+}
+#endif

src/ctypes-foreign-unthreaded/foreign.mli

@@ -51,6 +51,7 @@ val funptr :
   ?name:string ->
   ?check_errno:bool ->
   ?runtime_lock:bool ->
+  ?thread_registration:bool ->
   ('a -> 'b) Ctypes.fn ->
   ('a -> 'b) Ctypes.typ
 (** Construct a function pointer type from a function type.
@@ -81,6 +82,7 @@ val funptr_opt :
   ?name:string ->
   ?check_errno:bool ->
   ?runtime_lock:bool ->
+  ?thread_registration:bool ->
   ('a -> 'b) Ctypes.fn ->
   ('a -> 'b) option Ctypes.typ
 (** Construct a function pointer type from a function type.

tests/test-raw/test_raw.ml

@@ -24,6 +24,7 @@ let test_fabs _ =
     let callspec = allocate_callspec
       ~check_errno:false
       ~runtime_lock:false
+      ~thread_registration:false
     in
     let arg_1_offset = add_argument callspec double_ffitype in
     let () = prep_callspec callspec Libffi_abi.(abi_code default_abi)
@@ -57,6 +58,7 @@ let test_pow _ =
     let callspec = allocate_callspec
       ~check_errno:false
       ~runtime_lock:false
+      ~thread_registration:false
     in
     let arg_1_offset = add_argument callspec double_ffitype in
     let arg_2_offset = add_argument callspec double_ffitype in