;;;; -*- 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,
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
* 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
* Extensible Streams::
* Package Locks::
* Threading::
+* Timers::
* Networking::
* Profiling::
* Contributed Modules::
@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
--- /dev/null
+@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
"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"
(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)))
))))
(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
,@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))
;;; 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
(%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*))))
(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)))))
(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)
(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*))))))
(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*))))))
(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))))))
;;; 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"
projects / sbcl.git / commitdiff