add wrappers for uv_print_all_handles and uv_print_active_handles.

The API might not be stable, but it's great for debugging.

examples/copy.ml

@@ -79,4 +79,4 @@ let () =
     prerr_endline usage;
     exit 1
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/custom_c_worker.ml

@@ -15,4 +15,4 @@ let () =
   in
   Uwt.Main.run f
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/dns.ml

@@ -46,4 +46,4 @@ let () =
   in
   Uwt.Main.run t
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/help.ml

@@ -27,7 +27,7 @@ let wait () =
     ( fun () -> Lwt.pick ts )
     ( fun () -> close_all () )
 
-let clean () = Uwt.valgrind_happy ()
+let clean () = Uwt.Debug.valgrind_happy ()
 let chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
 let chars_len = String.length chars
 

examples/preemptive.ml

@@ -41,4 +41,4 @@ let () =
   Uwt.Main.run end'
 
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/spawn.ml

@@ -41,4 +41,4 @@ let () =
   let p = cat_test () in
   Uwt.Main.run p
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/timer.ml

@@ -33,4 +33,4 @@ let () =
   Uwt.Main.run (L.join [ once () ; sleep (); three_times () ])
 
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

examples/work.ml

@@ -26,4 +26,4 @@ let () =
   flush stdout;
   flush stderr
 
-let () = Uwt.valgrind_happy ()
+let () = Uwt.Debug.valgrind_happy ()

src/configure.ac

