X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftimer.lisp;h=065b4c22e6e6007733b14b4a7d5ad19eba787472;hb=769e1d8a825c587df85896dc971d0f90748e134e;hp=a38d98e557d3acf8fc21bd8a6d1734a261a640a8;hpb=40a26a4dd7f2891e78421ba465b99bb67f892856;p=sbcl.git

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index a38d98e..065b4c2 100644
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -16,7 +16,7 @@
 (declaim (inline heap-parent heap-left heap-right))
 
 (defun heap-parent (i)
-  (ash i -1))
+  (ash (1- i) -1))
 
 (defun heap-left (i)
   (1+ (ash i 1)))
@@ -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)
@@ -133,11 +133,16 @@
 (defstruct (timer
              (:conc-name %timer-)
              (:constructor %make-timer))
+  #!+sb-doc
+  "Timer type. Do not rely on timers being structs as it may change in
+future versions."
   name
   function
   expire-time
   repeat-interval
-  (thread nil :type (or sb!thread:thread (member t nil))))
+  (thread nil :type (or sb!thread:thread (member t nil)))
+  interrupt-function
+  cancel-function)
 
 (def!method print-object ((timer timer) stream)
   (let ((name (%timer-name timer)))
@@ -150,34 +155,44 @@
           ))))
 
 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
+  #!+sb-doc
+  "Create a timer object that's when scheduled runs FUNCTION. If
+THREAD is a thread then that thread is to be interrupted with
+FUNCTION. If THREAD is T then a new thread is created each timer
+FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
+thread. When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION
+and the ordering guarantees of INTERRUPT-THREAD also apply here.
+FUNCTION always runs with interrupts disabled but WITH-INTERRUPTS is
+allowed."
   (%make-timer :name name :function function :thread thread))
 
 (defun timer-name (timer)
+  #!+sb-doc
+  "Return the name of TIMER."
   (%timer-name timer))
 
-(defun timer-expired-p (timer &optional (delta 0))
+(defun timer-scheduled-p (timer &key (delta 0))
+  #!+sb-doc
+  "See if TIMER will still need to be triggered after DELTA seconds
+from now. For timers with a repeat interval it returns true."
   (symbol-macrolet ((expire-time (%timer-expire-time timer))
                     (repeat-interval (%timer-repeat-interval timer)))
-    (and (not (and repeat-interval (plusp repeat-interval)))
-         (or (null expire-time)
-             (< expire-time
-                (+ (get-internal-real-time) delta))))))
+      (or (and repeat-interval (plusp repeat-interval))
+          (and expire-time
+               (<= (+ (get-internal-real-time) delta)
+                   expire-time)))))
 
 ;;; The scheduler
 
 (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))
 
@@ -194,17 +209,59 @@
 
 ;;; Public interface
 
+(defun make-cancellable-interruptor (timer)
+  ;; return a list of two functions: one that does the same as
+  ;; FUNCTION until the other is called, from when it does nothing.
+  (let ((mutex (sb!thread:make-mutex))
+        (cancelledp nil)
+        (function (if (%timer-repeat-interval timer)
+                      (lambda ()
+                        (unwind-protect
+                             (funcall (%timer-function timer))
+                          (reschedule-timer timer)))
+                      (%timer-function timer))))
+    (list
+     (lambda ()
+       ;; Use WITHOUT-INTERRUPTS for the acquiring lock to avoid
+       ;; unblocking deferrables unless it's inevitable.
+       (without-interrupts
+         (sb!thread:with-recursive-lock (mutex)
+           (unless cancelledp
+             (allow-with-interrupts
+               (funcall function))))))
+     (lambda ()
+       (sb!thread:with-recursive-lock (mutex)
+         (setq cancelledp t))))))
+
 (defun %schedule-timer (timer)
-  (let ((changed-p nil))
-    (when (eql 0 (priority-queue-remove *schedule* timer))
+  (let ((changed-p nil)
+        (old-position (priority-queue-remove *schedule* timer)))
+    ;; Make sure interruptors are cancelled even if this timer was
+    ;; scheduled again since our last attempt.
+    (when old-position
+      (funcall (%timer-cancel-function timer)))
+    (when (eql 0 old-position)
       (setq changed-p t))
     (when (zerop (priority-queue-insert *schedule* timer))
       (setq changed-p t))
+    (setf (values (%timer-interrupt-function timer)
+                  (%timer-cancel-function timer))
+          (values-list (make-cancellable-interruptor timer)))
     (when changed-p
       (set-system-timer)))
   (values))
 
 (defun schedule-timer (timer time &key repeat-interval absolute-p)
+  #!+sb-doc
+  "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
+universal time, but non-integral values are also allowed, else TIME is
+measured as the number of seconds from the current time. If
+REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
+expiry."
+  ;; CANCEL-FUNCTION may block until all interruptors finish, let's
+  ;; try to cancel without the scheduler lock first.
+  (when (%timer-cancel-function timer)
+    (funcall (%timer-cancel-function timer)))
   (with-scheduler-lock ()
     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
                                         (delta->real
@@ -217,39 +274,62 @@
     (%schedule-timer timer)))
 
 (defun unschedule-timer (timer)
+  #!+sb-doc
+  "Cancel TIMER. Once this function returns it is guaranteed that
+TIMER shall not be triggered again and there are no unfinished
+triggers."
+  (let ((cancel-function (%timer-cancel-function timer)))
+    (when cancel-function
+      (funcall cancel-function)))
   (with-scheduler-lock ()
     (setf (%timer-expire-time timer) nil
           (%timer-repeat-interval timer) nil)
-    (when (eql 0 (priority-queue-remove *schedule* timer))
-      (set-system-timer)))
+    (let ((old-position (priority-queue-remove *schedule* timer)))
+      (when old-position
+        (funcall (%timer-cancel-function timer)))
+      (when (eql 0 old-position)
+        (set-system-timer))))
   (values))
 
 (defun list-all-timers ()
+  #!+sb-doc
+  "Return a list of all timers in the system."
   (with-scheduler-lock ()
     (concatenate 'list (%pqueue-contents *schedule*))))
 
 ;;; 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)))
+  ;; unless unscheduled
+  (when (%timer-expire-time 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 ()
+            ;; Schedule at regular intervals. If TIMER has not finished
+            ;; in time then it may catch up later.
+            (incf (%timer-expire-time timer) (%timer-repeat-interval timer))
+            (%schedule-timer timer))))))
 
 ;;; Expiring timers
 
