Add Ctypes_memory.keep_alive function

ctypes-foreign.opam

@@ -1,5 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "0.23.0"
 synopsis: "Dynamic access to foreign C libraries using Ctypes"
 description: """
 

ctypes.opam

@@ -1,5 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "0.23.0"
 synopsis: "Combinators for binding to C libraries without writing any C"
 description: """
 

dune-project

@@ -1,6 +1,6 @@
 (lang dune 2.9)
 (name ctypes)
-(version 0.22.0)
+(version 0.23.0)
 (formatting (enabled_for dune))
 (use_standard_c_and_cxx_flags true)
 

src/cstubs/cstubs_generate_ml.ml

@@ -543,15 +543,15 @@ let rec wrapper_body : type a. concurrency:concurrency_policy -> errno:errno_pol
 let lwt_bind = Ctypes_path.path_of_string "Lwt.bind"
 let lwt_return = Ctypes_path.path_of_string "Lwt.return"
 let box_lwt = Ctypes_path.path_of_string "box_lwt"
-let use_value = Ctypes_path.path_of_string "CI.use_value"
+let keep_alive = Ctypes_path.path_of_string "CI.keep_alive"
 
 let return_result : args:lident list -> ml_exp =
   fun ~args ->
     let x = fresh_var () in
-    (* fun v -> CI.use_value (x1,x2,....xn); Lwt.return v *)
+    (* fun v -> CI.keep_alive (x1,x2,....xn); Lwt.return v *)
     `Fun ([x],
           `Seq
-            (`Appl (`Ident use_value,
+            (`Appl (`Ident keep_alive,
                     `Tuple
                       (ListLabels.map args
                          ~f:(fun x -> `Ident (Ctypes_path.path_of_string x)))),

src/ctypes-foreign/ctypes_ffi.ml

@@ -48,7 +48,7 @@ struct
   *)
   let kept_alive_indefinitely = ref []
   let keep_alive w ~while_live:v =
-    try Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value w; ()) v
+    try Gc.finalise (fun _ -> Ctypes_memory.keep_alive w; ()) v
     with Invalid_argument _ ->
       kept_alive_indefinitely := Obj.repr w :: !kept_alive_indefinitely
 
@@ -114,7 +114,7 @@ struct
               (fun buf arr -> List.iter (fun w -> r := w buf arr :: !r) writers)
               read_return_value
           in 
-          Ctypes_memory_stubs.use_value r;
+          Ctypes_memory.keep_alive r;
           v
       | WriteArg (write, ccallspec) ->
         let next = invoke name ccallspec in
