From 953a2cedc151b1faec25cc9a19e666e6801c742a Mon Sep 17 00:00:00 2001 From: Jeremy Yallop Date: Wed, 17 Aug 2016 13:48:04 +0100 Subject: [PATCH 1/4] Test that OCaml values cannot be accessed without the runtime lock (Foreign). --- tests/test-passable/test_passable.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/test-passable/test_passable.ml b/tests/test-passable/test_passable.ml index 5428848c..53418293 100644 --- a/tests/test-passable/test_passable.ml +++ b/tests/test-passable/test_passable.ml @@ -348,6 +348,17 @@ 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 _ = + assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") + (fun () -> + Foreign.foreign "puts" (ocaml_string @-> returning int) + ~release_runtime_lock:true) + + let suite = "Passability tests" >::: ["primitives are passable" >:: test_primitives_are_passable; @@ -378,6 +389,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; ] From e5a4e0c926275dd5381ca607eb56769da8fbceda Mon Sep 17 00:00:00 2001 From: Jeremy Yallop Date: Wed, 17 Aug 2016 14:19:53 +0100 Subject: [PATCH 2/4] Disallow passing OCaml values to Foreign functions that release the runtime lock. --- src/ctypes-foreign-base/ctypes_ffi.ml | 7 +++++-- src/ctypes/ctypes_static.ml | 21 +++++++++++++++++++++ src/ctypes/ctypes_static.mli | 2 ++ 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/src/ctypes-foreign-base/ctypes_ffi.ml b/src/ctypes-foreign-base/ctypes_ffi.ml index c18313b0..f0a67509 100644 --- a/src/ctypes-foreign-base/ctypes_ffi.ml +++ b/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 diff --git a/src/ctypes/ctypes_static.ml b/src/ctypes/ctypes_static.ml index 9af3523e..807e2d14 100644 --- a/src/ctypes/ctypes_static.ml +++ b/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 diff --git a/src/ctypes/ctypes_static.mli b/src/ctypes/ctypes_static.mli index 9434b9e0..d6e0a51a 100644 --- a/src/ctypes/ctypes_static.mli +++ b/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 From fa327c448d63c50fb3ec022c9ec130ff764114f1 Mon Sep 17 00:00:00 2001 From: Jeremy Yallop Date: Wed, 17 Aug 2016 14:31:37 +0100 Subject: [PATCH 3/4] Test that OCaml values cannot be accessed without the runtime lock (Cstubs). --- Makefile.tests | 2 +- tests/test-passable/test_passable.ml | 29 ++++++++++++++++++++++++---- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/Makefile.tests b/Makefile.tests index 42da12d8..7f80c9e7 100644 --- a/Makefile.tests +++ b/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) diff --git a/tests/test-passable/test_passable.ml b/tests/test-passable/test_passable.ml index 53418293..b524e6e5 100644 --- a/tests/test-passable/test_passable.ml +++ b/tests/test-passable/test_passable.ml @@ -353,10 +353,31 @@ let test_incomplete_passability _ = without the OCaml runtime lock. *) let test_ocaml_values_are_not_passable_when_releasing_the_lock _ = - assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") - (fun () -> - Foreign.foreign "puts" (ocaml_string @-> returning int) - ~release_runtime_lock:true) + 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" >::: From 4d4c6f6690a3ddee716aa4b8a41404e20b499406 Mon Sep 17 00:00:00 2001 From: Jeremy Yallop Date: Wed, 17 Aug 2016 14:38:03 +0100 Subject: [PATCH 4/4] Disallow passing OCaml values to Cstubs functions that release the runtime lock. --- src/cstubs/cstubs_generate_c.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/cstubs/cstubs_generate_c.ml b/src/cstubs/cstubs_generate_c.ml index b56bcfd6..d57aaf2c 100644 --- a/src/cstubs/cstubs_generate_c.ml +++ b/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