-(defun real-time->sec-and-usec(time)
-  (if (minusp time)
-      (list 0 1)
-      (multiple-value-bind (s u) (floor time internal-time-units-per-second)
-        (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
-        (if (= 0 s u)
-            ;; 0 0 means "shut down the timer" for setitimer
-            (list 0 1)
-            (list s u)))))
+(defun real-time->sec-and-usec (time)
+  ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
+  ;; avoid starvation.
+  (let ((min-usec 100))
+    (if (minusp time)
+        (list 0 min-usec)
+        (multiple-value-bind (s u) (floor time internal-time-units-per-second)
+          (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
+          (if (and (= 0 s) (< u min-usec))
+              ;; 0 0 means "shut down the timer" for setitimer
+              (list 0 min-usec)
+              (list s u))))))
 
 (defun set-system-timer ()
   (assert (under-scheduler-lock-p))
+  (assert (not *interrupts-enabled*))
   (let ((next-timer (peek-schedule)))
     (if next-timer
         (let ((delta (- (%timer-expire-time next-timer)
@@ -259,44 +339,72 @@
         (sb!unix:unix-setitimer :real 0 0 0 0))))
 
 (defun run-timer (timer)
-  (symbol-macrolet ((function (%timer-function timer))
-                    (repeat-interval (%timer-repeat-interval timer))
-                    (thread (%timer-thread timer)))
-    (when repeat-interval
-      (reschedule-timer timer))
-    (cond ((null thread)
-           (funcall function))
-          ((eq t thread)
-           (sb!thread:make-thread function))
-          (t
-           (handler-case
-               (sb!thread:interrupt-thread thread function)
-             (sb!thread:interrupt-thread-error (c)
-               (warn c)))))))
-
+  (let ((function (%timer-interrupt-function timer))
+        (thread (%timer-thread timer)))
+    (if (eq t thread)
+        (sb!thread:make-thread (without-interrupts
+                                 (allow-with-interrupts
+                                   function))
+                               :name (format nil "Timer ~A"
+                                             (%timer-name timer)))
+        (let ((thread (or thread sb!thread:*current-thread*)))
+          (handler-case
+              (sb!thread:interrupt-thread thread function)
+            (sb!thread:interrupt-thread-error (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)))
+  (let (timer)
     (with-scheduler-lock ()
-      (set-system-timer))))
+      (setq timer (peek-schedule))
+      (when (or (null timer)
+                (< (get-internal-real-time)
+                   (%timer-expire-time timer)))
+        ;; Seemingly this is a spurious SIGALRM, but play it safe and
+        ;; reset the system timer because if the system clock was set
+        ;; back after the SIGALRM had been delivered then we won't get
+        ;; another chance.
+        (set-system-timer)
+        (return-from run-expired-timers nil))
+      (assert (eq timer (priority-queue-extract-maximum *schedule*)))
+      (set-system-timer))
+    (run-timer timer)))
+
+(defun timeout-cerror ()
+  (cerror "Continue" 'sb!ext::timeout))
 
 (defmacro sb!ext:with-timeout (expires &body body)
-  "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)
-       (unwind-protect
-            (progn ,@body)
-         (unschedule-timer ,timer)))))
+  #!+sb-doc
+  "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."
+  `(dx-flet ((timeout-body () ,@body))
+     (let ((expires ,expires))
+       ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
+       ;; unwinds are handled revisit it.
+       (if (> expires 0)
+           (let ((timer (make-timer #'timeout-cerror)))
+             (schedule-timer timer expires)
+             (unwind-protect (timeout-body)
+               (unschedule-timer timer)))
+           (timeout-body)))))