(aref heap 0)))
(defun heap-extract (heap i &key (key #'identity) (test #'>=))
- (when (< (length heap) i)
+ (unless (> (length heap) i)
(error "Heap underflow"))
(prog1
(aref heap i)
;; FUNCTION until the other is called, from when it does nothing.
(let ((mutex (sb!thread:make-mutex))
(cancelled-p nil))
- #!-sb-thread
- (declare (ignore mutex))
(list
#'(lambda ()
(sb!thread:with-recursive-lock (mutex)
(defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
(defmacro with-scheduler-lock ((&optional) &body body)
- ;; don't let the SIGALRM handler mess things up
- `(sb!sys:without-interrupts
- (sb!thread:with-mutex (*scheduler-lock*)
- ,@body)))
+ ;; Don't let the SIGALRM handler mess things up.
+ `(sb!thread::with-system-mutex (*scheduler-lock*)
+ ,@body))
(defun under-scheduler-lock-p ()
- #!-sb!thread
+ #!-sb-thread
t
- #!+sb!thread
+ #!+sb-thread
(eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
(defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
;;; Not public, but related
(defun reschedule-timer (timer)
- (with-scheduler-lock ()
- (setf (%timer-expire-time timer) (+ (get-internal-real-time)
- (%timer-repeat-interval timer)))
- (%schedule-timer timer)))
+ (let ((thread (%timer-thread timer)))
+ (if (and (sb!thread::thread-p thread) (not (sb!thread:thread-alive-p thread)))
+ (unschedule-timer timer)
+ (with-scheduler-lock ()
+ (setf (%timer-expire-time timer) (+ (get-internal-real-time)
+ (%timer-repeat-interval timer)))
+ (%schedule-timer timer)))))
;;; Expiring timers
(handler-case
(sb!thread:interrupt-thread thread function)
(sb!thread:interrupt-thread-error (c)
- (warn c)))))))
+ (declare (ignore c))
+ (warn "Timer ~S failed to interrupt thread ~S."
+ timer thread)))))))
+;; Called from the signal handler.
(defun run-expired-timers ()
(unwind-protect
- (let (timer)
- (loop
- (with-scheduler-lock ()
- (setq timer (peek-schedule))
- (unless (and timer
- (> (get-internal-real-time)
- (%timer-expire-time timer)))
- (return-from run-expired-timers nil))
- (assert (eq timer (priority-queue-extract-maximum *schedule*))))
- ;; run the timer without the lock
- (run-timer timer)))
+ (with-interrupts
+ (let (timer)
+ (loop
+ (with-scheduler-lock ()
+ (setq timer (peek-schedule))
+ (unless (and timer
+ (> (get-internal-real-time)
+ (%timer-expire-time timer)))
+ (return-from run-expired-timers nil))
+ (assert (eq timer (priority-queue-extract-maximum *schedule*))))
+ ;; run the timer without the lock
+ (run-timer timer))))
(with-scheduler-lock ()
(set-system-timer))))
(defmacro sb!ext:with-timeout (expires &body body)
#!+sb-doc
- "Execute the body, asynchronously interrupting it and signalling a
-TIMEOUT condition after at least EXPIRES seconds have passed."
+ "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
+condition after at least EXPIRES seconds have passed.
+
+Note that it is never safe to unwind from an asynchronous condition. Consider:
+
+ (defun call-with-foo (function)
+ (let (foo)
+ (unwind-protect
+ (progn
+ (setf foo (get-foo))
+ (funcall function foo))
+ (when foo
+ (release-foo foo)))))
+
+If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
+RELEASE-FOO will be missed. While individual sites like this can be made proof
+against asynchronous unwinds, this doesn't solve the fundamental issue, as all
+the frames potentially unwound through need to be proofed, which includes both
+system and application code -- and in essence proofing everything will make
+the system uninterruptible."
(with-unique-names (timer)
;; FIXME: a temporary compatibility workaround for CLX, if unsafe
;; unwinds are handled revisit it.