Reflect "managed" status in the types of fat pointers (#619)

Reflect "managed" status in the types of fat pointers (#619)

* Support patterns in let bindings in generated OCaml code.
* remove cptr and instead let-bind CPointer in generated code
* remove fptr and instead let-bind Static_funptr in generated code
* Parameterise fat pointers by the managed object type instead of using Obj.t
* Expose whether the managed object is optional in the type, and make it mutable.
* Update low-level tests for new cptr interface.

src/cstubs/cstubs_generate_ml.ml

@@ -38,7 +38,7 @@ type ml_exp = [ `Ident of path
               | `Appl of ml_exp * ml_exp
               | `Tuple of ml_exp list
               | `Seq of ml_exp * ml_exp
-              | `Let of lident * ml_exp * ml_exp
+              | `Let of ml_pat * ml_exp * ml_exp
               | `Unit
               | `Fun of lident list * ml_exp ]
 
@@ -156,10 +156,10 @@ struct
       fprintf fmt "(@[%a)@]" tuple_elements es
     | _, `Seq (e1, e2) ->
       fprintf fmt "(@[%a;@ %a)@]" (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2
-    | ApplParens, `Let (x, e1, e2) ->
-      fprintf fmt "(@[let@ %s@ = %a@ in@ %a)@]" x (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2
-    | NoApplParens, `Let (x, e1, e2) ->
-      fprintf fmt "@[let@ %s@ = %a@ in@ %a@]" x (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2
+    | ApplParens, `Let (p, e1, e2) ->
+      fprintf fmt "(@[let@ %a@ = %a@ in@ %a)@]" (ml_pat NoApplParens) p (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2
+    | NoApplParens, `Let (p, e1, e2) ->
+      fprintf fmt "@[let@ %a@ = %a@ in@ %a@]" (ml_pat NoApplParens) p (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2
   and tuple_elements fmt : ml_exp list -> unit =
     fun xs ->
       let last = List.length xs - 1 in
@@ -168,8 +168,7 @@ struct
           if i <> last then fprintf fmt "%a,@ " (ml_exp NoApplParens)
           else fprintf fmt "%a" (ml_exp NoApplParens))
         xs
-
-  let rec ml_pat appl_parens fmt pat =
+  and ml_pat appl_parens fmt pat =
     match appl_parens, pat with
     | _, `Var x -> fprintf fmt "%s" x
     | _, `Record (fs, `Etc) -> fprintf fmt "{@[%a_}@]" pat_fields fs
@@ -350,8 +349,10 @@ let map_result ~concurrency ~errno f e =
   | _, _, `Appl x ->
     map_result (`Ident (path_of_string x)) e 
 
+type pattern_exp_return = ml_pat * ml_exp option * (ml_pat * ml_exp) list
+
 let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno:errno_policy ->
-  a typ -> ml_exp -> polarity -> (lident * ml_exp) list -> ml_pat * ml_exp option * (lident * ml_exp) list =
+  a typ -> ml_exp -> polarity -> (ml_pat * ml_exp) list -> pattern_exp_return =
   fun ~concurrency ~errno typ e pol binds -> match typ with
   | Void ->
     (static_con "Void" [], None, binds)
@@ -362,7 +363,8 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
     begin match pol with
     | In ->
       let pat = static_con "Pointer" [`Underscore] in
-      (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"), e)), binds)
+      let x = fresh_var () in
+      (pat, Some (`Ident (path_of_string x)), binds @ [static_con "CPointer" [`Var x], e])
     | Out ->
       let x = fresh_var () in
       let pat = static_con "Pointer" [`Var x] in
@@ -372,7 +374,8 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
     begin match pol with
     | In ->
       let pat = static_con "Funptr" [`Underscore] in
-      (pat, Some (`Appl (`Ident (path_of_string "CI.fptr"), e)), binds)
+      let x = fresh_var () in
+      (pat, Some (`Ident (path_of_string x)), binds @ [static_con "Static_funptr" [`Var x], e])
     | Out ->
       let x = fresh_var () in
       let pat = static_con "Funptr" [`Var x] in
@@ -382,8 +385,10 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
     begin match pol with
     | In ->
       let pat = static_con "Struct" [`Underscore] in
-      (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"),
-                         `Appl (`Ident (path_of_string "Ctypes.addr"), e))), binds)
+      let x = fresh_var () in
+      (pat, Some (`Ident (path_of_string x)),
+       binds @ [static_con "CPointer" [`Var x],
+                `Appl (`Ident (path_of_string "Ctypes.addr"), e)])
     | Out ->
       let x = fresh_var () in
       let pat = `As (static_con "Struct" [`Underscore], x) in
@@ -393,8 +398,10 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
     begin match pol with
     | In ->
       let pat = static_con "Union" [`Underscore] in
-      (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"),
-                         `Appl (`Ident (path_of_string "Ctypes.addr"), e))), binds)
+      let x = fresh_var () in
+      (pat, Some (`Ident (path_of_string x)),
+       binds @ [static_con "CPointer" [`Var x],
+                `Appl (`Ident (path_of_string "Ctypes.addr"), e)])
     | Out ->
       let x = fresh_var () in
       let pat = `As (static_con "Union" [`Underscore], x) in
@@ -411,7 +418,7 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
       let pat = static_con "View"
         [`Record ([path_of_string "CI.ty", p;
                    path_of_string "write", `Var x], `Etc)] in
-      (pat, Some (`Ident (Ctypes_path.path_of_string y)), (y, e) :: binds)
+      (pat, Some (`Ident (Ctypes_path.path_of_string y)), (`Var y, e) :: binds)
     | Out ->
       let (p, None, binds), e | (p, Some e, binds), _ =
         pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in
@@ -483,7 +490,7 @@ type wrapper_state = {
   exp: ml_exp;
   args: lident list;
   trivial: bool;
-  binds: (lident * ml_exp) list;
+  binds: (ml_pat * ml_exp) list;
 }
 
 let lwt_unix_run_job = Ctypes_path.path_of_string "Lwt_unix.run_job"
@@ -497,13 +504,13 @@ let run_exp ~concurrency exp = match concurrency with
                                  `Fun (["_"], exp)),
                           `Unit)
 
