Allow passing OCaml values directly to stubs

src/cstubs/cstubs_analysis.ml

@@ -21,14 +21,15 @@ let rec float : type a. a fn -> bool = function
 
 (* A value of type 'a noalloc says that reading a value of type 'a
    will not cause an OCaml allocation in C code. *)
-type _ noalloc =
+type 'a noalloc =
   Noalloc_unit : unit noalloc
 | Noalloc_int : int noalloc
 | Noalloc_uint8_t : Unsigned.uint8 noalloc
 | Noalloc_uint16_t : Unsigned.uint16 noalloc
 | Noalloc_char : char noalloc
 | Noalloc_bool : bool noalloc
 | Noalloc_view : ('a, 'b) view * 'b noalloc -> 'a noalloc
+| Noalloc_value : 'a noalloc
 
 (* A value of type 'a alloc says that reading a value of type 'a
    may cause an OCaml allocation in C code. *)
@@ -109,6 +110,7 @@ let rec allocation : type a. a typ -> a allocation = function
  | Array _ -> `Alloc Alloc_array
  | Bigarray ba -> `Alloc (Alloc_bigarray ba)
  | OCaml _ -> `Alloc Alloc_pointer
+ | OCaml_value -> `Noalloc Noalloc_value
 
 let rec may_allocate : type a. a fn -> bool = function
   | Returns t ->

src/cstubs/cstubs_generate_c.ml

@@ -145,6 +145,7 @@ struct
     | OCaml String -> Some (string_to_ptr x)
     | OCaml Bytes -> Some (string_to_ptr x)
     | OCaml FloatArray -> Some (float_array_to_ptr x)
+    | OCaml_value -> Some (x :> ccomp)
 
   let prj ty x = prj ty ~orig:ty x
 
@@ -161,6 +162,7 @@ struct
     | Array _ -> report_unpassable "arrays"
     | Bigarray _ -> report_unpassable "bigarrays"
     | OCaml _ -> report_unpassable "ocaml references as return values"
+    | OCaml_value -> (x:> ceff)
 
   type _ fn =
   | Returns  : 'a typ   -> 'a fn
@@ -193,17 +195,17 @@ struct
                `Ignore_errno, `Sequential -> `Let ((local x t, e), (inj t (local x t) :> ccomp))
              | `Ignore_errno, `Unlocked ->
                 release_runtime_system >>
-                `Let ((local x t, e), 
+                `Let ((local x t, e),
                       acquire_runtime_system >>
                      (((inj t (local x t) :> ccomp), value) >>= fun x ->
 		      `CAMLreturnT (Ty value, x) :> ccomp))
