From 1c4eb0f5d2739ca8d1907efac1a2fdc3aef2638c Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Wed, 7 Dec 2022 16:02:02 +0100 Subject: [PATCH 1/2] Hardcode vendoring libuv --- src/c/dune | 45 +++++++-------------------------------------- 1 file changed, 7 insertions(+), 38 deletions(-) diff --git a/src/c/dune b/src/c/dune index ab3f9e93..9d7233ae 100644 --- a/src/c/dune +++ b/src/c/dune @@ -1,28 +1,3 @@ -(* -*- tuareg -*- *) - -let foreign_archives, uv_library_flag, include_dirs, i_option, install_h = - let use_system_libuv = - match Sys.getenv "LUV_USE_SYSTEM_LIBUV" with - | "yes" -> true - | _ -> false - | exception Not_found -> false - in - - if use_system_libuv then - "", - "-luv", - "", - "", - false - else - "(foreign_archives uv)", - "", - "(include_dirs vendor/libuv/include)", - "-I vendor/libuv/include", - true - -let () = Jbuild_plugin.V1.send @@ {| - ; The final FFI module, containing all the OCaml bits, and linked with libuv. (library (name luv_c) @@ -33,11 +8,10 @@ let () = Jbuild_plugin.V1.send @@ {| (foreign_stubs (language c) (names c_generated_functions helpers) - |}^ include_dirs ^{|) - |}^ foreign_archives ^{| - (c_library_flags |}^ uv_library_flag ^{| (:include extra_libs.sexp))) - -|}^ (if not install_h then "" else {| + (include_dirs vendor/libuv/include) + ) + (foreign_archives uv) + (c_library_flags (:include extra_libs.sexp))) (install (section lib) @@ -60,10 +34,6 @@ let () = Jbuild_plugin.V1.send @@ {| (vendor/libuv/include/uv/version.h as uv/version.h) (vendor/libuv/include/uv/win.h as uv/win.h))) -|}) ^{| - - - ; The vendored libuv. (rule (targets libuv.a dlluv%{ext_dll}) @@ -126,12 +96,13 @@ let () = Jbuild_plugin.V1.send @@ {| %{cc} %{c} \ -I '%{lib:ctypes:.}' \ -I %{ocaml_where} \ - |}^ i_option ^{| /Fe\"%{targets}\"; \ + -I vendor/libuv/include + /Fe\"%{targets}\"; \ else \ %{cc} %{c} \ -I '%{lib:ctypes:.}' \ -I %{ocaml_where} \ - |}^ i_option ^{| -o %{targets}; \ + -I vendor/libuv/include -o %{targets}; \ fi"))) (rule @@ -164,5 +135,3 @@ let () = Jbuild_plugin.V1.send @@ {| (rule (with-stdout-to luv_c_generated_functions.ml (run ./generate_ml_functions.exe luv_stub))) - -|} From ecafee59698ee2973158733fa5fea0270251b8ae Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Wed, 14 Dec 2022 12:10:59 +0100 Subject: [PATCH 2/2] ctypes port (WIP) --- dune-project | 4 +- src/c.ml | 10 +- src/c/{ => attic}/generate_c_functions.ml | 0 src/c/{ => attic}/generate_ml_functions.ml | 0 src/c/{ => attic}/generate_types_start.ml | 0 src/c/{ => attic}/luv_c_types.ml | 0 src/c/blocking.ml | 424 +++++++++++++++++ src/c/dune | 203 ++++---- ...nction_descriptions.ml => non_blocking.ml} | 436 +----------------- .../{luv_c_type_descriptions.ml => types.ml} | 2 +- src/feature/detect_features.ml | 2 +- src/unix/dune | 2 +- 12 files changed, 548 insertions(+), 535 deletions(-) rename src/c/{ => attic}/generate_c_functions.ml (100%) rename src/c/{ => attic}/generate_ml_functions.ml (100%) rename src/c/{ => attic}/generate_types_start.ml (100%) rename src/c/{ => attic}/luv_c_types.ml (100%) create mode 100644 src/c/blocking.ml rename src/c/{luv_c_function_descriptions.ml => non_blocking.ml} (75%) rename src/c/{luv_c_type_descriptions.ml => types.ml} (99%) diff --git a/dune-project b/dune-project index 929c696e..b5f5f5d0 100644 --- a/dune-project +++ b/dune-project @@ -1 +1,3 @@ -(lang dune 2.0) +(lang dune 3.7) + +(using ctypes 0.3) diff --git a/src/c.ml b/src/c.ml index 8c0e11c2..2c6901a5 100644 --- a/src/c.ml +++ b/src/c.ml @@ -3,10 +3,6 @@ -module Types = Luv_c_types -module Functions = - Luv_c_function_descriptions.Descriptions - (Luv_c_generated_functions.Non_blocking) -module Blocking = - Luv_c_function_descriptions.Blocking - (Luv_c_generated_functions.Blocking) +module Types = Luv_c.Types_generated +module Functions = Luv_c.Luv_c_generated.Non_blocking_inst +module Blocking = Luv_c.Luv_c_generated.Blocking_inst diff --git a/src/c/generate_c_functions.ml b/src/c/attic/generate_c_functions.ml similarity index 100% rename from src/c/generate_c_functions.ml rename to src/c/attic/generate_c_functions.ml diff --git a/src/c/generate_ml_functions.ml b/src/c/attic/generate_ml_functions.ml similarity index 100% rename from src/c/generate_ml_functions.ml rename to src/c/attic/generate_ml_functions.ml diff --git a/src/c/generate_types_start.ml b/src/c/attic/generate_types_start.ml similarity index 100% rename from src/c/generate_types_start.ml rename to src/c/attic/generate_types_start.ml diff --git a/src/c/luv_c_types.ml b/src/c/attic/luv_c_types.ml similarity index 100% rename from src/c/luv_c_types.ml rename to src/c/attic/luv_c_types.ml diff --git a/src/c/blocking.ml b/src/c/blocking.ml new file mode 100644 index 00000000..a0b60bb1 --- /dev/null +++ b/src/c/blocking.ml @@ -0,0 +1,424 @@ +module Types = Types_generated + +(* We want to be able to call some of the libuv functions with the OCaml runtime + lock released, in some circumstances. For that, we have Ctypes generate + separate stubs that release the lock. + + However, releasing the lock is not possible for some kinds of arguments. So, + we can't blindly generate lock-releasing and lock-retaining versions of each + binding. + + Instead, we group the lock-releasing bindings in this module [Blocking]. *) +module Functions (F : Ctypes.FOREIGN) = +struct + open Ctypes + open F + + let error_code = int + + module Loop = + struct + let run = + foreign "uv_run" + (ptr Types.Loop.t @-> Types.Loop.Run_mode.t @-> returning bool) + end + + (* See https://github.com/ocsigen/lwt/issues/230. *) + module Pipe = + struct + let bind = + foreign "uv_pipe_bind" + (ptr Types.Pipe.t @-> string @-> returning error_code) + end + + (* Synchronous (callback = NULL) calls to these functions are blocking, so we + have to release the OCaml runtime lock. Technically, asychronous calls are + non-blocking, and we don't have to release the lock. However, supporting + both variants would take a bit of extra code to implement, so it's best to + see if there is a need. For now, we release the runtime lock during the + asychronous calls as well. *) + module File = + struct + let t = int + let uid = int + let gid = int + let request = Types.File.Request.t + + type trampoline = (Types.File.Request.t ptr -> unit) static_funptr + + let trampoline : trampoline typ = + static_funptr + Ctypes.(ptr request @-> returning void) + + let get_trampoline = + foreign "luv_get_fs_trampoline" + (void @-> returning trampoline) + + let get_null_callback = + foreign "luv_null_fs_callback_pointer" + (void @-> returning trampoline) + + let req_cleanup = + foreign "uv_fs_req_cleanup" + (ptr request @-> returning void) + + let close = + foreign "uv_fs_close" + (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> + returning error_code) + + let open_ = + foreign "uv_fs_open" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + int @-> + int @-> + trampoline @-> + returning error_code) + + let read = + foreign "uv_fs_read" + (ptr Types.Loop.t @-> + ptr request @-> + t @-> + ptr Types.Buf.t @-> + uint @-> + int64_t @-> + trampoline @-> + returning error_code) + + let write = + foreign "uv_fs_write" + (ptr Types.Loop.t @-> + ptr request @-> + t @-> + ptr Types.Buf.t @-> + uint @-> + int64_t @-> + trampoline @-> + returning error_code) + + let unlink = + foreign "uv_fs_unlink" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let mkdir = + foreign "uv_fs_mkdir" + (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> + returning error_code) + + let mkdtemp = + foreign "uv_fs_mkdtemp" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let mkstemp = + foreign "uv_fs_mkstemp" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let rmdir = + foreign "uv_fs_rmdir" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let opendir = + foreign "uv_fs_opendir" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let closedir = + foreign "uv_fs_closedir" + (ptr Types.Loop.t @-> + ptr request @-> + ptr Types.File.Dir.t @-> + trampoline @-> + returning error_code) + + let readdir = + foreign "uv_fs_readdir" + (ptr Types.Loop.t @-> + ptr request @-> + ptr Types.File.Dir.t @-> + trampoline @-> + returning error_code) + + let scandir = + foreign "uv_fs_scandir" + (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> + returning error_code) + + let scandir_next = + foreign "uv_fs_scandir_next" + (ptr request @-> ptr Types.File.Dirent.t @-> returning error_code) + + let stat = + foreign "uv_fs_stat" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let lstat = + foreign "uv_fs_lstat" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let fstat = + foreign "uv_fs_fstat" + (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> + returning error_code) + + let statfs = + foreign "uv_fs_statfs" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let rename = + foreign "uv_fs_rename" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + string @-> + trampoline @-> + returning error_code) + + let fsync = + foreign "uv_fs_fsync" + (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> + returning error_code) + + let fdatasync = + foreign "uv_fs_fdatasync" + (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> + returning error_code) + + let ftruncate = + foreign "uv_fs_ftruncate" + (ptr Types.Loop.t @-> ptr request @-> t @-> int64_t @-> trampoline @-> + returning error_code) + + let copyfile = + foreign "uv_fs_copyfile" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + string @-> + int @-> + trampoline @-> + returning error_code) + + let sendfile = + foreign "uv_fs_sendfile" + (ptr Types.Loop.t @-> + ptr request @-> + t @-> + t @-> + int64_t @-> + size_t @-> + trampoline @-> + returning error_code) + + let access = + foreign "uv_fs_access" + (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> + returning error_code) + + let chmod = + foreign "uv_fs_chmod" + (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> + returning error_code) + + let fchmod = + foreign "uv_fs_fchmod" + (ptr Types.Loop.t @-> ptr request @-> t @-> int @-> trampoline @-> + returning error_code) + + let utime = + foreign "uv_fs_utime" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + float @-> + float @-> + trampoline @-> + returning error_code) + + let futime = + foreign "uv_fs_futime" + (ptr Types.Loop.t @-> + ptr request @-> + t @-> + float @-> + float @-> + trampoline @-> + returning error_code) + + let lutime = + foreign "uv_fs_lutime" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + float @-> + float @-> + trampoline @-> + returning error_code) + + let link = + foreign "uv_fs_link" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + string @-> + trampoline @-> + returning error_code) + + let symlink = + foreign "uv_fs_symlink" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + string @-> + int @-> + trampoline @-> + returning error_code) + + let readlink = + foreign "uv_fs_readlink" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let realpath = + foreign "uv_fs_realpath" + (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> + returning error_code) + + let chown = + foreign "uv_fs_chown" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + uid @-> + gid @-> + trampoline @-> + returning error_code) + + let fchown = + foreign "uv_fs_fchown" + (ptr Types.Loop.t @-> + ptr request @-> + t @-> + uid @-> + gid @-> + trampoline @-> + returning error_code) + + let lchown = + foreign "uv_fs_lchown" + (ptr Types.Loop.t @-> + ptr request @-> + string @-> + uid @-> + gid @-> + trampoline @-> + returning error_code) + + let get_result = + foreign "uv_fs_get_result" + (ptr request @-> returning PosixTypes.ssize_t) + + let get_ptr = + foreign "uv_fs_get_ptr" + (ptr request @-> returning (ptr void)) + + let get_ptr_as_string = + foreign "uv_fs_get_ptr" + (ptr request @-> returning string) + + let get_path = + foreign "luv_fs_get_path" + (ptr request @-> returning string) + + let get_statbuf = + foreign "uv_fs_get_statbuf" + (ptr request @-> returning (ptr Types.File.Stat.t)) + end + + module Thread = + struct + let join = + foreign "uv_thread_join" + (ptr Types.Thread.t @-> returning error_code) + end + + module Mutex = + struct + let lock = + foreign "uv_mutex_lock" + (ptr Types.Mutex.t @-> returning void) + end + + module Rwlock = + struct + let rdlock = + foreign "uv_rwlock_rdlock" + (ptr Types.Rwlock.t @-> returning void) + + let wrlock = + foreign "uv_rwlock_wrlock" + (ptr Types.Rwlock.t @-> returning void) + end + + module Semaphore = + struct + let wait = + foreign "uv_sem_wait" + (ptr Types.Semaphore.t @-> returning void) + end + + module Condition = + struct + let wait = + foreign "uv_cond_wait" + (ptr Types.Condition.t @-> ptr Types.Mutex.t @-> returning void) + + let timedwait = + foreign "uv_cond_timedwait" + (ptr Types.Condition.t @-> ptr Types.Mutex.t @-> uint64_t @-> + returning error_code) + end + + module Barrier = + struct + let wait = + foreign "uv_barrier_wait" + (ptr Types.Barrier.t @-> returning bool) + end + + module Time = + struct + let sleep = + foreign "uv_sleep" + (int @-> returning void) + end + + module Random = + struct + let request = Types.Random.Request.t + + let trampoline = + static_funptr + Ctypes.(ptr request @-> error_code @-> ptr void @-> size_t @-> + returning void) + + let random = + foreign "uv_random" + (ptr Types.Loop.t @-> + ptr request @-> + ptr char @-> + size_t @-> + uint @-> + trampoline @-> + returning error_code) + end +end diff --git a/src/c/dune b/src/c/dune index 9d7233ae..97b819fb 100644 --- a/src/c/dune +++ b/src/c/dune @@ -1,17 +1,39 @@ ; The final FFI module, containing all the OCaml bits, and linked with libuv. + (library (name luv_c) (public_name luv.c) - (wrapped false) - (modules Luv_c_generated_functions) - (libraries ctypes luv_c_function_descriptions threads) + ;(modules Generated_entry_point) + (libraries + ctypes + ;luv_c_function_descriptions + threads) (foreign_stubs (language c) - (names c_generated_functions helpers) - (include_dirs vendor/libuv/include) - ) + (names helpers) + (include_dirs vendor/libuv/include)) (foreign_archives uv) - (c_library_flags (:include extra_libs.sexp))) + (ctypes + (build_flags_resolver + (vendored + (c_library_flags + :standard + (:include extra_libs.sexp)) + (c_flags :standard -I vendor/libuv/include -I .))) + (external_library_name libuv) + (type_description + (instance Luv_c_types) + (functor Types)) + (function_description + (concurrency unlocked) + (functor Blocking) + (instance Blocking_inst)) + (function_description + (functor Non_blocking) + (instance Non_blocking_inst)) + (generated_entry_point Luv_c_generated) + (headers + (include :standard uv.h helpers.h)))) (install (section lib) @@ -35,103 +57,104 @@ (vendor/libuv/include/uv/win.h as uv/win.h))) ; The vendored libuv. + (rule (targets libuv.a dlluv%{ext_dll}) - (deps (source_tree vendor)) - (action (progn - (bash "cp -r vendor/configure/* vendor/libuv/") - (chdir vendor/libuv (progn - (bash - "sh configure --host `ocamlc -config | awk '/host/ {print $NF}'` \ - 'CC=%{cc}' CFLAGS=-DNDEBUG --silent --enable-silent-rules") - (ignore-outputs (bash - "$([ '%{os_type}' = Unix ] && echo %{make} || echo make) V=0 -j 4 \ - -o aclocal.m4 -o Makefile.in -o configure \ - -o configure.status -o Makefile libuv.la")) - (ignore-outputs (bash - "sh libtool --silent --no-warnings --mode install cp libuv.la `pwd`")))) - (bash "cp vendor/libuv/libuv.a .") - (ignore-outputs (bash - "cp vendor/libuv/libuv.so.1.0.0 dlluv.so || \ - cp vendor/libuv/libuv.1.dylib dlluv.so || \ - cp vendor/bin/libuv-1.dll dlluv.dll"))))) + (deps + (source_tree vendor)) + (action + (progn + (bash "cp -r vendor/configure/* vendor/libuv/") + (chdir + vendor/libuv + (progn + (bash + "sh configure --host `ocamlc -config | awk '/host/ {print $NF}'` 'CC=%{cc}' CFLAGS=-DNDEBUG --silent --enable-silent-rules") + (ignore-outputs + (bash + "$([ '%{os_type}' = Unix ] && echo %{make} || echo make) V=0 -j 4 -o aclocal.m4 -o Makefile.in -o configure -o configure.status -o Makefile libuv.la")) + (ignore-outputs + (bash + "sh libtool --silent --no-warnings --mode install cp libuv.la `pwd`")))) + (bash "cp vendor/libuv/libuv.a .") + (ignore-outputs + (bash + "cp vendor/libuv/libuv.so.1.0.0 dlluv.so || cp vendor/libuv/libuv.1.dylib dlluv.so || cp vendor/bin/libuv-1.dll dlluv.dll"))))) + +; (rule (targets extra_libs.sexp) - (action (ignore-outputs (bash "\ - if ocamlc -config | grep mingw; then \ - echo '(-liphlpapi -lpsapi -luserenv)' > extra_libs.sexp; \ - else \ - echo '()' > extra_libs.sexp; \ - fi")))) - - + (action + (ignore-outputs + (bash + "if ocamlc -config | grep mingw; then echo '(-liphlpapi -lpsapi -luserenv)' > extra_libs.sexp; else echo '()' > extra_libs.sexp; fi")))) ; Everything below is the bindings generation process using ctypes. It produces ; two OCaml modules, Luv_c_generated_functions and Luv_c_generated_types. ; Type bindings (Luv_c_generated_types). -(library - (name luv_c_type_descriptions) - (public_name luv.c_type_descriptions) - (modules Luv_c_type_descriptions) - (libraries ctypes)) +;(library +;(name luv_c_type_descriptions) +;(public_name luv.c_type_descriptions) +;(modules Luv_c_type_descriptions) +;(libraries ctypes)) -(executable - (name generate_types_start) - (modules Generate_types_start) - (libraries ctypes.stubs luv_c_type_descriptions)) +;(executable +; (name generate_types_start) +; (modules Generate_types_start) +; (libraries ctypes.stubs )) -(rule - (with-stdout-to generate_types_step_2.c - (run ./generate_types_start.exe))) +;(rule +; (with-stdout-to generate_types_step_2.c +; (run ./generate_types_start.exe))) ; Based partially on ; https://github.com/avsm/ocaml-yaml/blob/master/types/stubgen/jbuild#L20 -(rule - (targets generate_types_step_2.exe) - (deps (:c generate_types_step_2.c) helpers.h shims.h) - (action (bash "\ - if [ '%{ocaml-config:ccomp_type}' = 'msvc' ]; then \ - %{cc} %{c} \ - -I '%{lib:ctypes:.}' \ - -I %{ocaml_where} \ - -I vendor/libuv/include - /Fe\"%{targets}\"; \ - else \ - %{cc} %{c} \ - -I '%{lib:ctypes:.}' \ - -I %{ocaml_where} \ - -I vendor/libuv/include -o %{targets}; \ - fi"))) - -(rule - (with-stdout-to luv_c_generated_types.ml - (run ./generate_types_step_2.exe))) +;(rule +; (targets generate_types_step_2.exe) +; (deps (:c generate_types_step_2.c) helpers.h shims.h) +; (action (bash "\ +; if [ '%{ocaml-config:ccomp_type}' = 'msvc' ]; then \ +; %{cc} %{c} \ +; -I '%{lib:ctypes:.}' \ +; -I %{ocaml_where} \ +; -I vendor/libuv/include +; /Fe\"%{targets}\"; \ +; else \ +; %{cc} %{c} \ +; -I '%{lib:ctypes:.}' \ +; -I %{ocaml_where} \ +; -I vendor/libuv/include -o %{targets}; \ +; fi"))) + +;(rule +; (with-stdout-to luv_c_generated_types.ml +; (run ./generate_types_step_2.exe))) ; Function bindings. -(library - (name luv_c_function_descriptions) - (public_name luv.c_function_descriptions) - (flags (:standard -w -9-16-27)) - (wrapped false) - (modules Luv_c_generated_types Luv_c_function_descriptions Luv_c_types) - (libraries ctypes luv_c_type_descriptions)) - -(executable - (name generate_c_functions) - (modules Generate_c_functions) - (libraries ctypes.stubs luv_c_function_descriptions)) - -(executable - (name generate_ml_functions) - (modules Generate_ml_functions) - (libraries ctypes.stubs luv_c_function_descriptions)) - -(rule - (with-stdout-to c_generated_functions.c - (run ./generate_c_functions.exe luv_stub))) - -(rule - (with-stdout-to luv_c_generated_functions.ml - (run ./generate_ml_functions.exe luv_stub))) +;(library +; (name luv_c_function_descriptions) +; (public_name luv.c_function_descriptions) +; (flags (:standard -w -9-16-27)) +; (wrapped false) +; (modules Luv_c_generated_types Luv_c_function_descriptions Luv_c_types) +; (libraries ctypes )) +; +;(executable +; (name generate_c_functions) +; (modules Generate_c_functions) +; (libraries ctypes.stubs luv_c_function_descriptions)) +; +;(executable +; (name generate_ml_functions) +; (modules Generate_ml_functions) +; (libraries ctypes.stubs luv_c_function_descriptions)) +; +;(rule +; (with-stdout-to c_generated_functions.c +; (run ./generate_c_functions.exe luv_stub))) +; +;(rule +; (with-stdout-to luv_c_generated_functions.ml +; (run ./generate_ml_functions.exe luv_stub))) diff --git a/src/c/luv_c_function_descriptions.ml b/src/c/non_blocking.ml similarity index 75% rename from src/c/luv_c_function_descriptions.ml rename to src/c/non_blocking.ml index 24d6fa45..35942e5a 100644 --- a/src/c/luv_c_function_descriptions.ml +++ b/src/c/non_blocking.ml @@ -1,438 +1,6 @@ -(* This file is part of Luv, released under the MIT license. See LICENSE.md for - details, or visit https://github.com/aantron/luv/blob/master/LICENSE.md. *) +module Types = Types_generated - - -(* Everything is in one file to cut down on Dune boilerplate, as it would grow - proportionally in the number of files the bindings are spread over. - https://github.com/ocaml/dune/issues/135. *) - -module Types = Luv_c_types - -(* We want to be able to call some of the libuv functions with the OCaml runtime - lock released, in some circumstances. For that, we have Ctypes generate - separate stubs that release the lock. - - However, releasing the lock is not possible for some kinds of arguments. So, - we can't blindly generate lock-releasing and lock-retaining versions of each - binding. - - Instead, we group the lock-releasing bindings in this module [Blocking]. *) -module Blocking (F : Ctypes.FOREIGN) = -struct - open Ctypes - open F - - let error_code = int - - module Loop = - struct - let run = - foreign "uv_run" - (ptr Types.Loop.t @-> Types.Loop.Run_mode.t @-> returning bool) - end - - (* See https://github.com/ocsigen/lwt/issues/230. *) - module Pipe = - struct - let bind = - foreign "uv_pipe_bind" - (ptr Types.Pipe.t @-> string @-> returning error_code) - end - - (* Synchronous (callback = NULL) calls to these functions are blocking, so we - have to release the OCaml runtime lock. Technically, asychronous calls are - non-blocking, and we don't have to release the lock. However, supporting - both variants would take a bit of extra code to implement, so it's best to - see if there is a need. For now, we release the runtime lock during the - asychronous calls as well. *) - module File = - struct - let t = int - let uid = int - let gid = int - let request = Types.File.Request.t - - type trampoline = (Types.File.Request.t ptr -> unit) static_funptr - - let trampoline : trampoline typ = - static_funptr - Ctypes.(ptr request @-> returning void) - - let get_trampoline = - foreign "luv_get_fs_trampoline" - (void @-> returning trampoline) - - let get_null_callback = - foreign "luv_null_fs_callback_pointer" - (void @-> returning trampoline) - - let req_cleanup = - foreign "uv_fs_req_cleanup" - (ptr request @-> returning void) - - let close = - foreign "uv_fs_close" - (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> - returning error_code) - - let open_ = - foreign "uv_fs_open" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - int @-> - int @-> - trampoline @-> - returning error_code) - - let read = - foreign "uv_fs_read" - (ptr Types.Loop.t @-> - ptr request @-> - t @-> - ptr Types.Buf.t @-> - uint @-> - int64_t @-> - trampoline @-> - returning error_code) - - let write = - foreign "uv_fs_write" - (ptr Types.Loop.t @-> - ptr request @-> - t @-> - ptr Types.Buf.t @-> - uint @-> - int64_t @-> - trampoline @-> - returning error_code) - - let unlink = - foreign "uv_fs_unlink" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let mkdir = - foreign "uv_fs_mkdir" - (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> - returning error_code) - - let mkdtemp = - foreign "uv_fs_mkdtemp" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let mkstemp = - foreign "uv_fs_mkstemp" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let rmdir = - foreign "uv_fs_rmdir" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let opendir = - foreign "uv_fs_opendir" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let closedir = - foreign "uv_fs_closedir" - (ptr Types.Loop.t @-> - ptr request @-> - ptr Types.File.Dir.t @-> - trampoline @-> - returning error_code) - - let readdir = - foreign "uv_fs_readdir" - (ptr Types.Loop.t @-> - ptr request @-> - ptr Types.File.Dir.t @-> - trampoline @-> - returning error_code) - - let scandir = - foreign "uv_fs_scandir" - (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> - returning error_code) - - let scandir_next = - foreign "uv_fs_scandir_next" - (ptr request @-> ptr Types.File.Dirent.t @-> returning error_code) - - let stat = - foreign "uv_fs_stat" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let lstat = - foreign "uv_fs_lstat" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let fstat = - foreign "uv_fs_fstat" - (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> - returning error_code) - - let statfs = - foreign "uv_fs_statfs" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let rename = - foreign "uv_fs_rename" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - string @-> - trampoline @-> - returning error_code) - - let fsync = - foreign "uv_fs_fsync" - (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> - returning error_code) - - let fdatasync = - foreign "uv_fs_fdatasync" - (ptr Types.Loop.t @-> ptr request @-> t @-> trampoline @-> - returning error_code) - - let ftruncate = - foreign "uv_fs_ftruncate" - (ptr Types.Loop.t @-> ptr request @-> t @-> int64_t @-> trampoline @-> - returning error_code) - - let copyfile = - foreign "uv_fs_copyfile" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - string @-> - int @-> - trampoline @-> - returning error_code) - - let sendfile = - foreign "uv_fs_sendfile" - (ptr Types.Loop.t @-> - ptr request @-> - t @-> - t @-> - int64_t @-> - size_t @-> - trampoline @-> - returning error_code) - - let access = - foreign "uv_fs_access" - (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> - returning error_code) - - let chmod = - foreign "uv_fs_chmod" - (ptr Types.Loop.t @-> ptr request @-> string @-> int @-> trampoline @-> - returning error_code) - - let fchmod = - foreign "uv_fs_fchmod" - (ptr Types.Loop.t @-> ptr request @-> t @-> int @-> trampoline @-> - returning error_code) - - let utime = - foreign "uv_fs_utime" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - float @-> - float @-> - trampoline @-> - returning error_code) - - let futime = - foreign "uv_fs_futime" - (ptr Types.Loop.t @-> - ptr request @-> - t @-> - float @-> - float @-> - trampoline @-> - returning error_code) - - let lutime = - foreign "uv_fs_lutime" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - float @-> - float @-> - trampoline @-> - returning error_code) - - let link = - foreign "uv_fs_link" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - string @-> - trampoline @-> - returning error_code) - - let symlink = - foreign "uv_fs_symlink" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - string @-> - int @-> - trampoline @-> - returning error_code) - - let readlink = - foreign "uv_fs_readlink" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let realpath = - foreign "uv_fs_realpath" - (ptr Types.Loop.t @-> ptr request @-> string @-> trampoline @-> - returning error_code) - - let chown = - foreign "uv_fs_chown" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - uid @-> - gid @-> - trampoline @-> - returning error_code) - - let fchown = - foreign "uv_fs_fchown" - (ptr Types.Loop.t @-> - ptr request @-> - t @-> - uid @-> - gid @-> - trampoline @-> - returning error_code) - - let lchown = - foreign "uv_fs_lchown" - (ptr Types.Loop.t @-> - ptr request @-> - string @-> - uid @-> - gid @-> - trampoline @-> - returning error_code) - - let get_result = - foreign "uv_fs_get_result" - (ptr request @-> returning PosixTypes.ssize_t) - - let get_ptr = - foreign "uv_fs_get_ptr" - (ptr request @-> returning (ptr void)) - - let get_ptr_as_string = - foreign "uv_fs_get_ptr" - (ptr request @-> returning string) - - let get_path = - foreign "luv_fs_get_path" - (ptr request @-> returning string) - - let get_statbuf = - foreign "uv_fs_get_statbuf" - (ptr request @-> returning (ptr Types.File.Stat.t)) - end - - module Thread = - struct - let join = - foreign "uv_thread_join" - (ptr Types.Thread.t @-> returning error_code) - end - - module Mutex = - struct - let lock = - foreign "uv_mutex_lock" - (ptr Types.Mutex.t @-> returning void) - end - - module Rwlock = - struct - let rdlock = - foreign "uv_rwlock_rdlock" - (ptr Types.Rwlock.t @-> returning void) - - let wrlock = - foreign "uv_rwlock_wrlock" - (ptr Types.Rwlock.t @-> returning void) - end - - module Semaphore = - struct - let wait = - foreign "uv_sem_wait" - (ptr Types.Semaphore.t @-> returning void) - end - - module Condition = - struct - let wait = - foreign "uv_cond_wait" - (ptr Types.Condition.t @-> ptr Types.Mutex.t @-> returning void) - - let timedwait = - foreign "uv_cond_timedwait" - (ptr Types.Condition.t @-> ptr Types.Mutex.t @-> uint64_t @-> - returning error_code) - end - - module Barrier = - struct - let wait = - foreign "uv_barrier_wait" - (ptr Types.Barrier.t @-> returning bool) - end - - module Time = - struct - let sleep = - foreign "uv_sleep" - (int @-> returning void) - end - - module Random = - struct - let request = Types.Random.Request.t - - let trampoline = - static_funptr - Ctypes.(ptr request @-> error_code @-> ptr void @-> size_t @-> - returning void) - - let random = - foreign "uv_random" - (ptr Types.Loop.t @-> - ptr request @-> - ptr char @-> - size_t @-> - uint @-> - trampoline @-> - returning error_code) - end -end - -module Descriptions (F : Ctypes.FOREIGN) = +module Functions (F : Ctypes.FOREIGN) = struct open Ctypes open F diff --git a/src/c/luv_c_type_descriptions.ml b/src/c/types.ml similarity index 99% rename from src/c/luv_c_type_descriptions.ml rename to src/c/types.ml index 438b6177..adf5a765 100644 --- a/src/c/luv_c_type_descriptions.ml +++ b/src/c/types.ml @@ -7,7 +7,7 @@ proportionally in the number of files the bindings are spread over. https://github.com/ocaml/dune/issues/135. *) -module Descriptions (F : Ctypes.TYPE) = +module Types (F : Ctypes.TYPE) = struct open Ctypes open F diff --git a/src/feature/detect_features.ml b/src/feature/detect_features.ml index c330abe0..62fb1246 100644 --- a/src/feature/detect_features.ml +++ b/src/feature/detect_features.ml @@ -215,7 +215,7 @@ let () = let ml_buffer = Buffer.create 4096 in fixed_ml max_int ml_buffer; - let version = Luv_c_types.Version.minor in + let version = Luv_c.Types_generated.Version.minor in let context = mli_buffer, ml_buffer in let int = int context in diff --git a/src/unix/dune b/src/unix/dune index 9e7fe97d..dc9d5e43 100644 --- a/src/unix/dune +++ b/src/unix/dune @@ -1,5 +1,5 @@ (library (public_name luv_unix) (libraries luv luv.c result unix) - (foreign_stubs (language c) (names luv_unix)) + (foreign_stubs (language c) (names luv_unix) (include_dirs ../c/vendor/libuv/include)) (flags (:standard -w -49 -open Result)))