-let let_bind : (lident * ml_exp) list -> ml_exp -> ml_exp =
+let let_bind : (ml_pat * ml_exp) list -> ml_exp -> ml_exp =
   fun binds e ->
     ListLabels.fold_left ~init:e binds
       ~f:(fun e' (x, e) -> `Let (x, e, e'))
 
 let rec wrapper_body : type a. concurrency:concurrency_policy -> errno:errno_policy ->
-  a fn -> ml_exp -> polarity -> (lident * ml_exp) list -> wrapper_state =
+  a fn -> ml_exp -> polarity -> (ml_pat * ml_exp) list -> wrapper_state =
   fun ~concurrency ~errno fn exp pol binds -> match fn with
   | Returns t ->
     let exp = run_exp ~concurrency exp in
@@ -548,6 +555,16 @@ let return_result : args:lident list -> ml_exp =
                          ~f:(fun x -> `Ident (Ctypes_path.path_of_string x)))),
              `Appl (`Ident lwt_return, `Ident (Ctypes_path.path_of_string x))))
 
+(** Returns the variables bound in a pattern, in no particular order *)
+let rec pat_bound_vars : ml_pat -> lident list = function
+  | `Var x -> [x]
+  | `Record (args, _) -> pats_bound_vars (List.map snd args)
+  | `As (p, x) -> x :: pat_bound_vars p
+  | `Underscore -> []
+  | `Con (_, ps) -> pats_bound_vars ps
+and pats_bound_vars : ml_pat list -> lident list =
+  fun ps -> List.fold_left (fun xs p -> pat_bound_vars p @ xs) [] ps
+
 let wrapper : type a. concurrency:concurrency_policy -> errno:errno_policy ->
   path -> a fn -> string -> polarity -> ml_pat * ml_exp =
   fun ~concurrency ~errno id fn f pol ->
@@ -564,13 +581,17 @@ let wrapper : type a. concurrency:concurrency_policy -> errno:errno_policy ->
                     (`Appl (`Ident box_lwt,
                             `Appl (`Appl (`Ident lwt_bind,
                                           run_exp ~concurrency exp),
-                                   return_result ~args:(args @ (List.map fst binds)))))))
+                                   return_result ~args:(args
+                                                        @ pats_bound_vars
+                                                            (List.map fst binds)))))))
     | { exp; args; pat; binds }, #lwt ->
       (pat, `Fun (args,
                   let_bind binds
                     (`Appl (`Ident box_lwt,
                             `Appl (`Appl (`Ident lwt_bind, exp),
-                                   return_result ~args:(args @ (List.map fst binds)))))))
+                                   return_result ~args:(args @
+                                                          pats_bound_vars
+                                                            (List.map fst binds)))))))
 
 let case ~concurrency ~errno ~stub_name ~external_name fmt fn =
   let p, e = wrapper ~concurrency ~errno

src/ctypes-foreign-base/ctypes_ffi.ml

@@ -96,12 +96,12 @@ struct
           write arg_n buffer v_n)
      read_return_value
   *)
