Merge pull request #391 from yallop/lwt-jobs

Support for generating asynchronous bindings using Lwt jobs

.travis-ci.sh

@@ -2,7 +2,7 @@ if test $COVERAGE -a $TRAVIS_OS_NAME != osx ; then
     USE_BISECT=true;
 fi
 
-OPAM_DEPENDS="ocamlfind ounit"
+OPAM_DEPENDS="ocamlfind ounit lwt"
 if test $USE_BISECT ; then
     OPAM_DEPENDS="$OPAM_DEPENDS bisect_ppx ocveralls"
     MAKE="make COVERAGE=true"

Makefile.rules

@@ -100,11 +100,11 @@ $(BUILDDIR)/%.cmx : %.ml
 
 $(BUILDDIR)/%.o : %.c
 	@mkdir -p $(@D)
-	cd $(@D) && $(OCAMLFIND) ocamlc -c $(CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<)
+	cd $(@D) && $(OCAMLFIND) ocamlc -c $(OCAMLFIND_PACKAGE_FLAGS) $(CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<)
 
 $(BUILDDIR)/xen/%.o : %.c
 	@mkdir -p $(@D)
-	cd $(@D) && $(OCAMLFIND) ocamlc -c $(XEN_CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<)
+	cd $(@D) && $(OCAMLFIND) ocamlc -c $(OCAMLFIND_PACKAGE_FLAGS) $(XEN_CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<)
 
 $(BUILDDIR)/%.cmi : %.mli
 	@mkdir -p $(@D)

Makefile.tests

@@ -834,6 +834,47 @@ tests/test-passing-ocaml-values/generated_stubs.c: $(BUILDDIR)/test-passing-ocam
 tests/test-passing-ocaml-values/generated_bindings.ml: $(BUILDDIR)/test-passing-ocaml-values-stub-generator.native
 	$< --ml-file $@
 