-             | `Return_errno, `Sequential -> 
+             | `Return_errno, `Sequential ->
                (`LetAssign (errno,
                            `Int Signed.SInt.zero,
                            `Let ((local x t, e),
                                  ((inj t (local x t) :> ccomp), value) >>= fun v ->
                                  (pair_with_errno v :> ccomp))) : ccomp)
-             | `Return_errno, `Unlocked -> 
+             | `Return_errno, `Unlocked ->
                (`LetAssign (errno,
                            `Int Signed.SInt.zero,
                            release_runtime_system >>
@@ -345,7 +347,7 @@ module Lwt =
 struct
   let fprintf, sprintf = Format.fprintf, Printf.sprintf
 
-  let unsupported t = 
+  let unsupported t =
     let fail msg = raise (Unsupported msg) in
     Printf.ksprintf fail
       "cstubs.lwt does not support the type %s"
@@ -364,7 +366,7 @@ struct
   let lwt_unix_job =
     abstract ~name:"struct lwt_unix_job" ~size:1 ~alignment:1
 
-  let structure_type stub_name = 
+  let structure_type stub_name =
     structure (sprintf "job_%s" stub_name)
 
   let structure (type r) ~errno ~stub_name fmt fn args (result : r typ) =
@@ -383,7 +385,7 @@ struct
         ~f:(fun (BoxedType t, name) -> ignore (field s name t : (_,_) field)) in
     let () = seal s in
     fprintf fmt "@[%a@];@\n" (fun t -> format_typ t) s
-    
+
   let worker (type r) ~errno ~cname ~stub_name fmt f (result : r typ) args =
     let fn' = { fname = cname;
                allocates = false;
@@ -500,7 +502,7 @@ struct
           Function (Void, f) -> aux f args
         | Function (t, f) -> aux f ((BoxedType t, var "arg") :: args)
         | Returns t -> List.rev args, BoxedType t
-     in aux fn []  
+     in aux fn []
 
   let fn ~errno ~cname ~stub_name fmt fn =
     let args, BoxedType r = fn_args_and_result fn in

src/cstubs/cstubs_generate_ml.ml

@@ -30,7 +30,7 @@ type ml_pat = [ `Var of string
               | `Underscore
               | `Con of path * ml_pat list ]
 
-type ml_exp = [ `Ident of path 
+type ml_exp = [ `Ident of path
               | `Project of ml_exp * path
               | `MakePtr of ml_exp * ml_exp
               | `MakeFunPtr of ml_exp * ml_exp
@@ -52,7 +52,7 @@ type extern = {
   attributes: attributes;
 }
 
-module Emit_ML : sig 
+module Emit_ML : sig
   type appl_parens = ApplParens | NoApplParens
   val ml_exp : appl_parens -> Format.formatter -> ml_exp -> unit
   val ml_pat : appl_parens -> Format.formatter -> ml_pat -> unit
@@ -62,13 +62,13 @@ end =
 struct
   let fprintf = Format.fprintf
 
-  (* We (only) need to parenthesize function types in certain contexts 
+  (* We (only) need to parenthesize function types in certain contexts
         * on the lhs of a function type: - -> t
         * as the argument to a single-argument type constructor: - t
   *)
   type arrow_parens = ArrowParens | NoArrowParens
 
-  (* We (only) need to parenthesize application expressions in certain contexts 
+  (* We (only) need to parenthesize application expressions in certain contexts
         * in a projection expression: -.l
         * in a dereference expression: !@ -
         * as an argument in an application: e -
@@ -108,7 +108,7 @@ struct
     | Some primname -> fprintf fmt "%S@ " primname
 
   let attrs fmt { float; noalloc } =
-    begin 
+    begin
     (* TODO: float support not yet implemented *)
     (* if float then pp_print_string fmt "\"float\""; *)
 
@@ -250,6 +250,7 @@ let rec ml_typ_of_return_typ : type a. a typ -> ml_type =
     "cstubs does not support OCaml bytes values as return values"
   | OCaml FloatArray -> Ctypes_static.unsupported
     "cstubs does not support OCaml float arrays as return values"
+  | OCaml_value -> `Ident (literal_path "'a")
 
 let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function
   | Void -> `Ident (path_of_string "unit")
@@ -274,6 +275,8 @@ let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function
     `Appl (path_of_string "CI.ocaml",
            [`Appl (path_of_string "array",
                    [`Ident (path_of_string "float")])])
