Merge pull request #431 from yallop/runtime-lock-restrictions

Disallow passing OCaml values to functions that release the runtime lock

Makefile.tests

@@ -506,7 +506,7 @@ test-foreign-errno: $$(BEST_TARGET)
 test-passable.dir = tests/test-passable
 test-passable.threads = yes
 test-passable.deps = str bigarray oUnit bytes
-test-passable.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded
+test-passable.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded cstubs
 test-passable: PROJECT=test-passable
 test-passable: $$(BEST_TARGET)
 

src/cstubs/cstubs_generate_c.ml

@@ -528,8 +528,10 @@ struct
     end
 end
 
-let fn ~concurrency ~errno = match concurrency with
-  | `Lwt_preemptive | `Unlocked -> fn ~concurrency:`Unlocked ~errno
-  | `Sequential -> fn ~concurrency:`Sequential ~errno
-  | `Lwt_jobs -> Lwt.fn ~errno
+let fn ~concurrency ~errno ~cname ~stub_name fmt f = match concurrency with
+  | `Lwt_preemptive | `Unlocked | `Lwt_jobs when has_ocaml_argument f ->
+    raise (Unsupported "Unsupported argument type when releasing runtime lock")
+  | `Lwt_preemptive | `Unlocked -> fn ~concurrency:`Unlocked ~errno ~cname ~stub_name fmt f
+  | `Sequential -> fn ~concurrency:`Sequential ~errno ~cname ~stub_name fmt f
+  | `Lwt_jobs -> Lwt.fn ~errno ~cname ~stub_name fmt f
 

src/ctypes-foreign-base/ctypes_ffi.ml

@@ -183,8 +183,11 @@ struct
     Static_funptr (Ctypes_ptr.Fat.make ~reftyp:fn raw_ptr)
 
   let function_of_pointer ?name ~abi ~check_errno ~release_runtime_lock fn =
-    let f = build_function ?name ~abi ~check_errno ~release_runtime_lock fn in
-    fun (Static_funptr p) -> f p
+    if release_runtime_lock && has_ocaml_argument fn
+    then raise (Unsupported "Unsupported argument type when releasing runtime lock")
+    else
+      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 ~thread_registration fn =
     let cs' = Ctypes_ffi_stubs.allocate_callspec

src/ctypes/ctypes_static.ml

@@ -161,6 +161,27 @@ let rec passable : type a. a typ -> bool = function
   | OCaml _                        -> true
   | View { ty }                    -> passable ty
 
+(* Whether a value resides in OCaml-managed memory.
+   Values that reside in OCaml memory cannot be accessed
+   when the runtime lock is not held. *)
+let rec ocaml_value : type a. a typ -> bool = function
+    Void        -> false
+  | Primitive _ -> false
+  | Struct _    -> false
+  | Union _     -> false
+  | Array _     -> false
+  | Bigarray _  -> false
+  | Pointer _   -> false
+  | Funptr _    -> false
+  | Abstract _  -> false
+  | OCaml _     -> true
+  | View { ty } -> ocaml_value ty
+
+let rec has_ocaml_argument : type a. a fn -> bool = function
+    Returns _ -> false
+  | Function (t, _) when ocaml_value t -> true
+  | Function (_, t) -> has_ocaml_argument t
+
 let void = Void
 let char = Primitive Ctypes_primitive_types.Char
 let schar = Primitive Ctypes_primitive_types.Schar

src/ctypes/ctypes_static.mli

@@ -108,6 +108,8 @@ type boxed_typ = BoxedType : 'a typ -> boxed_typ
 val sizeof : 'a typ -> int
 val alignment : 'a typ -> int
 val passable : 'a typ -> bool
+val ocaml_value : 'a typ -> bool
+val has_ocaml_argument : 'a fn -> bool
 
 val void : unit typ
 val char : char typ

tests/test-passable/test_passable.ml

@@ -348,6 +348,38 @@ let test_incomplete_passability _ =
   end
 
 
+(*
+  Test that OCaml values cannot be passed to C functions that are called
+  without the OCaml runtime lock.
+*)
+let test_ocaml_values_are_not_passable_when_releasing_the_lock _ =
+  begin
+    assert_raises (Unsupported "Unsupported argument type when releasing runtime lock")
+      (fun () ->
+         Foreign.foreign "puts" (ocaml_string @-> returning int)
+           ~release_runtime_lock:true);
+
+    let module Bindings (F:Cstubs.FOREIGN) =
+    struct F.(foreign "puts" (ocaml_string @-> returning int)) end
+    in
+
+    assert_raises (Unsupported "Unsupported argument type when releasing runtime lock")
+      (fun () ->
+         Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.unlocked
+           Format.str_formatter (module Bindings));
+
+    assert_raises (Unsupported "Unsupported argument type when releasing runtime lock")
+      (fun () ->
+         Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.lwt_jobs
+           Format.str_formatter (module Bindings));
+
+    assert_raises (Unsupported "Unsupported argument type when releasing runtime lock")
+      (fun () ->
+         Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.lwt_preemptive
+           Format.str_formatter (module Bindings));
+  end
+
+
 let suite = "Passability tests" >:::
   ["primitives are passable"
     >:: test_primitives_are_passable;
@@ -378,6 +410,9 @@ let suite = "Passability tests" >:::
 
    "incomplete types are not passable"
     >:: test_incomplete_passability;
+
+   "ocaml values are not passable when the runtime lock is released"
+    >:: test_ocaml_values_are_not_passable_when_releasing_the_lock;
   ]