X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftimer.lisp;h=29a121ca46c625b1397eeadcd14c7c1cc2cab40d;hb=3cbc1e7cfb59875d7ebec4af3c7c744cab0b76ae;hp=cdf8863bf595b112772299fdcc8c5b9be0d8fa00;hpb=8d10dd337a91dc2f53cbd0e8e68b0e49238deaa3;p=sbcl.git

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index cdf8863..29a121c 100644
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -65,7 +65,7 @@
     (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)
@@ -200,16 +200,12 @@ from now. For timers with a repeat interval it returns true."
 (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
-  t
-  #!+sb!thread
-  (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
+  (sb!thread:holding-mutex-p *scheduler-lock*))
 
 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
 
@@ -294,10 +290,13 @@ triggers."
 ;;; 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
 
@@ -335,32 +334,58 @@ triggers."
            (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."
-  (with-unique-names (timer)
-    `(let ((,timer (make-timer (lambda ()
-                                 (cerror "Continue" 'sb!ext::timeout)))))
-      (schedule-timer ,timer ,expires)
+  "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 ,@body)
-        (unschedule-timer ,timer)))))
+         (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.
+    `(if (> ,expires 0)
+         (let ((,timer (make-timer (lambda ()
+                                     (cerror "Continue" 'sb!ext::timeout)))))
+           (schedule-timer ,timer ,expires)
+           (unwind-protect
+                (progn ,@body)
+             (unschedule-timer ,timer)))
+         (progn ,@body))))