X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftimer.lisp;h=065b4c22e6e6007733b14b4a7d5ad19eba787472;hb=f31bc323d5bfc205f94164b203833f35033df3cd;hp=7f49302e9de247fe10ca22ab07eb0eaa9ef97d08;hpb=1aee76da48edafa210f60e852913041a843428b7;p=sbcl.git diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 7f49302..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) @@ -128,24 +128,6 @@ (heap-extract contents i :key keyfun :test #'<=) i)))) -;;; thread utility - -(defun make-cancellable-interruptor (function) - ;; 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)) - (cancelled-p nil)) - #!-sb-thread - (declare (ignore mutex)) - (list - #'(lambda () - (sb!thread:with-recursive-lock (mutex) - (unless cancelled-p - (funcall function)))) - #'(lambda () - (sb!thread:with-recursive-lock (mutex) - (setq cancelled-p t)))))) - ;;; timers (defstruct (timer @@ -178,7 +160,10 @@ future versions." 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." +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) @@ -202,16 +187,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)) @@ -228,6 +209,30 @@ from now. For timers with a repeat interval it returns true." ;;; 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) (old-position (priority-queue-remove *schedule* timer))) @@ -241,8 +246,7 @@ from now. For timers with a repeat interval it returns true." (setq changed-p t)) (setf (values (%timer-interrupt-function timer) (%timer-cancel-function timer)) - (values-list (make-cancellable-interruptor - (%timer-function timer)))) + (values-list (make-cancellable-interruptor timer))) (when changed-p (set-system-timer))) (values)) @@ -296,25 +300,36 @@ 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))) + ;; 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) @@ -324,49 +339,72 @@ triggers." (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) #!+sb-doc - "Execute the body, asynchronously interrupting it and signalling a -TIMEOUT condition after at least EXPIRES seconds have passed." - (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)))) + "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)))))