-  let rec invoke : type a b.
+  let rec invoke : type a b m.
     string option ->
     a ccallspec ->
     (Ctypes_ptr.voidp -> (Obj.t * int) array -> Obj.t) list ->
     Ctypes_ffi_stubs.callspec ->
-    b fn Ctypes_ptr.Fat.t ->
+    (m, b fn) Ctypes_ptr.Fat.t ->
     a
     = fun name -> function
       | Call (check_errno, read_return_value) ->
@@ -137,15 +137,17 @@ struct
         let write_rv = Ctypes_memory.write ty in
         fun f ->
           let w = write_rv (Ctypes_weak_ref.get f) in
-          Ctypes_ffi_stubs.Done ((fun p -> w (Ctypes_ptr.Fat.make ~reftyp:Void p)),
+          Ctypes_ffi_stubs.Done ((fun p -> w (Ctypes_ptr.Fat.make
+                                                ~managed:None ~reftyp:Void p)),
                           callspec)
       | Function (p, f) ->
         let _ = add_argument callspec p in
         let box = box_function abi f callspec in
         let read = Ctypes_memory.build p in
         fun f -> Ctypes_ffi_stubs.Fn (fun buf ->
           let f' =
-            try Ctypes_weak_ref.get f (read (Ctypes_ptr.Fat.make ~reftyp:Void buf))
+            try Ctypes_weak_ref.get f (read (Ctypes_ptr.Fat.make
+                                               ~managed:None ~reftyp:Void buf))
             with Ctypes_weak_ref.EmptyWeakReference ->
               raise Ctypes_ffi_stubs.CallToExpiredClosure
           in
@@ -170,7 +172,7 @@ struct
          Obj.repr (wv, wa))
     | ty -> (fun ~offset ~idx v dst mov -> 
         Ctypes_memory.write ty v
-          (Ctypes_ptr.Fat.(add_bytes (make ~reftyp:Void dst) offset));
+          (Ctypes_ptr.Fat.(add_bytes (make ~managed:None ~reftyp:Void dst) offset));
         Obj.repr v)
 
   (*
@@ -187,7 +189,7 @@ struct
       | Returns t ->
         let () = prep_callspec callspec abi t in
         let b = Ctypes_memory.build t in
-        Call (check_errno, (fun p -> b (Ctypes_ptr.Fat.make ~reftyp:Void p)))
+        Call (check_errno, (fun p -> b (Ctypes_ptr.Fat.make ~managed:None ~reftyp:Void p)))
       | Function (p, f) ->
         let offset = add_argument callspec p in
         let rest = build_ccallspec ~abi ~check_errno ~idx:(idx+1) f callspec in
@@ -202,14 +204,13 @@ struct
     invoke name e [] c
 
   let funptr_of_rawptr fn raw_ptr =
-    Static_funptr (Ctypes_ptr.Fat.make ~reftyp:fn raw_ptr)
+    Static_funptr (Ctypes_ptr.Fat.make ~managed:None ~reftyp:fn raw_ptr)
 
   let function_of_pointer ?name ~abi ~check_errno ~release_runtime_lock fn =
     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
+    else fun (Static_funptr p) ->
+         build_function ?name ~abi ~check_errno ~release_runtime_lock fn p
 
   let pointer_of_function_internal ~abi ~acquire_runtime_lock ~thread_registration fn =
     let cs' = Ctypes_ffi_stubs.allocate_callspec

src/ctypes-foreign-base/ctypes_ffi_stubs.ml

@@ -56,7 +56,7 @@ external prep_callspec : callspec -> int -> _ ffitype -> unit
 (* Call the function specified by `callspec' at the given address.
    The callback functions write the arguments to the buffer and read
    the return value. *)
-external call : string -> _ Ctypes_static.fn Fat.t -> callspec ->
+external call : string -> (_, _ Ctypes_static.fn) Fat.t -> callspec ->
   (voidp -> (Obj.t * int) array -> unit) -> (voidp -> 'a) -> 'a
   = "ctypes_call"
 

src/ctypes/cstubs_internals.ml

@@ -10,23 +10,21 @@
 
 type voidp = Ctypes_ptr.voidp
 type managed_buffer = Ctypes_memory_stubs.managed_buffer
-type 'a fatptr = 'a Ctypes.typ Ctypes_ptr.Fat.t
-type 'a fatfunptr = 'a Ctypes.fn Ctypes_ptr.Fat.t
+type ('m, 'a) fatptr = ('m, 'a Ctypes.typ) Ctypes_ptr.Fat.t
+type ('m, 'a) fatfunptr = ('m, 'a Ctypes.fn) Ctypes_ptr.Fat.t
 
 let make_structured reftyp buf =
   let open Ctypes_static in
-  let managed = Obj.repr buf in
   let raw_ptr = Ctypes_memory_stubs.block_address buf in
-  { structured = CPointer (Ctypes_ptr.Fat.make ~managed ~reftyp raw_ptr) }
+  { structured = CPointer (Ctypes_ptr.Fat.make ~managed:(Some buf) ~reftyp raw_ptr) }
 
 include Ctypes_static
 include Ctypes_primitive_types
 
-let make_ptr reftyp raw_ptr = CPointer (Ctypes_ptr.Fat.make ~reftyp raw_ptr)
-let make_fun_ptr reftyp raw_ptr = Static_funptr (Ctypes_ptr.Fat.make ~reftyp raw_ptr)
-
-let cptr (CPointer p) = p
-let fptr (Static_funptr p) = p
+let make_ptr reftyp raw_ptr = CPointer (Ctypes_ptr.Fat.make
+                                          ~managed:None ~reftyp raw_ptr)
+let make_fun_ptr reftyp raw_ptr = Static_funptr (Ctypes_ptr.Fat.make
+                                                   ~managed:None ~reftyp raw_ptr)
 
 let mkView :
   type a b. string -> a typ -> typedef:bool -> unexpected:(a -> b) -> (b * a) list -> b typ =

src/ctypes/cstubs_internals.mli

@@ -14,18 +14,15 @@ open Unsigned
 
 type voidp = Ctypes_ptr.voidp
 type managed_buffer = Ctypes_memory_stubs.managed_buffer
-type 'a fatptr = 'a typ Ctypes_ptr.Fat.t
-type 'a fatfunptr = 'a fn Ctypes_ptr.Fat.t
+type ('m, 'a) fatptr = ('m, 'a typ) Ctypes_ptr.Fat.t
+type ('m, 'a) fatfunptr = ('m, 'a fn) Ctypes_ptr.Fat.t
 
 val make_structured :
   ('a, 's) structured typ -> managed_buffer -> ('a, 's) structured
 
 val make_ptr : 'a typ -> voidp -> 'a ptr
 val make_fun_ptr : 'a fn -> voidp -> 'a Ctypes_static.static_funptr
 
-val cptr : 'a ptr -> 'a typ Ctypes_ptr.Fat.t
-val fptr : 'a Ctypes_static.static_funptr -> 'a fn Ctypes_ptr.Fat.t
-
 type 'a ocaml_type = 'a Ctypes_static.ocaml_type =
   String     : string ocaml_type
 | Bytes      : Bytes.t ocaml_type
@@ -44,12 +41,12 @@ type 'a typ = 'a Ctypes_static.typ =
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t -> 'a typ
   | OCaml           : 'a ocaml_type             -> 'a ocaml typ
 and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer =
-  CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer
+  CPointer : (_ option,'a typ) Ctypes_ptr.Fat.t -> ('a, [`C]) pointer
 | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer
 and 'a ptr = ('a, [`C]) pointer
 and 'a ocaml = ('a, [`OCaml]) pointer
 and 'a static_funptr = 'a Ctypes_static.static_funptr =