@@ -11,7 +11,7 @@ AC_MSG_CHECKING([posix source 200809L])
 AC_CHECK_HEADERS(errno.h stdint.h unistd.h errno.h limits.h sys/stat.h sys/types.h sys/socket.h fcntl.h netinet/in.h netdb.h grp.h pwd.h sys/param.h byteswap.h sys/byteswap.h sys/endian.h)
 AC_CHECK_FUNCS(strdup)
 AC_CHECK_DECLS([strnlen], [], [], [#include <string.h>])
-AC_CHECK_DECLS([uv_tcp_init_ex,uv_udp_init_ex,uv_os_homedir,uv_os_tmpdir,uv_os_get_passwd,UV_DISCONNECT,UV_TTY_MODE_NORMAL,UV_TTY_MODE_RAW,UV_TTY_MODE_IO],[],[],[#include <uv.h>])
+AC_CHECK_DECLS([uv_print_all_handles,uv_print_active_handles,uv_tcp_init_ex,uv_udp_init_ex,uv_os_homedir,uv_os_tmpdir,uv_os_get_passwd,UV_DISCONNECT,UV_TTY_MODE_NORMAL,UV_TTY_MODE_RAW,UV_TTY_MODE_IO],[],[],[#include <uv.h>])
 AC_CHECK_DECLS([uv_fs_realpath],[AC_SUBST(HAVE_UV_REALPATH,1)],[AC_SUBST(HAVE_UV_REALPATH,0)],[#include <uv.h>])
 
 AC_HEADER_STDBOOL

src/uwt.ml

@@ -1754,7 +1754,17 @@ module Valgrind = struct
 
 end
 
-let valgrind_happy = Valgrind.valgrind_happy
+module Debug = struct
+  external print_all_handles:
+    loop -> file -> Int_result.unit = "uwt_print_all_handles"
+  let print_all_handles x = print_all_handles loop x
+
+  external print_active_handles:
+    loop -> file -> Int_result.unit = "uwt_print_active_handles"
+  let print_active_handles x = print_active_handles loop x
+
+  let valgrind_happy = Valgrind.valgrind_happy
+end
 
 let () =
   Printexc.register_printer

src/uwt.mli

@@ -782,10 +782,15 @@ module C_worker : sig
 end
 
 (**/**)
-(* Only for debugging.
-   - Don't call it, while Main.run is active.
-   - After you've called it, you can't run any uwt related functions *)
-val valgrind_happy : unit -> unit
+module Debug : sig
+  val print_all_handles: file -> Int_result.unit
+  val print_active_handles: file -> Int_result.unit
+
+  (* Only for debugging.
+     - Don't call it, while Main.run is active.
+     - After you've called it, you can't run any uwt related functions *)
+  val valgrind_happy : unit -> unit
+end
 
 (* Don't use it. It's currently only intended for Uwt_preemptive. *)
 module Async : sig

src/uwt_stubs.c

@@ -2652,6 +2652,14 @@ timer_once_cb(uv_timer_t * handle)
     }                                             \
   } while(0)
 
+#define INIT_LOOP_INT_RESULT(x,y)                 \
+  struct loop * x = Loop_val(y);                  \
+  do {                                            \
+    if (unlikely( !x || x->init_called == 0 ) ){  \
+      return VAL_UWT_INT_RESULT_UWT_EFATAL;       \
+    }                                             \
+  } while(0)
+
 CAMLprim value
 uwt_timer_start(value o_loop, value o_cb,
                 value o_timeout, value o_repeat)
@@ -5499,6 +5507,59 @@ uwt_win_version(value unit)
   return ret;
 }
 #endif /* _WIN32 */
+
+#if HAVE_DECL_UV_PRINT_ALL_HANDLES || HAVE_DECL_UV_PRINT_ACTIVE_HANDLES
+typedef void(*print_handles)(uv_loop_t*, FILE*);
+static value
+uwt_print_handles(value o_loop, value o_fd, print_handles phandles)
+{
+  INIT_LOOP_INT_RESULT(l,o_loop);
+  int fd ;
+  FILE * fp;
+#ifdef _WIN32
+  fd = _dup(FD_VAL(o_fd));
+#else
+  fd = dup(FD_VAL(o_fd));
+#endif
+  if ( fd == -1 ){
+    return VAL_UWT_UNIT_RESULT(-errno);
+  }
+#ifdef _WIN32
+  fp = _fdopen(fd,"w");
+#else
+  fp = fdopen(fd,"w");
+#endif
+  if ( fp == NULL ){
+    return VAL_UWT_UNIT_RESULT(-errno);
+  }
+  phandles(&l->loop,fp);
+  if ( fclose(fp) ){
+    return(VAL_UWT_UNIT_RESULT(-errno));
+  }
+  return Val_unit;
+}
+#endif
+
+CAMLprim value
+uwt_print_all_handles(value a, value b)
+{
+#if HAVE_DECL_UV_PRINT_ALL_HANDLES
+  return uwt_print_handles(a,b,uv_print_all_handles);
+#else
+  return VAL_UWT_INT_RESULT_UWT_EUNAVAIL;
+#endif
+}
+
+CAMLprim value
+uwt_print_active_handles(value a, value b)
+{
+#if HAVE_DECL_UV_PRINT_ACTIVE_HANDLES
+  return uwt_print_handles(a,b,uv_print_active_handles);
+#else
+  return VAL_UWT_INT_RESULT_UWT_EUNAVAIL;
+#endif
+}
+
 /* }}} Misc end */
 
 /* {{{ DNS start */

src/uwt_stubs.h

@@ -188,6 +188,8 @@ P1(uwt_exepath);
 P1(uwt_cwd);
 P1(uwt_get_process_title);
 P2(uwt_set_process_title_na);
+P2(uwt_print_all_handles);
+P2(uwt_print_active_handles);
 
 P6(uwt_getaddrinfo_native);
 BY(uwt_getaddrinfo_byte);

test/main.ml

@@ -41,16 +41,33 @@ let main () =
   Unix.putenv "OUNIT_RUNNER" "sequential";
   ignore (OUnit2.run_test_tt_main ~exit:mexit tests)
 
+let cleanup () =
+  let open Lwt.Infix in
+  let t =
+    (* close callbacks are defered, remove them first *)
+    Uwt.Main.yield () >>= fun () ->
+    Uwt.Main.yield () >>= fun () ->
+    let _  : unit Uwt.uv_result = T_fs_sync.with_file
+        ~mode:Uwt.Fs.[O_CREAT;O_TRUNC;O_WRONLY]
+        "p_end.log" @@ fun fd ->
+      ignore (Uwt.Debug.print_all_handles fd);
+      Ok ()
+    in
+    Lwt.return_unit
+  in
+  Uwt.Main.run t ;
+  Uwt.Debug.valgrind_happy ()
+
 let () =
   try
     main ();
     raise (Do_exit 0)
   with
   | Do_exit i ->
     (match Sys.getenv "WITH_VALGRIND" with
+    | exception Not_found -> cleanup ()
     | "false" | "0" | "" | "FALSE" -> ()
-    | _ -> Uwt.valgrind_happy ()
-    | exception Not_found -> Uwt.valgrind_happy ());
+    | _ -> cleanup () );
     exit i
   | exn ->
     Printexc.to_string exn |> prerr_endline ;

test/t_fs_sync.mli

@@ -1 +1,6 @@
 val l: OUnitTest.test
+val with_file:
+  mode:Uwt.Fs.uv_open_flag list ->
+  string ->
+  (Uwt.file -> 'a Uwt.uv_result) ->
+  'a Uwt.uv_result

test/t_tcp.ml

@@ -231,6 +231,7 @@ let l = [
      m_raises (Uwt.EADDRINUSE,"listen","") (l sockaddr));
   ("write_allot">::
    fun ctx ->
+     let first_round = ref true in
      let l addr = with_connect_own ~addr @@ fun client ->
        let buf_len = 65_536 in
        let x = max 1 (multiplicand ctx) in
@@ -244,6 +245,31 @@ let l = [
        let sleeper,waker = Lwt.task () in
        let cb_read = function
        | Ok b ->
+         if !first_round = true then (
+           first_round := false;
+           let l = [ ("p_all.log",Uwt.Debug.print_all_handles);
+                     ("p_active.log",Uwt.Debug.print_active_handles) ] in
+           l |> List.iter @@ fun (log,f_fd) ->
+           let t1 = T_fs_sync.with_file
+               ~mode:Uwt.Fs.[O_CREAT;O_TRUNC;O_WRONLY] log @@ fun fd ->
+             let x : Uwt.Int_result.unit = f_fd fd in
+             let x = ( x :> int ) in
+             let v = Uwt.Misc.version () in
+             if Uwt.Misc.( v.minor < 8 && v.major = 1) then (
+               assert_equal (Uwt.Int_result.uwt_eunavail :> int) x;
+               Ok ()
+             )
+             else (
+               assert_equal 0 x;
+               let x = match Uv_fs_sync.stat log with
+               | Error _ -> false
+               | Ok x -> x.Uv_fs_sync.st_size > 0L in
+               assert_equal true x;
+               Ok ()
+             )
+           in
+           assert_equal t1 (Ok ())
+         );
          for i = 0 to Bytes.length b - 1 do
            if Bytes.unsafe_get b i <> Char.chr (!bytes_read land 255) then
              Lwt.wakeup_exn waker (Failure "read wrong content");