[Sbcl-commits] master: sleep: do float to seconds/nanoseconds conversion in C.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  7de154d7b4fa909c669bf2f87f02c184a1b81970 (commit)
      from  b2071832914e31500f73f037f063a63905400e8f (commit)

- Log -----------------------------------------------------------------
commit 7de154d7b4fa909c669bf2f87f02c184a1b81970
Author: Stas Boukarev <sta...@gm...>
Date:   Wed Mar 29 02:48:33 2017 +0300

    sleep: do float to seconds/nanoseconds conversion in C.
    
    To avoid any possible consing.
---
 src/code/toplevel.lisp    | 58 ++++++++++++++++++++++++++++++-----------------
 src/code/unix.lisp        | 18 ++++++++++++---
 src/runtime/wrap.c        | 17 +++++++++++++-
 tests/interface.pure.lisp |  4 ++++
 4 files changed, 72 insertions(+), 25 deletions(-)

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index f2b49b3..463bbee 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -114,15 +114,27 @@ means to wait indefinitely.")
 
 ;;;; miscellaneous external functions
 
+(declaim (inline split-ratio-for-sleep))
+(defun split-ratio-for-sleep (seconds)
+  (declare (ratio seconds)
+           (muffle-conditions t))
+  (multiple-value-bind (quot rem) (truncate (numerator seconds)
+                                            (denominator seconds))
+    (values quot
+            (* rem
+               #.(if (sb!xc:typep 1000000000 'fixnum)
+                     '(truncate 1000000000 (denominator seconds))
+                     ;; Can't truncate a bignum by a fixnum without consing
+                     '(* 10 (truncate 100000000 (denominator seconds))))))))
+
 (defun split-seconds-for-sleep (seconds)
   (declare (muffle-conditions t))
-  (declare (optimize speed))
   ;; KLUDGE: This whole thing to avoid consing floats
   (flet ((split-float ()
            (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
              (values whole-seconds
                      (truly-the (integer 0 #.(expt 10 9))
-                                (%unary-truncate (* (- seconds (float whole-seconds))
+                                (%unary-truncate (* (- seconds (float whole-seconds seconds))
                                                     (load-time-value 1f9 t))))))))
     (declare (inline split-float))
     (typecase seconds
@@ -131,14 +143,7 @@ means to wait indefinitely.")
       ((double-float 0d0 #.(float sb!xc:most-positive-fixnum 1d0))
        (split-float))
       (ratio
-       (multiple-value-bind (quot rem) (truncate (numerator seconds)
-                                                 (denominator seconds))
-         (values quot
-                 (* rem
-                    #.(if (sb!xc:typep 1000000000 'fixnum)
-                          '(truncate 1000000000 (denominator seconds))
-                          ;; Can't truncate a bignum by a fixnum without consing
-                          '(* 10 (truncate 100000000 (denominator seconds))))))))
+       (split-ratio-for-sleep seconds))
       (t
        (multiple-value-bind (sec frac)
            (truncate seconds)
@@ -157,17 +162,28 @@ any non-negative real number."
            :datum seconds
            :expected-type '(real 0)))
   #!-(and win32 (not sb-thread))
-  (multiple-value-bind (sec nsec)
-      (if (integerp seconds)
-          (values seconds 0)
-          (split-seconds-for-sleep seconds))
-    ;; nanosleep() accepts time_t as the first argument, but on some platforms
-    ;; it is restricted to 100 million seconds. Maybe someone can actually
-    ;; have a reason to sleep for over 3 years?
-    (loop while (> sec (expt 10 8))
-          do (decf sec (expt 10 8))
-             (sb!unix:nanosleep (expt 10 8) 0))
-    (sb!unix:nanosleep sec nsec))
+  (typecase seconds
+    #!-win32
+    (double-float
+     (sb!unix::nanosleep-double seconds))
+    #!-win32
+    (single-float
+     (sb!unix::nanosleep-float seconds))
+    (t
+     (multiple-value-bind (sec nsec)
+         (if (integerp seconds)
+             (values seconds 0)
+             #!-win32
+             (split-ratio-for-sleep seconds)
+             #!+win32
+             (split-seconds-for-sleep seconds))
+       ;; nanosleep() accepts time_t as the first argument, but on some platforms
+       ;; it is restricted to 100 million seconds. Maybe someone can actually
+       ;; have a reason to sleep for over 3 years?
+       (loop while (> sec (expt 10 8))
+             do (decf sec (expt 10 8))
+                (sb!unix:nanosleep (expt 10 8) 0))
+       (sb!unix:nanosleep sec nsec))))
   #!+(and win32 (not sb-thread))
   (sb!win32:millisleep (truncate (* seconds 1000)))
   nil)
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index d35efde..5ad2ea5 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -936,10 +936,22 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called."
   ;; KLUDGE: the runtime `boolean' is defined as `int', but the alien
   ;; type is N-WORD-BITS wide.
   (daylight-savings-p (boolean 32) :out))
-
+#-win32
 (defun nanosleep (secs nsecs)
-  (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
-  (int-syscall ("sb_nanosleep" time-t int) secs nsecs)
+  (alien-funcall (extern-alien "sb_nanosleep" (function int time-t int))
+                 secs nsecs)
+  nil)
+
+#-win32
+(defun nanosleep-double (seconds)
+  (alien-funcall (extern-alien "sb_nanosleep_double" (function (values) double))
+                 seconds)
+  nil)
+
+#-win32
+(defun nanosleep-float (seconds)
+  (alien-funcall (extern-alien "sb_nanosleep_float" (function (values) float))
+                 seconds)
   nil)
 
 ;;;; sys/time.h
diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c
index c386215..5747033 100644
--- a/src/runtime/wrap.c
+++ b/src/runtime/wrap.c
@@ -35,6 +35,7 @@
 #include <errno.h>
 #include <limits.h>
 #include <fcntl.h>
+#include <math.h>
 
 #ifndef LISP_FEATURE_WIN32
 #include <pwd.h>
@@ -591,9 +592,23 @@ void sb_nanosleep(time_t sec, int nsec)
 /* nanosleep() is not re-entrant on some versions of Darwin and is
  * reimplemented it using the underlying syscalls.
  */
-void sb_nanosleep(time_t sec, int nsec);
+int sb_nanosleep(time_t sec, int nsec);
 #endif
 
+void sb_nanosleep_double(double seconds) {
+    /* Some (which?) platforms, apparently, can't sleep more than 100
+       million seconds */
+    for (; seconds > 0; seconds -= 100000000.0) {
+        long sec = truncl(seconds);
+        long nsec = truncl((seconds - (double) sec) * 1e9);
+        sb_nanosleep(sec, nsec);
+
+    }
+}
+void sb_nanosleep_float(float seconds) {
+    sb_nanosleep_double(seconds);
+}
+
 int sb_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds,
     struct timeval *timeout)
 {
diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index 9935a68..861461c 100644
--- a/tests/interface.pure.lisp
+++ b/tests/interface.pure.lisp
@@ -284,3 +284,7 @@
     (let ((str (get-output-stream-string s)))
       (assert (and (>= (count #\newline str) 4)
                    (search "bytes consed" str))))))
+
+(with-test (:name :split-seconds-for-sleep)
+  (assert (< (nth-value 1 (sb-impl::split-seconds-for-sleep 7.2993028420866d7))
+             1000000000)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL