[WIP] Add Obj.t typ for OCaml values

META

@@ -2,20 +2,20 @@ version = "0.20.0"
 description = "Combinators for binding to C libraries without writing any C."
 requires = "bigarray-compat bytes integers"
 archive(byte) = "ctypes.cma"
-archive(byte, plugin) = "ctypes.cma"
+plugin(byte) = "ctypes.cma"
 archive(byte, toploop) = "ctypes.cma ctypes-top.cma"
 archive(native) = "ctypes.cmxa"
-archive(native, plugin) = "ctypes.cmxs"
+plugin(native) = "ctypes.cmxs"
 exists_if = "ctypes.cma"
 
 package "top" (
   version = "0.20.0"
   description = "Toplevel printers for C types"
   requires = "ctypes"
   archive(byte) = "ctypes-top.cma"
-  archive(byte, plugin) = "ctypes-top.cma"
+  plugin(byte) = "ctypes-top.cma"
   archive(native) = "ctypes-top.cmxa"
-  archive(native, plugin) = "ctypes-top.cmxs"
+  plugin(native) = "ctypes-top.cmxs"
   exists_if = "ctypes-top.cma"
 )
 
@@ -24,9 +24,9 @@ package "stubs" (
   description = "Stub generation from C types"
   requires = "ctypes str"
   archive(byte) = "cstubs.cma"
-  archive(byte, plugin) = "cstubs.cma"
+  plugin(byte) = "cstubs.cma"
   archive(native) = "cstubs.cmxa"
-  archive(native, plugin) = "cstubs.cmxs"
+  plugin(native) = "cstubs.cmxs"
   xen_linkopts = "-lctypes_stubs_xen"
   exists_if = "cstubs.cma"
 )
@@ -36,8 +36,8 @@ package "foreign" (
  description = "Dynamic linking of C functions"
  requires = "threads ctypes"
  archive(byte) = "ctypes-foreign.cma"
- archive(byte, plugin) = "ctypes-foreign.cma"
+ plugin(byte) = "ctypes-foreign.cma"
  archive(native) = "ctypes-foreign.cmxa"
- archive(native, plugin) = "ctypes-foreign.cmxs"
+ plugin(native) = "ctypes-foreign.cmxs"
  exists_if = "ctypes-foreign.cma"
 )

ctypes-foreign.opam

@@ -1,47 +1,18 @@
 opam-version: "2.0"
 version: "dev"
+synopsis: "Virtual package for enabling the ctypes.foreign subpackage."
+description: """\
+`ctypes-foreign` is just a virtual OPAM package that determines
+whether the foreign subpackage should built as part of ctypes."""
 maintainer: "[email protected]"
+authors: "[email protected]"
+tags: ["org:ocamllabs" "org:mirage"]
 homepage: "https://github.com/ocamllabs/ocaml-ctypes"
-dev-repo: "git+http://github.com/ocamllabs/ocaml-ctypes.git"
 bug-reports: "http://github.com/ocamllabs/ocaml-ctypes/issues"
-depexts: [
-  ["libffi-dev"] {os-family = "debian"}
-  ["libffi"] {os = "macos" & os-distribution = "homebrew"}
-  ["libffi"] {os = "macos" & os-distribution = "macports"}
-  ["libffi-devel"] {os-distribution = "centos"}
-  ["libffi-devel"] {os-distribution = "ol"}
-  ["libffi"] {os = "win32" & os-distribution = "cygwinports"}
-  ["libffi-devel"] {os-distribution = "fedora"}
-  ["libffi-dev"] {os-distribution = "alpine"}
-  ["libffi-devel"] {os-family = "suse"}
-]
 depends: [
+  "ctypes" {post}
   "conf-pkg-config" {build}
+  "conf-libffi" {>= "2.0.0"}
 ]
-tags: ["org:ocamllabs" "org:mirage"]
-post-messages: [
-  "This package requires libffi on your system" {failure}
-]
-synopsis: "Virtual package for enabling the ctypes.foreign subpackage"
-description: """
-`ctypes-foreign` is just a virtual OPAM package that determines
-whether the foreign subpackage should built as part of ctypes.
-In order to actually get the ctypes package, you should also:
-
-    opam install ctypes ctypes-foreign
-
-You can verify the existence of the ocamlfind subpackage by:
-
-    ocamlfind list | grep ctypes
-
-Which should output something like:
-
-    ctypes              (version: 0.4.1)
-    ctypes.foreign      (version: 0.4.1)
-    ctypes.foreign.base (version: 0.4.1)
-    ctypes.foreign.threaded (version: 0.4.1)
-    ctypes.foreign.unthreaded (version: 0.4.1)
-    ctypes.stubs        (version: 0.4.1)
-    ctypes.top          (version: 0.4.1)"""
-authors: "[email protected]"
-
+post-messages: "This package requires libffi on your system" {failure}
+dev-repo: "git+http://github.com/ocamllabs/ocaml-ctypes.git"

ctypes.opam

@@ -1,47 +1,56 @@
 opam-version: "2.0"
 version: "dev"
+synopsis: "Combinators for binding to C libraries without writing any C"
+description: """\
+ctypes is a library for binding to C libraries using pure OCaml. The primary
+aim is to make writing C extensions as straightforward as possible.
+
+The core of ctypes is a set of combinators for describing the structure of C
+types -- numeric types, arrays, pointers, structs, unions and functions. You
+can use these combinators to describe the types of the functions that you want
+to call, then bind directly to those functions -- all without writing or
+generating any C!
+
+To install the optional `ctypes.foreign` interface (which uses `libffi` to
+provide dynamic access to foreign libraries), you will need to also install
+the `ctypes-foreign` optional dependency:
+
+    opam install ctypes ctypes-foreign
+
+This will make the `ctypes.foreign` ocamlfind subpackage available."""
 maintainer: "[email protected]"
-author: "[email protected]"
+authors: "[email protected]"
+license: "MIT"
+tags: ["org:ocamllabs" "org:mirage"]
 homepage: "https://github.com/ocamllabs/ocaml-ctypes"
 doc: "http://ocamllabs.github.io/ocaml-ctypes"
-dev-repo: "git+http://github.com/ocamllabs/ocaml-ctypes.git"
 bug-reports: "http://github.com/ocamllabs/ocaml-ctypes/issues"
-license: "MIT"
-build: [
-  [make
-    "XEN=%{mirage-xen:enable}%"
-    "COVERAGE=true" {bisect_ppx:installed}
-    "libffi.config"
-    "ctypes-base"
-    "ctypes-stubs"]
-  [make "XEN=%{mirage-xen:enable}%" "ctypes-foreign"] {ctypes-foreign:installed}
-]
-install: [
-  [make "install" "XEN=%{mirage-xen:enable}%"]
-]
 depends: [
-   "ocaml" {>= "4.03.0"}
-   "integers" { >= "0.3.0" }
-   "ocamlfind" {build}
-   "lwt" {with-test & >= "3.2.0"}
-   "ctypes-foreign" {with-test}
-   "ounit" {with-test}
-   "conf-ncurses" {with-test}
-   "bigarray-compat"
+  "ocaml" {>= "4.03.0"}
+  "integers" {>= "0.3.0"}
+  "ocamlfind" {build}
+  "lwt" {with-test & >= "3.2.0"}
+  "ctypes-foreign" {with-test}
+  "ounit" {with-test}
+  "conf-ncurses" {with-test}
+  "bigarray-compat"
 ]
