improve handling of ocaml finalizers (#9)

* ensure entry arguments live long enough

* ensure arguments to futhark functions live long enough

* use Ctypes_ptr.Fat to manage pointer lifetimes

* attach finalizers to C pointers, hold a context reference in array/opaque finalizers

* test for opaque use after free

* use get_ptr/get_opaque_ptr to access C pointers

* bump version to 0.2.8

* set null pointer in free function

CHANGES.md

@@ -1,3 +1,7 @@
+## 0.2.8
+
+- Improved handling of C pointers in OCaml finalizers
+
 ## 0.2.7
 
 - Fixed possible double frees when GC is triggered after `free` has already been called

Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "futhark-bindgen"
-version = "0.2.7"
+version = "0.2.8"
 edition = "2021"
 authors = ["Zach Shipko <[email protected]>"]
 license = "ISC"

examples/ocaml/test/test.ml

@@ -36,7 +36,7 @@ let () =
     try
       let _ = Array_f64_2d.get out in
       assert false
-    with Error (UseAfterFree `array) -> print_endline "Detected use after free"
+    with Error (UseAfterFree `array) -> print_endline "Detected array use after free"
   in
 
   (* tup_mul *)
@@ -50,6 +50,14 @@ let () =
     assert (out'.{i} = Array.get data3 i *. (Number.get_x (Tup.get_0 tup)))
   done;
 
+  Tup.free tup;
+  let () = 
+    try
+      let _ = Tup.get_0 tup in
+      assert false
+    with Error (UseAfterFree `opaque) -> print_endline "Detected opaque use after free"
+  in
+
   (* count_lines *)
   let text = "this\nis\na\ntest\n" in
   let arr = Array.init (String.length text) (fun i -> String.get text i |> int_of_char) in

src/generate/ocaml.rs

@@ -422,10 +422,10 @@ impl Generate for OCaml {
             new_params.push(format!("field{}", f.name));
 
             if type_is_array(&t) {
-                new_call_args.push(format!("field{}.ptr", f.name));
+                new_call_args.push(format!("(get_ptr field{})", f.name));
                 new_arg_types.push(format!("{}.t", first_uppercase(&t)));
             } else if type_is_opaque(&t) {
-                new_call_args.push(format!("field{}.opaque_ptr", f.name));
+                new_call_args.push(format!("(get_opaque_ptr field{})", f.name));
                 new_arg_types.push(t.to_string());
             } else {
                 new_call_args.push(format!("field{}", f.name));
@@ -562,9 +562,9 @@ impl Generate for OCaml {
 
             let t = self.get_type(&input.r#type);
             if type_is_array(&t) {
-                call_args.push(format!("input{i}.ptr"));
+                call_args.push(format!("(get_ptr input{i})"));
             } else if type_is_opaque(&t) {
-                call_args.push(format!("input{i}.opaque_ptr"));
+                call_args.push(format!("(get_opaque_ptr input{i})"));
             } else {
                 call_args.push(format!("input{i}"));
             }

src/generate/templates/ocaml/array.ml

@@ -5,10 +5,11 @@ module {module_name} = struct
 
   let kind = {ba_kind}
 
-  let free t =
-    if not t.array_free && not t.ctx.Context.context_free then
-      let () = ignore (Bindings.futhark_free_{elemtype}_{rank}d t.ctx.Context.handle t.ptr) in
-      t.array_free <- true
+  let free ctx ptr =
+    let is_null = Ctypes.is_null ptr || Ctypes.is_null (!@ptr) in
+    if not ctx.Context.context_free && not is_null then
+      let () = ignore (Bindings.futhark_free_{elemtype}_{rank}d ctx.Context.handle (!@ptr)) in
+      ptr <-@ Ctypes.null
 
   let cast x =
     coerce (ptr void) (ptr {ocaml_ctype}) (to_voidp x)
@@ -19,17 +20,15 @@ module {module_name} = struct
     let ptr = Bindings.futhark_new_{elemtype}_{rank}d ctx.Context.handle (cast @@ bigarray_start genarray ba) {dim_args} in
     if is_null ptr then raise (Error NullPtr);
     Context.auto_sync ctx;
-    let t = {{ ptr; ctx; shape = dims; array_free = false }} in
-    Gc.finalise free t; t
+    {{ ptr = Ctypes.allocate ~finalise:(free ctx) (Ctypes.ptr Ctypes.void) ptr; ctx; shape = dims }}
 
   let values t ba =
     check_use_after_free `context t.ctx.Context.context_free;
-    check_use_after_free `array t.array_free;
     let dims = Genarray.dims ba in
     let a = Array.fold_left ( * ) 1 t.shape in
     let b = Array.fold_left ( * ) 1 dims in
     if (a <> b) then raise (Error (InvalidShape (a, b)));
-    let rc = Bindings.futhark_values_{elemtype}_{rank}d t.ctx.Context.handle t.ptr (cast @@ bigarray_start genarray ba) in
+    let rc = Bindings.futhark_values_{elemtype}_{rank}d t.ctx.Context.handle (get_ptr t) (cast @@ bigarray_start genarray ba) in
     Context.auto_sync t.ctx;
     if rc <> 0 then raise (Error (Code rc))
 
@@ -71,8 +70,9 @@ module {module_name} = struct
     check_use_after_free `context ctx.Context.context_free;
     if is_null ptr then raise (Error NullPtr);
     let shape = ptr_shape ctx.Context.handle ptr in
-    let t = {{ ptr; ctx; shape; array_free = false }} in
-    Gc.finalise free t; t
+    {{ ptr = Ctypes.allocate ~finalise:(free ctx) (Ctypes.ptr Ctypes.void) ptr; ctx; shape }}
+
+  let free t = free t.ctx t.ptr
 
   let _ = of_ptr
 end

src/generate/templates/ocaml/bindings.ml

@@ -36,6 +36,10 @@ type error =
 
 exception Error of error
 
+let set_managed (p: 'a Ctypes_static.ptr) x =
+  match p with
+  | Ctypes_static.CPointer fat -> Ctypes_ptr.Fat.set_managed fat (Some (Obj.repr x))
+
 let check_use_after_free t b = if b then raise (Error (UseAfterFree t))
 
 let () = Printexc.register_printer (function
@@ -44,7 +48,7 @@ let () = Printexc.register_printer (function
   | Error (Code c) -> Some (Printf.sprintf "futhark error: code %d" c) 
   | Error (UseAfterFree `context) -> Some "futhark: context used after beeing freed"
   | Error (UseAfterFree `array) -> Some "futhark: array used after beeing freed"
-  | Error (UseAfterFree `opaque) -> Some "futhark: opqaue value used after beeing freed"
+  | Error (UseAfterFree `opaque) -> Some "futhark: opaque value used after beeing freed"
   | _ -> None)
 
 

src/generate/templates/ocaml/context.ml

@@ -1,7 +1,9 @@
 open Bigarray
 
 module Context = struct
+  [@@@ocaml.warning "-69"]
   type t = {{ handle: unit ptr; config: unit ptr; cache_file: string option; auto_sync: bool; mutable context_free: bool }}
+  [@@@ocaml.warning "+69"]
 
   let free t =
     if not t.context_free then
@@ -24,6 +26,7 @@ module Context = struct
       raise (Error NullPtr)
     else
       let t = {{ handle; config; cache_file; auto_sync; context_free = false }} in
+      set_managed handle t; 
       let () = Gc.finalise free t in
       t
 
@@ -64,5 +67,22 @@ module Context = struct
     Bindings.futhark_context_unpause_profiling t.handle
 end
 
-type futhark_array = {{ ptr: unit ptr; shape: int array; ctx: Context.t; mutable array_free: bool }}
-type opaque = {{ opaque_ptr: unit ptr; opaque_ctx: Context.t; mutable opaque_free: bool }}
+[@@@ocaml.warning "-34"]
+[@@@ocaml.warning "-69"]
+type futhark_array = {{ mutable ptr: unit ptr ptr; shape: int array; ctx: Context.t }}
+type opaque = {{ mutable opaque_ptr: unit ptr ptr; opaque_ctx: Context.t }}
+[@@@ocaml.warning "+34"]
+[@@@ocaml.warning "+69"]
+
+[@@@ocaml.warning "-32"]
+let get_ptr t =
+  let x = !@(t.ptr) in
+  check_use_after_free `array (Ctypes.is_null x);
+  x
+
+let get_opaque_ptr t =
+  let x = !@(t.opaque_ptr) in
+  check_use_after_free `opaque (Ctypes.is_null x);
+  x
+[@@@ocaml.warning "+32"]
+

src/generate/templates/ocaml/opaque.ml

@@ -2,14 +2,16 @@
   let t = Bindings.{name}
   let _ = t
 
-  let free t = 
-    if not t.opaque_free && not t.opaque_ctx.Context.context_free then
-      let () = ignore (Bindings.{free_fn} t.opaque_ctx.Context.handle t.opaque_ptr) in
-      t.opaque_free <- true
+  let free' ctx ptr = 
+    let is_null = Ctypes.is_null ptr || Ctypes.is_null (!@ptr) in
+    if not ctx.Context.context_free && not is_null then
+      let () = ignore (Bindings.{free_fn} ctx.Context.handle (!@ptr)) in
+      ptr <-@ Ctypes.null
 
   let of_ptr ctx ptr =
     if is_null ptr then raise (Error NullPtr);
-    let t = {{ opaque_ptr = ptr; opaque_ctx = ctx; opaque_free = false }} in
-    Gc.finalise free t; t
+    {{ opaque_ptr = allocate ~finalise:(free' ctx) (Ctypes.ptr Ctypes.void) ptr; opaque_ctx = ctx }}
+
+  let free t = free' t.opaque_ctx t.opaque_ptr 
 
   let _ = of_ptr

src/generate/templates/ocaml/record.ml

@@ -1,9 +1,7 @@
   let v ctx {new_params} =
     check_use_after_free `context ctx.Context.context_free;
-    let ptr = allocate (ptr void) null in
+    let ptr = allocate ~finalise:(free' ctx) (ptr void) null in
     let rc = Bindings.{new_fn} ctx.Context.handle ptr {new_call_args} in
-    Context.auto_sync ctx;
     if rc <> 0 then raise (Error (Code rc));
-    let opaque_ptr = !@ptr in
-    let t = {{ opaque_ptr; opaque_ctx = ctx; opaque_free = false }} in
-    Gc.finalise free t; t
+    Context.auto_sync ctx;
+    {{ opaque_ptr = ptr; opaque_ctx = ctx }}

src/generate/templates/ocaml/record_project.ml

@@ -1,8 +1,7 @@
   let get_{name} t =
     check_use_after_free `context t.opaque_ctx.Context.context_free;
-    check_use_after_free `opaque t.opaque_free;
     let out = allocate_n ~count:1 {s} in
-    let rc = Bindings.{project} t.opaque_ctx.Context.handle out t.opaque_ptr in
+    let rc = Bindings.{project} t.opaque_ctx.Context.handle out (get_opaque_ptr t) in
     if rc <> 0 then raise (Error (Code rc));
     Context.auto_sync t.opaque_ctx;
     {out}