*allow-with-interrupts*
*interrupts-enabled*
*interrupt-pending*
+ #!+sb-thruption *thruption-pending*
*type-system-initialized*))
(defvar *cold-init-complete-p*)
(defun %exit ()
;; If anything goes wrong, we will exit immediately and forcibly.
(handler-bind ((serious-condition *exit-error-handler*))
- (let (ok)
- (unwind-protect
- (progn
- (flush-standard-output-streams)
- (sb!thread::%exit-other-threads)
- (setf ok t))
- (os-exit *exit-in-process* :abort (not ok))))))
+ (let ((ok nil)
+ (code *exit-in-process*))
+ (if (consp code)
+ ;; Another thread called EXIT, and passed the buck to us -- only
+ ;; final call left to do.
+ (os-exit (car code) :abort nil)
+ (unwind-protect
+ (progn
+ (flush-standard-output-streams)
+ (sb!thread::%exit-other-threads)
+ (setf ok t))
+ (os-exit code :abort (not ok)))))))
\f
;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
(let ((*current-error-depth* (1+ *current-error-depth*)))
(/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
;; arbitrary truncation
- #!+sb-show (sb!debug:backtrace 8)
+ #!+sb-show (sb!debug:print-backtrace :count 8)
,@forms)))
;;; a helper function for INFINITE-ERROR-PROTECT
(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 ()
+ (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
+ (values whole-seconds
+ (truly-the fixnum
+ (%unary-truncate (* (- seconds (float 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
+ (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)
+ (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
(when (or (not (realp seconds))
(minusp seconds))
(error 'simple-type-error
- :format-control "invalid argument to SLEEP: ~S"
+ :format-control "Invalid argument to SLEEP: ~S, ~
+ should be a non-negative real."
:format-arguments (list seconds)
:datum seconds
:expected-type '(real 0)))
- #!-win32
+ #!-(and win32 (not sb-thread))
(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?
do (decf sec (expt 10 8))
(sb!unix:nanosleep (expt 10 8) 0))
(sb!unix:nanosleep sec nsec))
- #!+win32
+ #!+(and win32 (not sb-thread))
(sb!win32:millisleep (truncate (* seconds 1000)))
nil)
\f
;; Delete all the options that we processed, so that only
;; user-level options are left visible to user code.
- (setf (rest *posix-argv*) options)
+ (when *posix-argv*
+ (setf (rest *posix-argv*) options))
;; Disable debugger before processing initialization files & co.
(when disable-debugger