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

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index a38d98e..29dc0a8 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,45 @@
           ))))
 
 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
+  #!+sb-doc
+  "Create a timer that runs FUNCTION when triggered.
+
+If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
+T, a new thread is created for FUNCTION each time the timer is
+triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
+
+When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
+ordering guarantees of INTERRUPT-THREAD apply. FUNCTION 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 +210,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,86 +275,209 @@
     (%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)))
+      ;; Don't use cancel-function as the %timer-cancel-function
+      ;; may have changed before we got the scheduler lock.
+      (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))))))
+
+;;; setitimer is unavailable for win32, but we can emulate it when
+;;; threads are available -- using win32 waitable timers.
+;;;
+;;; Conversely, when we want to minimize signal use on POSIX, we emulate
+;;; win32 waitable timers using a timerfd-like portability layer in
+;;; the runtime.
+
+#!+sb-wtimer
+(define-alien-type wtimer
+    #!+win32 system-area-pointer ;HANDLE, but that's not defined yet
+    #!+sunos system-area-pointer ;struct os_wtimer *
+    #!+(or linux bsd) int)
+
+#!+sb-wtimer
+(progn
+  (define-alien-routine "os_create_wtimer" wtimer)
+  (define-alien-routine "os_wait_for_wtimer" int (wt wtimer))
+  (define-alien-routine "os_close_wtimer" void (wt wtimer))
+  (define-alien-routine "os_cancel_wtimer" void (wt wtimer))
+  (define-alien-routine "os_set_wtimer" void (wt wtimer) (sec int) (nsec int))
+
+  ;; scheduler lock already protects us
+
+  (defvar *waitable-timer-handle* nil)
+
+  (defvar *timer-thread* nil)
+
+  (defun get-waitable-timer ()
+    (assert (under-scheduler-lock-p))
+    (or *waitable-timer-handle*
+        (prog1
+            (setf *waitable-timer-handle* (os-create-wtimer))
+          (setf *timer-thread*
+                (sb!thread:make-thread
+                 (lambda ()
+                   (loop while
+                        (or (zerop
+                             (os-wait-for-wtimer *waitable-timer-handle*))
+                            *waitable-timer-handle*)
+                        doing (run-expired-timers)))
+                 :ephemeral t
+                 :name "System timer watchdog thread")))))
+
+  (defun itimer-emulation-deinit ()
+    (with-scheduler-lock ()
+      (when *timer-thread*
+        (sb!thread:terminate-thread *timer-thread*)
+        (sb!thread:join-thread *timer-thread* :default nil))
+      (when *waitable-timer-handle*
+        (os-close-wtimer *waitable-timer-handle*)
+        (setf *waitable-timer-handle* nil))))
+
+  (defun %clear-system-timer ()
+    (os-cancel-wtimer (get-waitable-timer)))
+
+  (defun %set-system-timer (sec nsec)
+    (os-set-wtimer (get-waitable-timer) sec nsec)))
 
 ;;; 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-nsec (time)
+  ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
+  ;; avoid starvation.
+  (let ((min-nsec 100000))
+    (if (minusp time)
+        (values 0 min-nsec)
+        (multiple-value-bind (s u) (floor time internal-time-units-per-second)
+          (setf u (floor (* (/ u internal-time-units-per-second)
+                            #.(expt 10 9))))
+          (if (and (= 0 s) (< u min-nsec))
+              ;; 0 0 means "shut down the timer" for setitimer
+              (values 0 min-nsec)
+              (values s u))))))
+
+#!-(or sb-wtimer win32)
+(progn
+  (defun %set-system-timer (sec nsec)
+    (sb!unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000)))
+
+  (defun %clear-system-timer ()
+    (sb!unix:unix-setitimer :real 0 0 0 0)))
 
 (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)
                         (get-internal-real-time))))
-          (apply #'sb!unix:unix-setitimer
-                 :real 0 0 (real-time->sec-and-usec delta)))
-        (sb!unix:unix-setitimer :real 0 0 0 0))))
+          (multiple-value-call #'%set-system-timer
+            (real-time->sec-and-nsec delta)))
+        (%clear-system-timer))))
 
 (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. We loop until all the expired timers
+;;; have been run.
 (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-scheduler-lock ()
-      (set-system-timer))))
+  (loop
+    (let ((now (get-internal-real-time))
+          (timers nil))
+      (flet ((run-timers ()
+               (dolist (timer (nreverse timers))
+                 (run-timer timer))))
+        (with-scheduler-lock ()
+          (loop for timer = (peek-schedule)
+                when (or (null timer) (< now (%timer-expire-time timer)))
+                ;; No more timers to run for now, reset the system timer.
+                do (run-timers)
+                   (set-system-timer)
+                   (return-from run-expired-timers nil)
+                else
+                do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
+                   (push timer timers)))
+        (run-timers)))))
+
+(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)))))