sleep: Add more precautions to avoid consing on x86.

[sbcl.git] / src / code / toplevel.lisp

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 71e7d5e..d6c5427 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -159,46 +159,17 @@ means to wait indefinitely.")
         (t
          (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
          nil)))
-
-;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
-;;; one point (shown below), and SBCL cross-compiled it without
-;;; warning about FORMS being undefined. Check whether that problem
-;;; (missing warning) is repeatable in the final system and if so, fix
-;;; it.
-#|
-(defun infinite-error-protector ()
-  `(cond ((not *cold-init-complete-p*)
-          (%primitive print "Argh! error in cold init, halting")
-          (%primitive sb!c:halt))
-         ((or (not (boundp '*current-error-depth*))
-              (not (realp   *current-error-depth*))
-              (not (boundp '*maximum-error-depth*))
-              (not (realp   *maximum-error-depth*)))
-          (%primitive print "Argh! corrupted error depth, halting")
-          (%primitive sb!c:halt))
-         ((> *current-error-depth* *maximum-error-depth*)
-          (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
-          (error-error "Help! "
-                       *current-error-depth*
-                       " nested errors. "
-                       "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
-          (progn ,@forms)
-          t)
-         (t
-          (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
-          nil)))
-|#
 \f
 ;;;; miscellaneous external functions
 
 (defun split-seconds-for-sleep (seconds)
   (declare (optimize speed))
+  ;; KLUDGE: This whole thing to avoid consing floats
   (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)
+                                (%unary-truncate (* (- seconds (float whole-seconds))
                                                     (load-time-value 1s9 t))))))))
     (declare (inline split-float))
     (typecase seconds
@@ -210,7 +181,11 @@ means to wait indefinitely.")
        (multiple-value-bind (quot rem) (truncate (numerator seconds)
                                                  (denominator seconds))
          (values quot
-                 (* rem (/ 1000000000 (denominator seconds))))))
+                 (* rem
+                    (if (typep 1000000000 'fixnum)
+                        (truncate 1000000000 (denominator seconds))
+                        ;; Can't truncate a bignum by a fixnum without consing
+                        (* 10 (truncate 100000000 (denominator seconds))))))))
       (t
        (multiple-value-bind (sec frac)
            (truncate seconds)