+  | OCaml_value ->
+    `Ident (literal_path "'a")
 
 type polarity = In | Out
 
@@ -348,7 +351,7 @@ let map_result ~concurrency ~errno f e =
   | _, _, `MakeStructured x ->
     map_result (`Appl (`Ident make_structured, `Ident (path_of_string x))) e
   | _, _, `Appl x ->
-    map_result (`Ident (path_of_string x)) e 
+    map_result (`Ident (path_of_string x)) e
 
 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 =
@@ -433,6 +436,7 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
     | Out, FloatArray -> Ctypes_static.unsupported
       "cstubs does not support OCaml float arrays as return values"
     end
+  | OCaml_value -> (static_con "OCaml_value" [], None, binds)
   | Abstract _ as ty -> internal_error
     "Unexpected abstract type encountered during ML code generation: %s"
     (Ctypes.string_of_typ ty)
@@ -473,6 +477,9 @@ let rec pattern_of_typ : type a. a typ -> ml_pat = function
   | OCaml FloatArray ->
     Ctypes_static.unsupported
       "cstubs does not support OCaml float arrays as global values"
+  | OCaml_value ->
+    Ctypes_static.unsupported
+      "cstubs does not support generic OCaml values as global values"
   | Abstract _ as ty ->
     internal_error
       "Unexpected abstract type encountered during ML code generation: %s"
@@ -600,5 +607,5 @@ let inverse_case ~register_name ~constructor name fmt fn : unit =
       (path_of_string "f") fn "f" Out in
   Format.fprintf fmt "|@[ @[%a, %S@] -> %s %s (%a)@]@\n"
     Emit_ML.(ml_pat NoApplParens) p name register_name constructor
-    Emit_ML.(ml_exp ApplParens) 
+    Emit_ML.(ml_exp ApplParens)
     e

src/cstubs/ctypes_path.ml

@@ -20,10 +20,13 @@ let rec is_valid_path = function
   | [l] -> is_ident l
   | u :: p -> is_uident u && is_valid_path p
 
-let path_of_string s = 
+let path_of_string s =
   let p = Str.(split (regexp_string ".") s) in
   if is_valid_path p then p
   else invalid_arg "Ctypes_ident.path_of_string"
 
 let format_path fmt p =
   Format.pp_print_string fmt (String.concat "." p)
+
+let literal_path s =
+  [s]

src/cstubs/ctypes_path.mli

@@ -10,4 +10,5 @@
 type path
 
 val path_of_string : string -> path
+val literal_path : string -> path
 val format_path : Format.formatter -> path -> unit

src/ctypes-foreign-base/ctypes_ffi.ml

@@ -64,6 +64,7 @@ struct
     | Pointer _                           -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
     | Funptr _                            -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
     | OCaml _                             -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
+    | OCaml_value                         -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
     | Union _                             -> report_unpassable "unions"
     | Struct ({ spec = Complete _ } as s) -> struct_arg_type s
     | View { ty }                         -> arg_type ty
@@ -111,7 +112,7 @@ struct
           let v = Ctypes_ffi_stubs.call name addr callspec
               (fun buf arr -> List.iter (fun w -> r := w buf arr :: !r) writers)
               read_return_value
-          in 
+          in
           Ctypes_memory_stubs.use_value r;
           v
       | WriteArg (write, ccallspec) ->
@@ -164,11 +165,11 @@ struct
     | OCaml Bytes      -> ocaml_arg 1
     | OCaml FloatArray -> ocaml_arg (Ctypes_primitives.sizeof Ctypes_primitive_types.Double)
     | View { write = w; ty } ->
-      (fun ~offset ~idx v dst mov -> 
+      (fun ~offset ~idx v dst mov ->
          let wv = w v in
          let wa = write_arg ty ~offset ~idx wv dst mov in
          Obj.repr (wv, wa))
-    | ty -> (fun ~offset ~idx v dst mov -> 
+    | ty -> (fun ~offset ~idx v dst mov ->
         Ctypes_memory.write ty v
           (Ctypes_ptr.Fat.(add_bytes (make ~reftyp:Void dst) offset));
         Obj.repr v)

src/ctypes/cstubs_internals.mli

@@ -43,6 +43,7 @@ type 'a typ = 'a Ctypes_static.typ =
   | Array           : 'a typ * int              -> 'a Ctypes_static.carray typ
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t -> 'a typ
   | OCaml           : 'a ocaml_type             -> 'a ocaml typ
+  | OCaml_value     :                              'a typ
 and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer =
   CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer
 | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer

src/ctypes/ctypes_memory.ml

@@ -35,6 +35,7 @@ let rec build : type a b. a typ -> b typ Fat.t -> a
       let buildty = build ty in
       (fun buf -> read (buildty buf))
     | OCaml _ -> (fun buf -> assert false)
+    | OCaml_value -> (fun buf -> assert false)
     (* The following cases should never happen; non-struct aggregate
        types are excluded during type construction. *)
     | Union _ -> assert false
@@ -73,6 +74,7 @@ let rec write : type a b. a typ -> a -> b Fat.t -> unit
       let writety = write ty in
       (fun v -> writety (w v))
     | OCaml _ -> raise IncompleteType
+    | OCaml_value -> raise IncompleteType
 
 let null : unit ptr = CPointer (Fat.make ~reftyp:Void Raw.null)
 
@@ -415,7 +417,7 @@ struct
 
   let set : 'a. unit ptr -> 'a -> unit =
     fun p v -> Stubs.set (raw_addr p) v
-  
+
   let release : 'a. unit ptr -> unit =
     fun p -> Stubs.release (raw_addr p)
 end

src/ctypes/ctypes_static.ml

@@ -32,7 +32,7 @@ type _ ocaml_type =
 | Bytes      : Bytes.t ocaml_type
 | FloatArray : float array ocaml_type
 
-type _ typ =
+type 'a typ =
     Void            :                       unit typ
   | Primitive       : 'a Ctypes_primitive_types.prim -> 'a typ
   | Pointer         : 'a typ             -> 'a ptr typ
@@ -45,6 +45,7 @@ type _ typ =
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t
                                          -> 'a typ
   | OCaml           : 'a ocaml_type      -> 'a ocaml typ
+  | OCaml_value     :                       'a typ
 and 'a carray = { astart : 'a ptr; alength : int }
 and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr }
 and 'a union = ('a, [`Union]) structured
@@ -132,6 +133,7 @@ let rec sizeof : type a. a typ -> int = function
   | Pointer _                      -> Ctypes_primitives.pointer_size
   | Funptr _                       -> Ctypes_primitives.pointer_size
   | OCaml _                        -> raise IncompleteType
+  | OCaml_value                    -> raise IncompleteType
   | View { ty }                    -> sizeof ty
 
 let rec alignment : type a. a typ -> int = function
@@ -148,6 +150,7 @@ let rec alignment : type a. a typ -> int = function
   | Pointer _                        -> Ctypes_primitives.pointer_alignment
   | Funptr _                         -> Ctypes_primitives.pointer_alignment
   | OCaml _                          -> raise IncompleteType
+  | OCaml_value                      -> raise IncompleteType
   | View { ty }                      -> alignment ty
 
 let rec passable : type a. a typ -> bool = function
@@ -163,6 +166,7 @@ let rec passable : type a. a typ -> bool = function
   | Funptr _                       -> true
   | Abstract _                     -> false
   | OCaml _                        -> true
+  | OCaml_value                    -> true
   | View { ty }                    -> passable ty
 
 (* Whether a value resides in OCaml-managed memory.
@@ -179,6 +183,7 @@ let rec ocaml_value : type a. a typ -> bool = function
   | Funptr _    -> false
   | Abstract _  -> false
   | OCaml _     -> true
+  | OCaml_value -> true
   | View { ty } -> ocaml_value ty
 
 let rec has_ocaml_argument : type a. a fn -> bool = function
@@ -221,6 +226,7 @@ let array i t = Array (t, i)
 let ocaml_string = OCaml String
 let ocaml_bytes = OCaml Bytes
 let ocaml_float_array = OCaml FloatArray
+let ocaml_any_value = OCaml_value
 let ptr t = Pointer t
 let ( @->) f t =
   if not (passable f) then
@@ -242,7 +248,7 @@ let bigarray_ : type a b c d e l.
     dims: b;
     ba_repr: c;
     bigarray: d;
-    carray: e > bigarray_class -> 
+    carray: e > bigarray_class ->
    b -> (a, c) Bigarray.kind -> l Bigarray.layout -> d typ =
   fun spec dims kind l -> match spec with
   | Genarray -> Bigarray (Ctypes_bigarray.bigarray dims kind l)

src/ctypes/ctypes_static.mli

@@ -13,7 +13,7 @@ type abstract_type = {
   aalignment : int;
 }
 
-type _ ocaml_type =
+type 'a ocaml_type =
   String     : string ocaml_type
 | Bytes      : Bytes.t ocaml_type
 | FloatArray : float array ocaml_type
@@ -39,6 +39,7 @@ type _ typ =
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t
                                          -> 'a typ
   | OCaml           : 'a ocaml_type      -> 'a ocaml typ
+  | OCaml_value     :                       'a typ
 and 'a carray = { astart : 'a ptr; alength : int }
 and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr }
 and 'a union = ('a, [`Union]) structured