-  Static_funptr of 'a fn Ctypes_ptr.Fat.t
+  Static_funptr : (_ option, 'a fn) Ctypes_ptr.Fat.t -> 'a static_funptr
 and ('a, 'b) view = ('a, 'b) Ctypes_static.view = {
   read : 'b -> 'a;
   write : 'a -> 'b;

src/ctypes/ctypes_bigarray.ml

@@ -122,7 +122,7 @@ let prim_of_kind k = prim_of_kind (kind k)
 
 let unsafe_address b = Ctypes_bigarray_stubs.address b
 
-let view : type a b l. (a, b, l) t -> _ Ctypes_ptr.Fat.t -> b =
+let view : type a b l m. (a, b, l) t -> (m option, _) Ctypes_ptr.Fat.t -> b =
   let open Ctypes_bigarray_stubs in
   fun (dims, kind, layout) ptr -> let ba : b = match dims with
   | DimsGen ds -> view kind ~dims:ds ptr layout

src/ctypes/ctypes_bigarray.mli

@@ -59,7 +59,7 @@ val unsafe_address : 'a -> Ctypes_ptr.voidp
     reference to the OCaml object then the array might be freed, invalidating
     the address. *)
 
-val view : (_, 'a, _) t -> _ Ctypes_ptr.Fat.t -> 'a
+val view : (_, 'a, _) t -> (_ option, _) Ctypes_ptr.Fat.t -> 'a
 (** [view b ptr] creates a bigarray view onto existing memory.
 
     If [ptr] references an OCaml object then [view] will ensure that