PR#4023 and GPR#68: add Unix.sleepf and improve Unix.sleep

Unix.sleepf provides sleep with sub-second resolution.
Unix.sleep is implemented on top of Unix.sleepf.
If a handled signal causes the sleep to return early with an EINTR
error, catch it and restart the sleep for the remaining time.

6 files changed, 63 insertions, 7 deletions

diff --git a/Changes b/Changes
index d5857cb89e..b673fe96b8 100644
--- a/Changes
+++ b/Changes
@@ -174,6 +174,12 @@ Toplevel and debugger:
    review by Gabriel Scherer and Jacques-Henri Jourdan)
 
 Other libraries:
+- PR#4023 and GPR#68: add Unix.sleepf (sleep with sub-second resolution)
+  (Evgenii Lepikhin and Xavier Leroy)
+* Protect Unix.sleep against interruptions by handled signals.
+  Before, a handled signal could cause Unix.sleep to return early.
+  Now, the sleep is restarted until the given time is elapsed.
+  (Xavier Leroy)
 - PR#6896: serious reimplementation of Big_int.float_of_big_int and
   Ratio.float_of_ratio, ensuring that the result is correctly rounded.
   (Xavier Leroy)
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index a39c5f829d..4a83396085 100644
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -15,10 +15,55 @@
 #include <caml/signals.h>
 #include "unixsupport.h"
 
-CAMLprim value unix_sleep(value t)
+#include <errno.h>
+#include <time.h>
+#ifdef HAS_SELECT
+#include <sys/types.h>
+#include <sys/time.h>
+#ifdef HAS_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+#endif
+
+CAMLprim value unix_sleep(value duration)
 {
-  enter_blocking_section();
-  sleep(Int_val(t));
-  leave_blocking_section();
+  double d = Double_val(duration);
+  if (d <= 0.0) return Val_unit;
+#if _POSIX_C_SOURCE >= 199309L
+  {
+    struct timespec t;
+    int ret;
+    enter_blocking_section();
+    t.tv_sec = (time_t) d;
+    t.tv_nsec = (d - t.tv_sec) * 1e9;
+    do {
+      ret = nanosleep(&t, &t);
+    } while (ret == -1 && errno == EINTR);
+    leave_blocking_section();
+    if (ret == -1) uerror("sleep", Nothing);
+  }
+#elif defined(HAS_SELECT)
+  {
+    struct timeval t;
+    int ret;
+    enter_blocking_section();
+    t.tv_sec = (time_t) d;
+    t.tv_usec = (d - t.tv_sec) * 1e6;
+    do {
+      ret = select(0, NULL, NULL, NULL, &t);
+    } while (ret == -1 && errno == EINTR);
+    leave_blocking_section();
+    if (ret == -1) uerror("sleep", Nothing);
+  }
+#else
+  /* Fallback implementation, resolution 1 second only.
+     We cannot reliably iterate until sleep() returns 0, because the
+     remaining time returned by sleep() is generally rounded up. */
+  {
+    enter_blocking_section();
+    sleep ((unsigned int) d);
+    leave_blocking_section();
+  }
+#endif
   return Val_unit;
 }
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index d18b338adb..9e0f4cf832 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -427,7 +427,8 @@ external gmtime : float -> tm = "unix_gmtime"
 external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
 external alarm : int -> int = "unix_alarm"
-external sleep : int -> unit = "unix_sleep"
+external sleepf : float -> unit = "unix_sleep"
+let sleep duration = sleepf (float duration)
 external times : unit -> process_times = "unix_times"
 external utimes : string -> float -> float -> unit = "unix_utimes"
 
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index dea5cb30be..a349d3d3a3 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -788,6 +788,9 @@ val alarm : int -> int
 
 val sleep : int -> unit
 (** Stop execution for the given number of seconds. *)
+val sleepf : float -> unit
+(** Stop execution for the given number of seconds.  Like [sleep],
+    but fractions of seconds are supported. *)
 
 val times : unit -> process_times
 (** Return the execution times of the process. *)
diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 6d630d2057..650c6d670f 100644
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -19,7 +19,7 @@ CAMLprim value unix_sleep(t)
      value t;
 {
   enter_blocking_section();
-  Sleep(Int_val(t) * 1000);
+  Sleep(Double_val(t) * 1e3);
   leave_blocking_section();
   return Val_unit;
 }
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 0f273d1eba..6b20715bfe 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -429,7 +429,8 @@ external gmtime : float -> tm = "unix_gmtime"
 external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
 let alarm n = invalid_arg "Unix.alarm not implemented"
-external sleep : int -> unit = "unix_sleep"
+external sleepf : float -> unit = "unix_sleep"
+let sleep n = sleepf (float n)
 external times: unit -> process_times = "unix_times"
 external utimes : string -> float -> float -> unit = "unix_utimes"