@@ -149,6 +150,7 @@ val ullong : Unsigned.ullong typ
 val array : int -> 'a typ -> 'a carray typ
 val ocaml_string : string ocaml typ
 val ocaml_bytes : Bytes.t ocaml typ
+val ocaml_any_value : 'a typ
 val ocaml_float_array : float array ocaml typ
 val ptr : 'a typ -> 'a ptr typ
 val ( @-> ) : 'a typ -> 'b fn -> ('a -> 'b) fn

src/ctypes/ctypes_type_printing.ml

@@ -76,6 +76,8 @@ let rec format_typ' : type a. a typ ->
     | OCaml String -> format_typ' (ptr char) k context fmt
     | OCaml Bytes -> format_typ' (ptr char) k context fmt
     | OCaml FloatArray -> format_typ' (ptr double) k context fmt
+    | OCaml_value ->
+      fprintf fmt "value%t" (k `nonarray)
 
 and format_fields : type a. a boxed_field list -> Format.formatter -> unit =
   fun fields fmt ->

src/ctypes/ctypes_types.mli

@@ -212,6 +212,10 @@ sig
   val ocaml_bytes : Bytes.t Ctypes_static.ocaml typ
   (** Value representing the directly mapped storage of an OCaml byte array. *)
 
+  val ocaml_any_value : 'a typ
+  (** Value representing any OCaml value, to be accessed from C directly. This
+      corresponds to the C type [value] from [caml/mlvalues.h]. *)
+
   (** {3 Array types} *)
 
   (** {4 C array types} *)

src/ctypes/ctypes_value_printing.ml

@@ -22,6 +22,7 @@ let rec format : type a. a typ -> Format.formatter -> a -> unit
     (fun fmt -> Ctypes_type_printing.format_typ fmt) typ
   | Abstract _ -> format_structured fmt v
   | OCaml _ -> format_ocaml fmt v
+  | OCaml_value -> Format.pp_print_string fmt "(value)"
   | View {write; ty; format=f} ->
     begin match f with
       | None -> format ty fmt (write v)