From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 2 Jun 2013 20:15:33 +0000 (+0400)
Subject: Avoid consing in SLEEP.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f962bad9a3dcfa165fe359e60be48c636a1622ec;p=sbcl.git

Avoid consing in SLEEP.

Try to compute seconds without consing, when the arguments are small
enough (in the fixnum range).

Add a transform to go directly to sb-unix:nanosleep when possible.
---

diff --git a/NEWS b/NEWS
index b6e2d99..45b6aec 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,7 @@ changes relative to sbcl-1.1.8:
   * optimization: compute encode-universal-time at compile time when possible.
   * optimization: when referencing internal functions as #'x, don't go through
     an indirect fdefn structure.
+  * optimization: SLEEP doesn't cons on non-immediate floats and on ratios.
   
 changes in sbcl-1.1.8 relative to sbcl-1.1.7:
   * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of
diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 9632d08..71e7d5e 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -191,6 +191,31 @@ means to wait indefinitely.")
 
 ;;;; miscellaneous external functions
 
+(defun split-seconds-for-sleep (seconds)
+  (declare (optimize speed))
+  (flet ((split-float ()
+           ;; KLUDGE: This whole thing to avoid consing floats
+           (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
+             (values whole-seconds
+                     (truly-the fixnum
+                                (%unary-truncate (* (- seconds whole-seconds)
+                                                    (load-time-value 1s9 t))))))))
+    (declare (inline split-float))
+    (typecase seconds
+      ((single-float 0s0 #.(float most-positive-fixnum 1s0))
+       (split-float))
+      ((double-float 0d0 #.(float most-positive-fixnum 1d0))
+       (split-float))
+      (ratio
+       (multiple-value-bind (quot rem) (truncate (numerator seconds)
+                                                 (denominator seconds))
+         (values quot
+                 (* rem (/ 1000000000 (denominator seconds))))))
+      (t
+       (multiple-value-bind (sec frac)
+           (truncate seconds)
+         (values sec (truncate frac (load-time-value 1s-9 t))))))))
+
 (defun sleep (seconds)
   #!+sb-doc
   "This function causes execution to be suspended for SECONDS. SECONDS may be
@@ -207,9 +232,7 @@ any non-negative real number."
   (multiple-value-bind (sec nsec)
       (if (integerp seconds)
           (values seconds 0)
-          (multiple-value-bind (sec frac)
-              (truncate seconds)
-            (values sec (truncate frac 1e-9))))
+          (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?
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c90ca44..cc6b36d 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -4677,3 +4677,16 @@
     (if (zerop (rem time-zone 1/3600))
         (encode-universal-time second minute hour date month year time-zone)
         (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+  `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+  (let ((seconds-value (lvar-value seconds)))
+    (multiple-value-bind (seconds nano)
+        (sb!impl::split-seconds-for-sleep seconds-value)
+      (if (> seconds (expt 10 8))
+          (give-up-ir1-transform)
+          `(sb!unix:nanosleep ,seconds ,nano)))))