-depopts: [
-   "ctypes-foreign"
-   "mirage-xen"
-   "bisect_ppx" {with-test}
-   "ocveralls" {with-test}
+depopts: ["ctypes-foreign" "mirage-xen"]
+conflicts: [
+  "mirage-xen" {>= "6.0.0"}
 ]
-build-test: [
-   [make "COVERAGE=true" {bisect_ppx:installed} "test"]
-   [make "COVERAGE=true" {bisect_ppx:installed} "run-examples" ] {os != "win32"}
-   [make "date" "date-stubs" "date-stub-generator" "date-cmd-build" "date-cmd" ] {os = "win32"}
-   ["sh" "-c" "_build/date-cmd.native ; _build/date.native" ] {os = "win32"}
-   ["sh" "-c" "ocveralls" "--send bisect*.out" "_build/bisect*.out" ">" "coveralls.json"] {bisect_ppx:installed}
+build: [
+  [make "XEN=%{mirage-xen:enable}%" "libffi.config"]
+    {ctypes-foreign:installed}
+  ["touch" "libffi.config"] {!ctypes-foreign:installed}
+  [make "XEN=%{mirage-xen:enable}%" "ctypes-base" "ctypes-stubs"]
+  [make "XEN=%{mirage-xen:enable}%" "ctypes-foreign"]
+    {ctypes-foreign:installed}
+  [make "test"] {with-test}
 ]
-tags: ["org:ocamllabs" "org:mirage"]
-synopsis: "Combinators for binding to C libraries without writing any C"
-
+install: [make "install" "XEN=%{mirage-xen:enable}%"]
+dev-repo: "git+http://github.com/ocamllabs/ocaml-ctypes.git"
+url {
+  src: "https://github.com/ocamllabs/ocaml-ctypes/archive/0.19.1.tar.gz"
+  checksum: "md5=ceb891ec568fd7da76c31af270a2afe2"
+}

src/cstubs/cstubs_analysis.ml

@@ -52,6 +52,7 @@ type _ alloc =
 | Alloc_complex : Complex.t alloc
 | Alloc_complexld : ComplexL.t alloc
 | Alloc_pointer : (_, _) pointer alloc
+| Alloc_value : Obj.t alloc
 | Alloc_funptr : _ static_funptr alloc
 | Alloc_structured : (_, _) structured alloc
 | Alloc_array : _ carray alloc
@@ -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 -> `Alloc Alloc_value
 
 let rec may_allocate : type a. a fn -> bool = function
   | Returns t ->

src/cstubs/cstubs_generate_c.ml

@@ -87,6 +87,16 @@ struct
                           (value @-> returning (ptr void)),
                    [x])
 
+  let value_to_intnat : cexp -> ccomp =
+    fun x -> `App (reader "CTYPES_INTNAT_OF_VALUE"
+                          (value @-> returning nativeint),
+                   [x])
+
+  let intnat_to_value : cexp -> ceff =
+    fun x -> `App (conser "CTYPES_VALUE_OF_INTNAT"
+                          (nativeint @-> returning value),
+                   [x])
+
   let from_ptr : cexp -> ceff =
     fun x -> `App (conser "CTYPES_FROM_PTR"
                           (ptr void @-> returning value),
@@ -150,6 +160,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 (value_to_intnat x)
 
   let prj ty x = prj ty ~orig:ty x
 
@@ -165,6 +176,7 @@ struct
     | View { ty } -> inj ty x
     | Array _ -> report_unpassable "arrays"
     | Bigarray _ -> report_unpassable "bigarrays"
+    | Value -> (intnat_to_value (x:>cexp))
     | OCaml _ -> report_unpassable "ocaml references as return values"
 
   type _ fn =

src/cstubs/cstubs_generate_ml.ml

@@ -249,6 +249,9 @@ 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"
+  | Value ->
+    `Ident (path_of_string "Obj.t")
+
 
 let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function
   | Void -> `Ident (path_of_string "unit")
@@ -273,6 +276,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")])])
+  | Value ->
+    `Ident (path_of_string "Obj.t")
 
 type polarity = In | Out
 
@@ -440,6 +445,11 @@ 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 ->
+   begin  match pol with
+     | In -> (static_con "Value" [], None, binds)
+     | Out -> (static_con "Value" [], None, binds)
+   end
   | Abstract _ as ty -> internal_error
     "Unexpected abstract type encountered during ML code generation: %s"
     (Ctypes.string_of_typ ty)
@@ -480,6 +490,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"
+  | Value ->
+    Ctypes_static.unsupported
+      "cstubs does not support OCaml value as global values"
   | Abstract _ as ty ->
     internal_error
       "Unexpected abstract type encountered during ML code generation: %s"

src/ctypes-foreign/ctypes_ffi.ml

@@ -27,7 +27,7 @@ struct
   let () = Ctypes_ffi_stubs.set_closure_callback Closure_properties.retrieve
 
   type _ ccallspec =
-      Call : bool * (Ctypes_ptr.voidp -> 'a) -> 'a ccallspec
+      Call : bool * (Obj.t -> 'a) -> 'a ccallspec
     | WriteArg : ('a -> Ctypes_ptr.voidp -> (Obj.t * int) array -> Obj.t) * 'b ccallspec ->
                  ('a -> 'b) ccallspec
 
@@ -64,6 +64,9 @@ struct
     | Pointer _                           -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
     | Funptr _                            -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
     | OCaml _                             -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ())
+    | Value                               ->
+      let ffitype = Ctypes_ffi_stubs.primitive_ffitype Ctypes_primitive_types.Nativeint in
+      ArgType (ffitype)
     | Union _                             -> report_unpassable "unions"
     | Struct ({ spec = Complete _ } as s) -> struct_arg_type s
     | View { ty }                         -> arg_type ty
@@ -165,6 +168,10 @@ struct
     | OCaml String     -> ocaml_arg 1
     | OCaml Bytes      -> ocaml_arg 1
     | OCaml FloatArray -> ocaml_arg (Ctypes_primitives.sizeof Ctypes_primitive_types.Double)
+    | Value            ->
+      (fun ~offset ~idx obj dst mov ->
+         mov.(idx) <- (obj, -1); (* -1 special value *)
+         obj)
     | View { write = w; ty } ->
       (fun ~offset ~idx v dst mov -> 
          let wv = w v in
@@ -175,6 +182,15 @@ struct
           (Ctypes_ptr.Fat.(add_bytes (make ~managed:None ~reftyp:Void dst) offset));
         Obj.repr v)
 
+  let rec is_ocaml_value : type a. a Ctypes_static.typ -> bool  = function
+       | Value -> true
+       | View { ty } -> is_ocaml_value ty
+       | _ -> false
+
+  let rec return_ocaml_value : type a. a Ctypes_static.fn -> bool = function
+    | Returns (ty) -> is_ocaml_value ty
+    | Function(_,fn) -> return_ocaml_value fn
+
   (*
     callspec = allocate_callspec ()
     add_argument callspec arg1
@@ -187,9 +203,23 @@ struct
     Ctypes_ffi_stubs.callspec -> a ccallspec
     = fun ~abi ~check_errno ?(idx=0) fn callspec -> match fn with
       | 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 ~managed:None ~reftyp:Void p)))
+        (* ugly *)
+        if is_ocaml_value t then
+          let () = prep_callspec callspec abi Value in
+          let rec aux : type a. a typ -> Obj.t -> a = function
+            | Value -> (fun p -> p)
+            | View { read; ty } ->
+               let buildty = aux ty in
+               (fun p -> read (buildty p))
+            | _ -> assert false
+          in
+          Call (check_errno, aux t)
+        else
+          let () = prep_callspec callspec abi t in
+          let b = Ctypes_memory.build t in
+          Call (check_errno, (fun p ->
+              let p = (Obj.obj p : Ctypes_ptr.voidp) in
+              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
@@ -199,6 +229,7 @@ struct
     let c = Ctypes_ffi_stubs.allocate_callspec ~check_errno
       ~runtime_lock:release_runtime_lock
       ~thread_registration:false
+      ~return_ocaml_value:(return_ocaml_value fn)
     in
     let e = build_ccallspec ~abi ~check_errno fn c in
     invoke name e [] c
@@ -217,6 +248,7 @@ struct
       ~check_errno:false
       ~runtime_lock:acquire_runtime_lock
       ~thread_registration
+      ~return_ocaml_value:(return_ocaml_value fn)
     in
     let cs = box_function abi fn cs' in
     fun f ->

src/ctypes-foreign/ctypes_ffi_stubs.ml

@@ -42,7 +42,7 @@ type callspec
 
 (* Allocate a new C call specification *)
 external allocate_callspec : check_errno:bool -> runtime_lock:bool ->
-  thread_registration:bool -> callspec
+  thread_registration:bool -> return_ocaml_value:bool -> callspec
   = "ctypes_allocate_callspec"
 
 (* Add an argument to the C buffer specification *)
@@ -57,7 +57,7 @@ external prep_callspec : callspec -> int -> _ ffitype -> unit
    The callback functions write the arguments to the buffer and read
    the return value. *)
 external call : string -> (_, _ Ctypes_static.fn) Fat.t -> callspec ->
-  (voidp -> (Obj.t * int) array -> unit) -> (voidp -> 'a) -> 'a
+  (voidp -> (Obj.t * int) array -> unit) -> (Obj.t -> 'a) -> 'a
   = "ctypes_call"