Add support for C functions which directly handle OCaml values

Makefile.tests

@@ -799,6 +799,41 @@ tests/test-bools/generated_stubs.c: $(BUILDDIR)/test-bools-stub-generator.$(BEST
 tests/test-bools/generated_bindings.ml: $(BUILDDIR)/test-bools-stub-generator.$(BEST)
 	$< --ml-file $@
 
+test-values-stubs.dir  = tests/test-values/stubs
+test-values-stubs.threads = yes
+test-values-stubs.subproject_deps = ctypes \
+   ctypes-foreign tests-common
+test-values-stubs: PROJECT=test-values-stubs
+test-values-stubs: $$(LIB_TARGETS)
+
+test-values-stub-generator.dir = tests/test-values/stub-generator
+test-values-stub-generator.threads = yes
+test-values-stub-generator.subproject_deps = ctypes cstubs \
+     ctypes-foreign test-values-stubs tests-common
+test-values-stub-generator.deps = str bigarray integers
+test-values-stub-generator: PROJECT=test-values-stub-generator
+test-values-stub-generator: $$(BEST_TARGET)
+
+test-values.dir = tests/test-values
+test-values.threads = yes
+test-values.deps = str bigarray oUnit integers
+test-values.subproject_deps = ctypes ctypes-foreign \
+  cstubs tests-common test-values-stubs
+test-values.link_flags = -L$(BUILDDIR)/clib -ltest_functions
+test-values: PROJECT=test-values
+test-values: $$(BEST_TARGET)
+
+test-values-generated= \
+  tests/test-values/generated_bindings.ml \
+  tests/test-values/generated_stubs.c
+
+test-values-generated: $(test-values-generated)
+
+tests/test-values/generated_stubs.c: $(BUILDDIR)/test-values-stub-generator.$(BEST)
+	$< --c-file $@
+tests/test-values/generated_bindings.ml: $(BUILDDIR)/test-values-stub-generator.$(BEST)
+	$< --ml-file $@
+
 test-callback_lifetime-stubs.dir  = tests/test-callback_lifetime/stubs
 test-callback_lifetime-stubs.threads = yes
 test-callback_lifetime-stubs.subproject_deps = ctypes \
@@ -1359,6 +1394,7 @@ TESTS += test-returning-errno-stubs test-returning-errno-stub-generator test-ret
 TESTS += test-closure-type-promotion-stubs test-closure-type-promotion-stub-generator test-closure-type-promotion-generated test-closure-type-promotion
 TESTS += test-threads-stubs test-threads-stub-generator test-threads-generated test-threads
 TESTS += test-ldouble
+TESTS += test-values-stubs test-values-stub-generator test-values-generated test-values
 
 ifneq (,$(filter mingw%,$(OSYSTEM)))
 WINLDFLAGS=-Wl,--out-implib,libtest_functions.dll.a

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
+ | Value -> `Noalloc Noalloc_value
 
 let rec may_allocate : type a. a fn -> bool = function
   | Returns t ->

src/cstubs/cstubs_generate_c.ml

@@ -150,6 +150,7 @@ struct
     | OCaml String -> Some (string_to_ptr x)
     | OCaml Bytes -> Some (bytes_to_ptr x)
     | OCaml FloatArray -> Some (float_array_to_ptr x)
+    | Value -> Some (x :> ccomp)
 
   let prj ty x = prj ty ~orig:ty x
 
@@ -166,6 +167,7 @@ struct
     | Array _ -> report_unpassable "arrays"
     | Bigarray _ -> report_unpassable "bigarrays"
     | OCaml _ -> report_unpassable "ocaml references as return values"
+    | Value -> (x :> ceff)
 
   type _ fn =
   | Returns  : 'a typ   -> 'a fn

src/cstubs/cstubs_generate_ml.ml

@@ -239,6 +239,7 @@ let rec ml_typ_of_return_typ : type a. a typ -> ml_type =
   | Pointer _   -> voidp
   | Funptr _    -> voidp
   | View { ty } -> ml_typ_of_return_typ ty
+  | Value       -> `Ident (path_of_string "_")
   | Array _    as a -> internal_error
     "Unexpected array type in the return type: %s" (Ctypes.string_of_typ a)
   | Bigarray _ as a -> internal_error
@@ -273,6 +274,7 @@ 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")])])
+  | Value       -> `Ident (path_of_string "_")
 
 type polarity = In | Out
 
@@ -440,6 +442,8 @@ 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
+  | Value   ->
+    (static_con "Value" [], None, binds)
   | Abstract _ as ty -> internal_error
     "Unexpected abstract type encountered during ML code generation: %s"
     (Ctypes.string_of_typ ty)
@@ -484,6 +488,9 @@ let rec pattern_of_typ : type a. a typ -> ml_pat = function
     internal_error
       "Unexpected abstract type encountered during ML code generation: %s"
       (Ctypes.string_of_typ ty)
+  | Value ->
+    Ctypes_static.unsupported
+      "cstubs does not support OCaml values as global values"
 
 type wrapper_state = {
   pat: ml_pat;

src/ctypes-foreign/ctypes_ffi.ml

@@ -74,6 +74,7 @@ struct
     (* The following case should never happen; incomplete types are excluded
        during type construction. *)
     | Struct { spec = Incomplete _ }      -> report_unpassable "incomplete types"
+    | Value                               -> ArgType (Ctypes_ffi_stubs.value_ffitype ())
   and struct_arg_type : type s. s structure_type -> arg_type =
      fun ({fields} as s) ->
        let bufspec = Ctypes_ffi_stubs.allocate_struct_ffitype (List.length fields) in

src/ctypes-foreign/ctypes_ffi_stubs.ml

@@ -22,6 +22,9 @@ external pointer_ffitype : unit -> voidp ffitype
 external void_ffitype : unit -> unit ffitype
  = "ctypes_void_ffitype"
 
+external value_ffitype : unit -> 'a ffitype
+ = "ctypes_value_ffitype"
+
 
 (* Allocate a new C typed buffer specification *)
 external allocate_struct_ffitype : int -> struct_ffitype

src/ctypes-foreign/ffi_type_stubs.c

@@ -113,6 +113,23 @@ value ctypes_void_ffitype(value _)
   return CTYPES_FROM_PTR(&ffi_type_void);
 }
 
+/* value_ffitype : unit -> value ffitype */
+value ctypes_value_ffitype(value _)
+{
+#if SIZEOF_PTR == SIZEOF_LONG
+/* Standard models: ILP32 or I32LP64 */
+  return CTYPES_FROM_PTR(&ffi_type_slong);
+#elif SIZEOF_PTR == SIZEOF_INT
+/* Hypothetical IP32L64 model */
+  return CTYPES_FROM_PTR(&ffi_type_sint);
+#elif SIZEOF_PTR == 8
+/* Win64 model: IL32P64 */
+  return CTYPES_FROM_PTR(&ffi_type_sint64);
+#else
+#error "No integer type available to represent pointers"
+#endif
+}
+
 #define Struct_ffitype_val(v) (*(ffi_type **)Data_custom_val(v))
 
 /* allocate_struct_ffitype : int -> managed_buffer */

src/ctypes/cstubs_internals.mli

@@ -40,6 +40,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
+  | Value           :                              'a typ
 and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer =
   CPointer : (Obj.t option,'a typ) Ctypes_ptr.Fat.t -> ('a, [`C]) pointer
 | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer

