X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftimer.lisp;h=ca4ffef1545965a2e82b51a1c2032fb0274e57af;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=2d4c67ac3c061950bd455805d9330f1598c9b134;hpb=0c5c2fec5aae5fc87fc392192b009d234ea99462;p=sbcl.git diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 2d4c67a..ca4ffef 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) @@ -111,7 +111,7 @@ (heap-extract-maximum contents :key keyfun :test #'<=)))) (defun priority-queue-insert (priority-queue new-item) - "Add NEW-ITEM to PRIOIRITY-QUEUE." + "Add NEW-ITEM to PRIORITY-QUEUE." (symbol-macrolet ((contents (%pqueue-contents priority-queue)) (keyfun (%pqueue-keyfun priority-queue))) (heap-insert contents new-item :key keyfun :test #'<=))) @@ -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 @@ -174,11 +156,15 @@ future versions." (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." + "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) @@ -202,16 +188,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 +210,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 +247,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)) @@ -281,6 +286,8 @@ triggers." (setf (%timer-expire-time timer) nil (%timer-repeat-interval timer) nil) (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) @@ -296,81 +303,181 @@ 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)))))) + +;;; 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) - (declare (ignore c)) - (warn "Timer ~S failed to interrupt thread ~S." - timer thread))))))) - -;; Called from the signal handler. + (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 - (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)))) + (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) #!+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)))))