From 8d10dd337a91dc2f53cbd0e8e68b0e49238deaa3 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Tue, 6 Sep 2005 14:49:53 +0000 Subject: [PATCH] 0.9.4.28: Beane counters * exported timer facility * fixed UNSCHEDULE-TIMER race: pending interrupts are cancelled * thanks, Zach --- NEWS | 7 ++-- doc/manual/sbcl.texinfo | 2 + doc/manual/timers.texinfo | 25 +++++++++++ package-data-list.lisp-expr | 6 ++- src/code/timer.lisp | 96 +++++++++++++++++++++++++++++++++++-------- tests/timer.impure.lisp | 56 ++++++++++++++----------- version.lisp-expr | 2 +- 7 files changed, 150 insertions(+), 44 deletions(-) create mode 100644 doc/manual/timers.texinfo diff --git a/NEWS b/NEWS index bfa565a..bcb7628 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,6 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.5 relative to sbcl-0.9.4: + * new feature: timers based on Zach Beane's excellent timer package * added support for the following external formats: koi8-u, x-mac-cyrillic, cp437, cp850, cp852, cp855, cp857, cp860, cp861, cp862, cp863, cp864, cp865, cp866, cp869, cp874, iso-8859-2, @@ -7,8 +8,8 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: iso-8859-8, iso-8859-9, iso-8859-10, iso-8859-11, iso-8859-13, iso-8859-14, cp1250, cp1251, cp1252, cp1253, cp1254, cp1255,cp1256, cp1257, cp1258 (contributed by Ivan Boldyrev) - * incompatible change: a threaded SBCL will no longer revert to - non-threaded mode on non-NPTL systems, but refuse to start entirely. + * incompatible change: a threaded SBCL will no longer revert to + non-threaded mode on non-NPTL systems, but refuse to start entirely. * bug fix: interrupts are disabled until startup is complete; no more sigsegvs when receiving a signal to soon * optimization: Faster 32-bit SB-ROTATE-BYTE:ROTATE-BYTE on non-x86/ppc @@ -20,7 +21,7 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: * bug fix: printing objects of type HASH-TABLE signals a PRINT-NOT-READABLE error when *READ-EVAL* is NIL. (reported by Faré Rideau) - * bug fix: GET-INTERNAL-REAL-TIME now works even for processes that + * bug fix: GET-INTERNAL-REAL-TIME now works even for processes that have been running for over 50 days. (reported by Gilbert Baumann) * bug fix: the logic for getting names of functions gets less confused when confronded with alternate-metaclass diff --git a/doc/manual/sbcl.texinfo b/doc/manual/sbcl.texinfo index 9216d7b..ea5c44a 100644 --- a/doc/manual/sbcl.texinfo +++ b/doc/manual/sbcl.texinfo @@ -62,6 +62,7 @@ provided with absolutely no warranty. See the @file{COPYING} and * Extensible Streams:: * Package Locks:: * Threading:: +* Timers:: * Networking:: * Profiling:: * Contributed Modules:: @@ -84,6 +85,7 @@ provided with absolutely no warranty. See the @file{COPYING} and @include streams.texinfo @include package-locks.texi-temp @include threading.texinfo +@include timers.texinfo @include sb-bsd-sockets/sb-bsd-sockets.texinfo @include profiling.texinfo @include contrib-modules.texinfo diff --git a/doc/manual/timers.texinfo b/doc/manual/timers.texinfo new file mode 100644 index 0000000..45e617e --- /dev/null +++ b/doc/manual/timers.texinfo @@ -0,0 +1,25 @@ +@node Timers +@comment node-name, next, previous, up +@chapter Timers + +SBCL supports a system-wide scheduler implemented on top of +@code{setitimer} that also works with threads but does not require a +separate schduler thread. + +@menu +@end menu + +@lisp +(schedule-timer (make-timer (lambda () + (write-line "Hello, world") + (force-output))) + 2) +@end lisp + +@include struct-sb-ext-timer.texinfo +@include fun-sb-ext-make-timer.texinfo +@include fun-sb-ext-timer-name.texinfo +@include fun-sb-ext-timer-scheduled-p.texinfo +@include fun-sb-ext-schedule-timer.texinfo +@include fun-sb-ext-unschedule-timer.texinfo +@include fun-sb-ext-list-all-timers.texinfo diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9598aab..93922bc 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -727,7 +727,11 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "PROCESS-STATUS-HOOK" "PROCESS-WAIT" ;; external-format support - "OCTETS-TO-STRING" "STRING-TO-OCTETS")) + "OCTETS-TO-STRING" "STRING-TO-OCTETS" + + ;; timer + "TIMER" "MAKE-TIMER" "TIMER-NAME" "TIMER-SCHEDULED-P" + "SCHEDULE-TIMER" "UNSCHEDULE-TIMER" "LIST-ALL-TIMERS")) #s(sb-cold:package-data :name "SB!FORMAT" diff --git a/src/code/timer.lisp b/src/code/timer.lisp index a38d98e..cdf8863 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -128,16 +128,37 @@ (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)) + (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 (: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,18 +171,29 @@ )))) (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." (%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 @@ -174,9 +206,9 @@ ,@body))) (defun under-scheduler-lock-p () - #!-sb-thread + #!-sb!thread t - #!+sb-thread + #!+sb!thread (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*))) (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time)) @@ -195,16 +227,35 @@ ;;; Public interface (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-function 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,14 +268,26 @@ (%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*)))) @@ -291,12 +354,13 @@ (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) - (unwind-protect - (progn ,@body) - (unschedule-timer ,timer))))) + (schedule-timer ,timer ,expires) + (unwind-protect + (progn ,@body) + (unschedule-timer ,timer))))) diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index d07a7a0..45b7025 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -15,9 +15,9 @@ (with-test (:name (:timer :relative)) (let* ((has-run-p nil) - (timer (sb-impl::make-timer (lambda () (setq has-run-p t)) + (timer (make-timer (lambda () (setq has-run-p t)) :name "simple timer"))) - (sb-impl::schedule-timer timer 0.5) + (schedule-timer timer 0.5) (sleep 0.2) (assert (not has-run-p)) (sleep 0.5) @@ -26,50 +26,53 @@ (with-test (:name (:timer :absolute)) (let* ((has-run-p nil) - (timer (sb-impl::make-timer (lambda () (setq has-run-p t)) + (timer (make-timer (lambda () (setq has-run-p t)) :name "simple timer"))) - (sb-impl::schedule-timer timer (+ 1/2 (get-universal-time)) - :absolute-p t) + (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t) (sleep 0.2) (assert (not has-run-p)) (sleep 0.5) (assert has-run-p) (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) -(defvar *x* nil) - #+sb-thread (with-test (:name (:timer :other-thread)) - (let* ((thread (sb-thread:make-thread (lambda () (let ((*x* t)) (sleep 2))))) - (timer (sb-impl::make-timer (lambda () (assert *x*)) :thread thread))) - (sb-impl::schedule-timer timer 0.1))) + (let* ((thread (sb-thread:make-thread (lambda () (sleep 2)))) + (timer (make-timer (lambda () + (assert (eq thread sb-thread:*current-thread*))) + :thread thread))) + (schedule-timer timer 0.1))) #+sb-thread (with-test (:name (:timer :new-thread)) - (let ((*x* t) - (timer (sb-impl::make-timer (lambda () (assert (not *x*))) :thread t))) - (sb-impl::schedule-timer timer 0.1))) + (let* ((original-thread sb-thread:*current-thread*) + (timer (make-timer + (lambda () + (assert (not (eq original-thread + sb-thread:*current-thread*)))) + :thread t))) + (schedule-timer timer 0.1))) (with-test (:name (:timer :repeat-and-unschedule)) (let* ((run-count 0) timer) (setq timer - (sb-impl::make-timer (lambda () + (make-timer (lambda () (when (= 5 (incf run-count)) - (sb-impl::unschedule-timer timer))))) - (sb-impl::schedule-timer timer 0 :repeat-interval 0.2) - (assert (not (sb-impl::timer-expired-p timer 0.3))) + (unschedule-timer timer))))) + (schedule-timer timer 0 :repeat-interval 0.2) + (assert (timer-scheduled-p timer :delta 0.3)) (sleep 1.3) (assert (= 5 run-count)) - (assert (sb-impl::timer-expired-p timer)) + (assert (not (timer-scheduled-p timer))) (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) (with-test (:name (:timer :reschedule)) (let* ((has-run-p nil) - (timer (sb-impl::make-timer (lambda () + (timer (make-timer (lambda () (setq has-run-p t))))) - (sb-impl::schedule-timer timer 0.2) - (sb-impl::schedule-timer timer 0.3) + (schedule-timer timer 0.2) + (schedule-timer timer 0.3) (sleep 0.5) (assert has-run-p) (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) @@ -77,8 +80,7 @@ (with-test (:name (:timer :stress)) (let ((time (1+ (get-universal-time)))) (loop repeat 200 do - (sb-impl::schedule-timer (sb-impl::make-timer (lambda ())) time - :absolute-p t)) + (schedule-timer (make-timer (lambda ())) time :absolute-p t)) (sleep 2) (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) @@ -107,3 +109,11 @@ (sb-ext:with-timeout 0.5 (sb-ext:with-timeout 2 (sleep 2)))))) + +(with-test (:name (:with-timeout :many-at-the-same-time)) + (loop repeat 10 do + (sb-thread:make-thread + (lambda () + (sb-ext:with-timeout 0.5 + (sleep 5) + (assert nil)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 7e801f8..92349cf 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.4.27" +"0.9.4.28" -- 1.7.10.4