@@ -154,7 +154,7 @@ struct
               raise Ctypes_ffi_stubs.CallToExpiredClosure
           in
           let v = box (Ctypes_weak_ref.make f') in
-          let () = Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value f') v in
+          let () = Gc.finalise (fun _ -> Ctypes_memory.keep_alive f') v in
           v)
 
   let rec write_arg : type a. a typ -> offset:int -> idx:int -> a ->

src/ctypes/cstubs_internals.ml

@@ -85,4 +85,4 @@ let build_enum_type name underlying ?(typedef=false) ?unexpected alist =
     Printf.ksprintf failwith
       "Enum type detected as floating type: %s" name
 
-let use_value v = Ctypes_memory_stubs.use_value v
+let keep_alive x = ignore (Sys.opaque_identity x)

src/ctypes/cstubs_internals.mli

@@ -95,4 +95,4 @@ val build_enum_type :
   string -> Ctypes_static.arithmetic -> ?typedef:bool ->
   ?unexpected:(int64 -> 'a) -> ('a * int64) list -> 'a typ
 
-val use_value : 'a -> unit
+val keep_alive : 'a -> unit

src/ctypes/ctypes.mli

@@ -198,6 +198,24 @@ val allocate_n : ?finalise:('a ptr -> unit) -> 'a typ -> count:int -> 'a ptr
     memory is allocated with libc's [calloc] and is guaranteed to be
     zero-filled.  *)
 
+val keep_alive : 'a -> unit
+(** Inserting [keep_alive x;] in a sequence of expressions ensures that
+    the garbage collector will not collect [x] until after that [keep_alive]
+    has returned.
+
+    For example:
+    {[
+      let strchr = Foreign.foreign "strchr" (ptr char @-> char @-> returning (ptr char)) in
+      let p = CArray.of_string "abc" in
+      let q =  strchr (CArray.start p) 'a' in
+      let () = Gc.compact () in
+      let () = Printf.printf "%c\n" !@q in
+      keep_alive p;
+    ]}
+    Without the [keep_alive p] at the bottom, [p] could be collected during the
+    [Gc.compact ()] call, which would make [q] an invalid pointer into the
+    now-collected [p], leading to undefined behavior. *)
+
 val ptr_compare : 'a ptr -> 'a ptr -> int
 (** If [p] and [q] are pointers to elements [i] and [j] of the same array then
     [ptr_compare p q] compares the indexes of the elements.  The result is

src/ctypes/ctypes_bigarray.ml

@@ -131,4 +131,7 @@ let view : type a b l m. (a, b, l) t -> (m option, _) Ctypes_ptr.Fat.t -> b =
   | Dims3 (d1, d2, d3) -> view3 kind ~dims:[| d1; d2; d3 |] ptr layout in
   match Ctypes_ptr.Fat.managed ptr with
   | None -> ba
-  | Some src -> Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value src) ba; ba
+  | Some src -> 
+    (* To avoid a dependence on Ctypes_memory, we redefine keep_alive here. *)
+    let keep_alive x = ignore (Sys.opaque_identity x) in
+    Gc.finalise (fun _ -> keep_alive src) ba; ba

src/ctypes/ctypes_memory.ml

@@ -147,6 +147,9 @@ let allocate : type a. ?finalise:(a ptr -> unit) -> a typ -> a -> a ptr
       p
     end
 
+let keep_alive : type a. a -> unit
+  = fun x -> ignore (Sys.opaque_identity x)
+
 let ptr_compare (CPointer l) (CPointer r) = Fat.(compare l r)
 
 let reference_type (CPointer p) = Fat.reftype p

src/ctypes/ctypes_memory_stubs.ml

@@ -46,6 +46,3 @@ external memcpy : dst:_ Fat.t -> src:_ Fat.t -> size:int -> unit
 external string_of_array : _ Fat.t -> len:int -> string
   = "ctypes_string_of_array"
 
-(* Do nothing, concealing from the optimizer that nothing is being done. *)
-external use_value : 'a -> unit
-  = "ctypes_use" [@@noalloc]

src/ctypes/ctypes_roots.c

@@ -34,9 +34,3 @@ value ctypes_caml_roots_release(value p_)
   caml_stat_free(p);
   return Val_unit;
 }
-
-/* 'a -> unit */
-value ctypes_use(value v)
-{
-  return Val_unit;
-}

tests/test-callback_lifetime/test_callback_lifetime.ml

@@ -97,7 +97,7 @@ struct
     let ret = Sys.opaque_identity (Better.make ~arg:(closure (int_of_string "3"))) in
     Gc.full_major ();
     assert_equal 15 (Better.get ret 5);
-    let _ = Ctypes_memory_stubs.use_value ret in
+    let _ = Ctypes_memory.keep_alive ret in
 
     (* However, even with the careful implementation things can go wrong if we
        keep a reference to ret beyond the lifetime of the pair. *)
@@ -111,7 +111,7 @@ struct
     let ret = Careful.get (Careful.make ~arg:(closure (int_of_string "3"))) in
     Gc.full_major ();
     assert_equal 15 (ret 5);
-    let _ = Ctypes_memory_stubs.use_value ret in
+    let _ = Ctypes_memory.keep_alive ret in
     ()
 end
 

tests/test-cstdlib/test_cstdlib.ml

@@ -124,7 +124,7 @@ struct
         f x y
       in
       let () = qsort (to_voidp (start arr)) len size cmp in
-      let _ = Ctypes_memory_stubs.use_value cmp in
+      let _ = Ctypes_memory.keep_alive cmp in
       to_list arr
       in
 
@@ -256,7 +256,7 @@ struct
     let () =
       assert_equal None (find_month_by_name empty)
 
-    let _ = Ctypes_memory_stubs.use_value
+    let _ = Ctypes_memory.keep_alive
       [jan; feb; mar; apr; may; jun;
        jul; aug; sep; oct; nov; dec]
     end in ()

tests/test-oo_style/test_oo_style.ml

@@ -68,7 +68,7 @@ struct
           assert_equal c#humps 3;
         end
 
-      let _ = Ctypes_memory_stubs.use_value (idfn, humpsfn, sayfn)
+      let _ = Ctypes_memory.keep_alive (idfn, humpsfn, sayfn)
 
       (* Test that we can call a virtual method in a C-created subclass from
          OCaml *)