src/ctypes/ctypes_memory.ml

@@ -37,6 +37,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)
+    | Value -> (fun buf -> Stubs.Value.read buf)
     (* The following cases should never happen; non-struct aggregate
        types are excluded during type construction. *)
     | Union _ -> assert false
@@ -75,6 +76,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
+    | Value -> (fun v dst -> Stubs.Value.write v dst)
 
 let null : unit ptr = CPointer (Fat.make ~managed:None ~reftyp:Void Raw.null)
 
@@ -93,6 +95,7 @@ let rec (!@) : type a. a ptr -> a
       | Bigarray b -> Ctypes_bigarray.view b cptr
       | Abstract _ -> { structured = ptr }
       | OCaml _ -> raise IncompleteType
+      | Value -> raise IncompleteType
       (* If it's a value type then we cons a new value. *)
       | _ -> build (Fat.reftype cptr) cptr
 

src/ctypes/ctypes_memory_stubs.ml

@@ -38,6 +38,15 @@ struct
   = "ctypes_write_pointer"
 end
 
+module Value =
+struct
+  external read : _ Fat.t -> _
+    = "ctypes_read_value"
+
+  external write : _ -> _ Fat.t -> unit
+    = "ctypes_write_value"
+end
+
 (* Copy [size] bytes from [src] to [dst]. *)
 external memcpy : dst:_ Fat.t -> src:_ Fat.t -> size:int -> unit
   = "ctypes_memcpy"

src/ctypes/ctypes_static.ml

@@ -32,7 +32,7 @@ type _ ocaml_type =
 | Bytes      : bytes 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
+  | Value           :                       'a typ
 and 'a carray = { astart : 'a ptr; alength : int }
 and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } [@@unboxed]
 and 'a union = ('a, [`Union]) structured
@@ -134,6 +135,7 @@ let rec sizeof : type a. a typ -> int = function
   | Funptr _                       -> Ctypes_primitives.pointer_size
   | OCaml _                        -> raise IncompleteType
   | View { ty }                    -> sizeof ty
+  | Value                          -> raise IncompleteType
 
 let rec alignment : type a. a typ -> int = function
     Void                             -> raise IncompleteType
@@ -150,6 +152,7 @@ let rec alignment : type a. a typ -> int = function
   | Funptr _                         -> Ctypes_primitives.pointer_alignment
   | OCaml _                          -> raise IncompleteType
   | View { ty }                      -> alignment ty
+  | Value                            -> raise IncompleteType
 
 let rec passable : type a. a typ -> bool = function
     Void                           -> true
@@ -165,6 +168,7 @@ let rec passable : type a. a typ -> bool = function
   | Abstract _                     -> false
   | OCaml _                        -> true
   | View { ty }                    -> passable ty
+  | Value                          -> true
 
 (* Whether a value resides in OCaml-managed memory.
    Values that reside in OCaml memory cannot be accessed
@@ -181,6 +185,7 @@ let rec ocaml_value : type a. a typ -> bool = function
   | Abstract _  -> false
   | OCaml _     -> true
   | View { ty } -> ocaml_value ty
+  | Value       -> true
 
 let rec has_ocaml_argument : type a. a fn -> bool = function
     Returns _ -> false
@@ -236,6 +241,11 @@ let id v = v
 let typedef old name =
   view ~format_typ:(fun k fmt -> Format.fprintf fmt "%s%t" name k)
     ~read:id ~write:id old
+module Value () = struct
+  type t
+
+  let typ = Value
+end
 
 let bigarray_ : type a b c d e l.
   < element: a;

src/ctypes/ctypes_static.mli

@@ -26,7 +26,7 @@ type 'a structspec =
     Incomplete of incomplete_size
   | Complete of structured_spec
 
-type _ typ =
+type 'a typ =
     Void            :                       unit typ
   | Primitive       : 'a Ctypes_primitive_types.prim -> 'a typ
   | Pointer         : 'a typ             -> 'a ptr typ
@@ -39,6 +39,7 @@ type _ typ =
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t
                                          -> 'a typ
   | OCaml           : 'a ocaml_type      -> 'a ocaml typ
+  | Value           :                       'a typ
 and 'a carray = { astart : 'a ptr; alength : int }
 and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } [@@unboxed]
 and 'a union = ('a, [`Union]) structured
