diff --git a/.depend b/.depend index 96abfc96..c6e574c8 100644 --- a/.depend +++ b/.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 diff --git a/Makefile b/Makefile index af8ee364..688f054f 100644 --- a/Makefile +++ b/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 diff --git a/src/ctypes-foreign-base/ctypes_ffi.ml b/src/ctypes-foreign-base/ctypes_ffi.ml index cb19160e..c18313b0 100644 --- a/src/ctypes-foreign-base/ctypes_ffi.ml +++ b/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 -> diff --git a/src/ctypes-foreign-base/ctypes_ffi.mli b/src/ctypes-foreign-base/ctypes_ffi.mli index 61d0aad8..d025cfc7 100644 --- a/src/ctypes-foreign-base/ctypes_ffi.mli +++ b/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 diff --git a/src/ctypes-foreign-base/ctypes_ffi_stubs.ml b/src/ctypes-foreign-base/ctypes_ffi_stubs.ml index 269ce198..b9c666e5 100644 --- a/src/ctypes-foreign-base/ctypes_ffi_stubs.ml +++ b/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 *) diff --git a/src/ctypes-foreign-base/ctypes_foreign_basis.ml b/src/ctypes-foreign-base/ctypes_foreign_basis.ml index fe7a1f25..dfda20d6 100644 --- a/src/ctypes-foreign-base/ctypes_foreign_basis.ml +++ b/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) diff --git a/src/ctypes-foreign-base/ffi_call_stubs.c b/src/ctypes-foreign-base/ffi_call_stubs.c index 3d92aeb9..65aac234 100644 --- a/src/ctypes-foreign-base/ffi_call_stubs.c +++ b/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(); diff --git a/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.ml b/src/ctypes-foreign-threaded/ctypes_foreign_threaded_stubs.ml new file mode 100644 index 00000000..c5f2816c --- /dev/null +++ b/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" diff --git a/src/ctypes-foreign-threaded/foreign.ml b/src/ctypes-foreign-threaded/foreign.ml index c75b1d10..48d0cab5 100644 --- a/src/ctypes-foreign-threaded/foreign.ml +++ b/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 diff --git a/src/ctypes-foreign-threaded/foreign.mli b/src/ctypes-foreign-threaded/foreign.mli index 4d6b8cf4..f9f06d19 100644 --- a/src/ctypes-foreign-threaded/foreign.mli +++ b/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. diff --git a/src/ctypes-foreign-threaded/foreign_threaded_stubs.c b/src/ctypes-foreign-threaded/foreign_threaded_stubs.c new file mode 100644 index 00000000..9b90bc36 --- /dev/null +++ b/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 +#include + +#ifdef _WIN32 +value ctypes_setup_thread_registration(value _) +{ + /* Don't override the hook on systems without pthreads. */ + return Val_unit; +} +#else +#include + +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 diff --git a/src/ctypes-foreign-unthreaded/foreign.mli b/src/ctypes-foreign-unthreaded/foreign.mli index 4d6b8cf4..f9f06d19 100644 --- a/src/ctypes-foreign-unthreaded/foreign.mli +++ b/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. diff --git a/tests/test-raw/test_raw.ml b/tests/test-raw/test_raw.ml index 36db8ad4..641f8d10 100644 --- a/tests/test-raw/test_raw.ml +++ b/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