+test-lwt-jobs-stubs.dir  = tests/test-lwt-jobs/stubs
+test-lwt-jobs-stubs.threads = yes
+test-lwt-jobs-stubs.subproject_deps = ctypes cstubs \
+   ctypes-foreign-base ctypes-foreign-threaded tests-common
+test-lwt-jobs-stubs: PROJECT=test-lwt-jobs-stubs
+test-lwt-jobs-stubs: $$(LIB_TARGETS)
+
+test-lwt-jobs-stub-generator.dir = tests/test-lwt-jobs/stub-generator
+test-lwt-jobs-stub-generator.threads = yes
+test-lwt-jobs-stub-generator.subproject_deps = ctypes cstubs \
+     ctypes-foreign-base ctypes-foreign-threaded test-lwt-jobs-stubs tests-common
+test-lwt-jobs-stub-generator.deps = str bigarray bytes
+test-lwt-jobs-stub-generator: PROJECT=test-lwt-jobs-stub-generator
+test-lwt-jobs-stub-generator: $$(NATIVE_TARGET)
+
+test-lwt-jobs.dir = tests/test-lwt-jobs
+test-lwt-jobs.threads = yes
+test-lwt-jobs.deps = str bigarray oUnit bytes lwt.unix
+test-lwt-jobs.subproject_deps = ctypes ctypes-foreign-base \
+   ctypes-foreign-threaded cstubs tests-common test-lwt-jobs-stubs
+test-lwt-jobs.link_flags = -L$(BUILDDIR)/clib -ltest_functions
+test-lwt-jobs: PROJECT=test-lwt-jobs
+test-lwt-jobs: $$(NATIVE_TARGET)
+
+test-lwt-jobs-generated: \
+  tests/test-lwt-jobs/generated_bindings.ml \
+  tests/test-lwt-jobs/generated_stubs.c \
+  tests/test-lwt-jobs/generated_struct_bindings.ml \
+  $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c
+
+tests/test-lwt-jobs/generated_stubs.c: $(BUILDDIR)/test-lwt-jobs-stub-generator.native
+	$< --c-file $@
+tests/test-lwt-jobs/generated_bindings.ml: $(BUILDDIR)/test-lwt-jobs-stub-generator.native
+	$< --ml-file $@
+tests/test-lwt-jobs/generated_struct_bindings.ml: $(BUILDDIR)/test-lwt-jobs-ml-stub-generator.native
+	$< > $@
+$(BUILDDIR)/test-lwt-jobs-ml-stub-generator.native: $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c
+	$(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^
+$(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c: $(BUILDDIR)/test-lwt-jobs-stub-generator.native
+	$< --c-struct-file $@
+
 test-threads-stubs.dir  = tests/test-threads/stubs
 test-threads-stubs.threads = yes
 test-threads-stubs.subproject_deps = ctypes cstubs \
@@ -882,6 +923,7 @@ TESTS += test-bigarrays-stubs test-bigarrays-stub-generator test-bigarrays-gener
 TESTS += test-coercions-stubs test-coercions-stub-generator test-coercions-generated test-coercions
 TESTS += test-roots
 TESTS += test-passing-ocaml-values-stubs test-passing-ocaml-values-stub-generator test-passing-ocaml-values-generated test-passing-ocaml-values
+TESTS += test-lwt-jobs-stubs test-lwt-jobs-stub-generator test-lwt-jobs-generated test-lwt-jobs
 TESTS += test-threads-stubs test-threads
 
 
@@ -911,5 +953,5 @@ test: build testlib tests-common $(TESTS) \
 
 run-%:	$*
 	@echo running $*
-	@cd $(BUILDDIR) && LD_LIBRARY_PATH=clib DYLD_LIBRARY_PATH=clib ./$*.native
+	@cd $(BUILDDIR) && LD_LIBRARY_PATH=clib DYLD_LIBRARY_PATH=clib ./$*.native -runner sequential
 

appveyor.yml

@@ -10,19 +10,23 @@ environment:
     matrix:
         -   WODI_ARCH: 32
             MINGW_ARCH: i686
+            WODI_FILE: https://dl.dropbox.com/sh/t9ozci9rso9gij4/AABS0ZGie-RdZDxyRaDKImWVa/wodi32.tar.xz
+            WODI_PACKAGES_FILE: https://dl.dropbox.com/sh/feldcwshtinmdo8/AAAaEK0cJoB1h6UDh4Vbvpaaa/packages32.tar.xz
         -   WODI_ARCH: 64
             MINGW_ARCH: x86_64
-
+            WODI_FILE: https://dl.dropbox.com/sh/t9ozci9rso9gij4/AADtoDkuFC9ALiLduQ73VOzla/wodi64.tar.xz
+            WODI_PACKAGES_FILE: https://dl.dropbox.com/sh/feldcwshtinmdo8/AADlqehWQ17xVWCW2GGHIo_za/packages64.tar.xz
 init:
     - 'echo System architecture: %PLATFORM%'
-    - appveyor DownloadFile "http://wodi.forge.ocamlcore.org/wodi%WODI_ARCH%.tar.xz" -FileName "C:/wodi%WODI_ARCH%.tar.xz"
+    - appveyor DownloadFile "%WODI_FILE%" -FileName "C:/wodi%WODI_ARCH%.tar.xz"
+    - appveyor DownloadFile "%WODI_PACKAGES_FILE%" -FileName "C:/packages%WODI_ARCH%.tar.xz"
 
 install:
     - if not exist "%CYG_ROOT%" mkdir "%CYG_ROOT%"
     - appveyor DownloadFile "http://cygwin.com/setup-%CYG_ARCH%.exe" -FileName "%CYG_ROOT%\setup.exe"
     - '"%CYG_ROOT%\setup.exe" -qnBWNd -R "%CYG_ROOT%" -P cygwin -P wget  -P dos2unix -P diffutils -P cpio -P make -P patch -P mingw64-%MINGW_ARCH%-gcc-core -P mingw64-%MINGW_ARCH%-gcc-g++ >NUL'
     - '%CYG_ROOT%/bin/bash -lc "cygcheck -dc cygwin"'
-    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && ./appveyor/install.sh %WODI_ARCH% %MINGW_ARCH% wodi%WODI_ARCH%.tar.xz"'
+    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && ./appveyor/install.sh %WODI_ARCH% %MINGW_ARCH% wodi%WODI_ARCH%.tar.xz packages%WODI_ARCH%.tar.xz"'
 
 build_script:
     - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && ./appveyor/build.sh %WODI_ARCH%"'

appveyor/install.sh

@@ -4,22 +4,30 @@ set -ex
 WODI_ARCH=$1
 MINGW_ARCH=$2
 WODI_FILE=$3
+WODI_PACKAGES_FILE=$4
 
 echo "WODI_ARCH: ${WODI_ARCH}"
 echo "MINGW_ARCH: ${MINGW_ARCH}"
 echo "WODI_FILE: ${WODI_FILE}"
+echo "WODI_PACKAGES_FILE: ${WODI_PACKAGES_FILE}"
 
 cp C:/${WODI_FILE} /tmp
+cp C:/${WODI_PACKAGES_FILE} /tmp
 
 pushd /tmp
 rm -rf wodi${WODI_ARCH}
 tar -xf wodi${WODI_ARCH}.tar.xz
+tar -xf packages${WODI_ARCH}.tar.xz
 
 wodi${WODI_ARCH}/install.sh
 
 godi_dir=/opt/wodi${WODI_ARCH}
+
+mkdir -p $godi_dir/var/cache/godi
+mv packages${WODI_ARCH}/* $godi_dir/var/cache/godi
+
 export PATH=$godi_dir/sbin:$godi_dir/bin:$PATH
-godi_add godi-ounit base-libffi
+godi_add godi-ounit base-libffi godi-lwt
 popd
 
 

ctypes.opam

@@ -20,6 +20,7 @@ depends: [
    "base-bytes"
    "ocamlfind" {build}
    "conf-pkg-config" {build}
+   "lwt" {test}
 ]
 depopts: [
    "ctypes-foreign"

src/cstubs/cstubs.ml

@@ -23,7 +23,9 @@ module type FOREIGN' = FOREIGN with type 'a result = unit
 
 module type BINDINGS = functor (F : FOREIGN') -> sig end
 
-let gen_c prefix fmt : (module FOREIGN') =
+type concurrency_policy = [ `Sequential | `Lwt_jobs ]
+
+let gen_c ~concurrency prefix fmt : (module FOREIGN') =
   (module
    struct
      let counter = ref 0
@@ -33,7 +35,8 @@ let gen_c prefix fmt : (module FOREIGN') =
      type 'a return = 'a
      type 'a result = unit
      let foreign cname fn =
-       Cstubs_generate_c.fn ~cname ~stub_name:(var prefix cname) fmt fn
+       Cstubs_generate_c.fn ~concurrency
+         ~cname ~stub_name:(var prefix cname) fmt fn
      let foreign_value cname typ =
        Cstubs_generate_c.value ~cname ~stub_name:(var prefix cname) fmt typ
      let returning = Ctypes.returning
@@ -43,24 +46,56 @@ let gen_c prefix fmt : (module FOREIGN') =
 type bind = Bind : string * string * ('a -> 'b) Ctypes.fn -> bind
 type val_bind = Val_bind : string * string * 'a Ctypes.typ -> val_bind
 
-let write_foreign fmt bindings val_bindings =
-  Format.fprintf fmt
-    "type 'a fn = 'a Ctypes.fn@\n";
+let write_return : concurrency:concurrency_policy -> Format.formatter -> unit =
+  fun ~concurrency fmt -> match concurrency with
+      `Sequential -> Format.fprintf fmt "type 'a return = 'a@\n"
+    | `Lwt_jobs ->
+      begin
+        Format.fprintf fmt "type 'a return = { lwt: 'a Lwt.t }@\n";
+        Format.fprintf fmt "let box_lwt lwt = {lwt}@\n";
+      end
+
+let write_fn : concurrency:concurrency_policy -> Format.formatter -> unit =
+  fun ~concurrency fmt -> match concurrency with
+      `Sequential ->
+      begin
+        Format.fprintf fmt
+          "type 'a fn = 'a CI.fn = @\n";
+        Format.fprintf fmt
+          " | Returns  : 'a CI.typ   -> 'a return fn@\n";
+        Format.fprintf fmt
+          " | Function : 'a CI.typ * 'b fn  -> ('a -> 'b) fn@\n";
+        Format.fprintf fmt
+          "let returning t = CI.Returns t@\n";
+        Format.fprintf fmt
+          "let (@@->) f p = CI.Function (f, p)@\n";
+      end
+    | `Lwt_jobs ->
+      begin
+        Format.fprintf fmt
+          "type 'a fn = @\n";
+        Format.fprintf fmt
+          " | Returns  : 'a CI.typ   -> 'a return fn@\n";
+        Format.fprintf fmt
+          " | Function : 'a CI.typ * 'b fn  -> ('a -> 'b) fn@\n";
+        Format.fprintf fmt
+          "let returning t = Returns t@\n";
+        Format.fprintf fmt
+          "let (@@->) f p = Function (f, p)@\n";
+      end
+
+let write_foreign ~concurrency fmt bindings val_bindings =
   Format.fprintf fmt
     "type 'a result = 'a@\n";
+  write_return ~concurrency fmt;
+  write_fn ~concurrency fmt;
   Format.fprintf fmt
-    "type 'a return = 'a@\n";
-  Format.fprintf fmt
-    "let returning = Ctypes.returning@\n";
-  Format.fprintf fmt
-    "let (@@->) f p = Ctypes.(f @@-> p)@\n";
-  Format.fprintf fmt
-    "let foreign : type a b. string -> (a -> b) Ctypes.fn -> (a -> b) =@\n";
+    "let foreign : type a b. string -> (a -> b) fn -> (a -> b) =@\n";
   Format.fprintf fmt
     "  fun name t -> match t, name with@\n@[<v>";
   ListLabels.iter bindings
     ~f:(fun (Bind (stub_name, external_name, fn)) ->
-      Cstubs_generate_ml.case ~stub_name ~external_name fmt fn);
+      Cstubs_generate_ml.case ~concurrency ~stub_name ~external_name fmt fn);
   Format.fprintf fmt "@[<hov 2>@[|@ _,@ s@ ->@]@ ";
   Format.fprintf fmt
     " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n";
@@ -77,7 +112,7 @@ let write_foreign fmt bindings val_bindings =
   Format.fprintf fmt
     " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n"
 
-let gen_ml prefix fmt : (module FOREIGN') * (unit -> unit) =
+let gen_ml ~concurrency prefix fmt : (module FOREIGN') * (unit -> unit) =
   let bindings = ref []
   and val_bindings = ref []
   and counter = ref 0 in
@@ -94,23 +129,36 @@ let gen_ml prefix fmt : (module FOREIGN') * (unit -> unit) =
      let foreign cname fn =
        let name = var prefix cname in
        bindings := Bind (cname, name, fn) :: !bindings;
-       Cstubs_generate_ml.extern ~stub_name:name ~external_name:name fmt fn
+       Cstubs_generate_ml.extern ~concurrency
+         ~stub_name:name ~external_name:name fmt fn
      let foreign_value cname typ =
        let name = var prefix cname in
-       Cstubs_generate_ml.extern ~stub_name:name ~external_name:name fmt
+       Cstubs_generate_ml.extern ~concurrency:`Sequential
+         ~stub_name:name ~external_name:name fmt
          Ctypes.(void @-> returning (ptr void));
        val_bindings := Val_bind (cname, name, typ) :: !val_bindings
+     let returning = Ctypes.returning
+     let (@->) = Ctypes.(@->)
    end),
   fun () ->
-    write_foreign fmt !bindings !val_bindings
+    write_foreign ~concurrency fmt !bindings !val_bindings
 
-let write_c fmt ~prefix (module B : BINDINGS) =
-  Format.fprintf fmt
-    "#include \"ctypes_cstubs_internals.h\"@\n@\n";
-  let module M = B((val gen_c prefix fmt)) in ()
+let sequential = `Sequential
+let lwt_jobs = `Lwt_jobs
+
+let headers : concurrency_policy -> string list = function
+    `Sequential -> ["\"ctypes_cstubs_internals.h\""]
+  | `Lwt_jobs ->   ["\"ctypes_cstubs_internals.h\"";
+                    "\"lwt_unix.h\"";
+                    "<errno.h>";
+                    "<caml/memory.h>"]
+
+let write_c ?(concurrency=`Sequential) fmt ~prefix (module B : BINDINGS) =
+  List.iter (Format.fprintf fmt "#include %s@\n") (headers concurrency);
+  let module M = B((val gen_c ~concurrency prefix fmt)) in ()
 
-let write_ml fmt ~prefix (module B : BINDINGS) =
-  let foreign, finally = gen_ml prefix fmt in
+let write_ml ?(concurrency=`Sequential) fmt ~prefix (module B : BINDINGS) =
+  let foreign, finally = gen_ml ~concurrency prefix fmt in
   let () = Format.fprintf fmt "module CI = Cstubs_internals@\n@\n" in
   let module M = B((val foreign)) in
   finally ()

src/cstubs/cstubs.mli

@@ -83,20 +83,58 @@ end
 
 module type BINDINGS = functor (F : FOREIGN with type 'a result = unit) -> sig end
 
-val write_c : Format.formatter -> prefix:string -> (module BINDINGS) -> unit
+type concurrency_policy
+(** Values of the [concurrency_policy] type specify the concurrency support
+    provided by the generated code.  See {!sequential} and {!lwt_jobs} for the
+    available options.
+*)
+
+val sequential : concurrency_policy
+(** Generate code with no special support for concurrency.  This is the
+    default.
+*)
+
+val lwt_jobs : concurrency_policy
+(** Generate code which implements C function calls as Lwt jobs:
+
+    http://ocsigen.org/lwt/2.5.1/api/Lwt_unix#TYPEjob
+
+    Passing [lwt_jobs] as the [concurrency] argument to {!Cstubs.write_c} and
+    {!Cstubs.write_ml} changes the return type of bound functions to include
+    the {!Lwt.t} constructor.  For example, the binding specification
+
+       [let unlink = foreign "unlink" (string @-> returning int)]
+
+    generates a value of the following type by default:
+
+       [val unlink : string -> int]
+
+    but when using [lwt_jobs] the generated type is as follows:
+
+       [val unlink : string -> int Lwt.t]
+*)
+
+val write_c : ?concurrency:concurrency_policy ->
+  Format.formatter -> prefix:string -> (module BINDINGS) -> unit
 (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound
     with [foreign] in [bindings].  The stubs are intended to be used in
     conjunction with the ML code generated by {!write_ml}.
 
+    The optional argument [concurrency] specifies the concurrency support
+    provided by the generated code.  The default is [sequential].
+
     The generated code uses definitions exposed in the header file
     [ctypes_cstubs_internals.h].
 *)
 
-val write_ml : Format.formatter -> prefix:string -> (module BINDINGS) -> unit
+val write_ml : ?concurrency:concurrency_policy ->
+  Format.formatter -> prefix:string -> (module BINDINGS) -> unit
 (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions
     bound with [foreign] in [bindings].  The generated code conforms to the
     {!FOREIGN} interface.
 
+    The optional argument [concurrency] specifies the concurrency support
+    provided by the generated code.  The default is [sequential].
+
     The generated code uses definitions exposed in the module
     [Cstubs_internals]. *)
-