@@ -181,6 +182,12 @@ val offsetof : ('a, 'b) field -> int
 val field_type : ('a, 'b) field -> 'a typ
 val field_name : ('a, 'b) field -> string
 
+module Value () : sig
+  type t
+
+  val typ : t typ
+end
+
 exception IncompleteType
 exception ModifyingSealedType of string
 exception Unsupported of string

src/ctypes/ctypes_type_printing.ml

@@ -76,6 +76,7 @@ let rec format_typ' : type a. a typ ->
     | OCaml String -> format_typ' (ptr char) k context fmt
     | OCaml Bytes -> format_typ' (ptr uchar) k context fmt
     | OCaml FloatArray -> format_typ' (ptr double) k context fmt
+    | 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

@@ -42,6 +42,16 @@ sig
       {!IncompleteType}.
   *)
 
+  (** {3 Value types}
+
+      The scalar types consist of the {!arithmetic_types} and the {!pointer_types}.
+  *)
+  module Value () : sig
+    type t
+
+    val typ : t typ
+  end
+
   (** {3 Scalar types}
 
       The scalar types consist of the {!arithmetic_types} and the {!pointer_types}.

src/ctypes/ctypes_value_printing.ml

@@ -27,6 +27,7 @@ let rec format : type a. a typ -> Format.formatter -> a -> unit
       | None -> format ty fmt (write v)
       | Some f -> f fmt v
     end
+  | Value -> Format.pp_print_string fmt "<abstract>"
 and format_structured : type a b. Format.formatter -> (a, b) structured -> unit
   = fun fmt ({structured = CPointer p} as s) ->
     let open Format in

src/ctypes/type_info_stubs.c

@@ -200,6 +200,23 @@ value ctypes_write_pointer(value p_, value dst_)
   CAMLreturn(Val_unit);
 }
 
+/* read_value : fat_pointer -> value */
+value ctypes_read_value(value src_)
+{
+  CAMLparam1(src_);
+  void *src = CTYPES_ADDR_OF_FATPTR(src_);
+  CAMLreturn(*(value *)src);
+}
+
+/* write_value : _ -> dst:fat_pointer -> unit */
+value ctypes_write_value(value v_, value dst_)
+{
+  CAMLparam2(v_, dst_);
+  void *dst = CTYPES_ADDR_OF_FATPTR(dst_);
+  *(value *)dst = v_;
+  CAMLreturn(Val_unit);
+}
+
 /* string_of_pointer : fat_pointer -> string */
 value ctypes_string_of_pointer(value p_)
 {