--- /dev/null
+;;;; a timer facility based heavily on the timer package by Zach Beane
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; Heap (for the priority queue)
+
+(declaim (inline heap-parent heap-left heap-right))
+
+(defun heap-parent (i)
+ (ash i -1))
+
+(defun heap-left (i)
+ (1+ (ash i 1)))
+
+(defun heap-right (i)
+ (+ 2 (ash i 1)))
+
+(defun heapify (heap start &key (key #'identity) (test #'>=))
+ (declare (function key test))
+ (flet ((key (obj) (funcall key obj))
+ (ge (i j) (funcall test i j)))
+ (let ((l (heap-left start))
+ (r (heap-right start))
+ (size (length heap))
+ largest)
+ (setf largest (if (and (< l size)
+ (not (ge (key (aref heap start))
+ (key (aref heap l)))))
+ l
+ start))
+ (when (and (< r size)
+ (not (ge (key (aref heap largest))
+ (key (aref heap r)))))
+ (setf largest r))
+ (when (/= largest start)
+ (rotatef (aref heap largest) (aref heap start))
+ (heapify heap largest :key key :test test)))
+ heap))
+
+(defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
+ (declare (function key test))
+ (flet ((key (obj) (funcall key obj))
+ (ge (i j) (funcall test i j)))
+ (vector-push-extend nil heap)
+ (loop for i = (1- (length heap)) then parent-i
+ for parent-i = (heap-parent i)
+ while (and (> i 0)
+ (not (ge (key (aref heap parent-i))
+ (key new-item))))
+ do (setf (aref heap i) (aref heap parent-i))
+ finally (setf (aref heap i) new-item)
+ (return-from heap-insert i))))
+
+(defun heap-maximum (heap)
+ (unless (zerop (length heap))
+ (aref heap 0)))
+
+(defun heap-extract (heap i &key (key #'identity) (test #'>=))
+ (when (< (length heap) i)
+ (error "Heap underflow"))
+ (prog1
+ (aref heap i)
+ (setf (aref heap i) (aref heap (1- (length heap))))
+ (decf (fill-pointer heap))
+ (heapify heap i :key key :test test)))
+
+(defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
+ (heap-extract heap 0 :key key :test test))
+
+;;; Priority queue
+
+(defstruct (priority-queue
+ (:conc-name %pqueue-)
+ (:constructor %make-priority-queue))
+ contents
+ keyfun)
+
+(defun make-priority-queue (&key (key #'identity) (element-type t))
+ (let ((contents (make-array 100
+ :adjustable t
+ :fill-pointer 0
+ :element-type element-type)))
+ (%make-priority-queue :keyfun key
+ :contents contents)))
+
+(def!method print-object ((object priority-queue) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~[empty~:;~:*~D item~:P~]"
+ (length (%pqueue-contents object)))))
+
+(defun priority-queue-maximum (priority-queue)
+ "Return the item in PRIORITY-QUEUE with the largest key."
+ (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
+ (unless (zerop (length contents))
+ (heap-maximum contents))))
+
+(defun priority-queue-extract-maximum (priority-queue)
+ "Remove and return the item in PRIORITY-QUEUE with the largest key."
+ (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+ (keyfun (%pqueue-keyfun priority-queue)))
+ (unless (zerop (length contents))
+ (heap-extract-maximum contents :key keyfun :test #'<=))))
+
+(defun priority-queue-insert (priority-queue new-item)
+ "Add NEW-ITEM to PRIOIRITY-QUEUE."
+ (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+ (keyfun (%pqueue-keyfun priority-queue)))
+ (heap-insert contents new-item :key keyfun :test #'<=)))
+
+(defun priority-queue-empty-p (priority-queue)
+ (zerop (length (%pqueue-contents priority-queue))))
+
+(defun priority-queue-remove (priority-queue item &key (test #'eq))
+ "Remove and return ITEM from PRIORITY-QUEUE."
+ (symbol-macrolet ((contents (%pqueue-contents priority-queue))
+ (keyfun (%pqueue-keyfun priority-queue)))
+ (let ((i (position item contents :test test)))
+ (when i
+ (heap-extract contents i :key keyfun :test #'<=)
+ i))))
+
+;;; timers
+
+(defstruct (timer
+ (:conc-name %timer-)
+ (:constructor %make-timer))
+ name
+ function
+ expire-time
+ repeat-interval
+ (thread nil :type (or sb!thread:thread (member t nil))))
+
+(def!method print-object ((timer timer) stream)
+ (let ((name (%timer-name timer)))
+ (if name
+ (print-unreadable-object (timer stream :type t :identity t)
+ (prin1 name stream))
+ (print-unreadable-object (timer stream :type t :identity t)
+ ;; body is empty => there is only one space between type and
+ ;; identity
+ ))))
+
+(defun make-timer (function &key name (thread sb!thread:*current-thread*))
+ (%make-timer :name name :function function :thread thread))
+
+(defun timer-name (timer)
+ (%timer-name timer))
+
+(defun timer-expired-p (timer &optional (delta 0))
+ (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))))))
+
+;;; 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)))
+
+(defun under-scheduler-lock-p ()
+ #!-sb-thread
+ t
+ #!+sb-thread
+ (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
+
+(defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
+
+(defun peek-schedule ()
+ (priority-queue-maximum *schedule*))
+
+(defun time-left (timer)
+ (- (%timer-expire-time timer) (get-internal-real-time)))
+
+;;; real time conversion
+
+(defun delta->real (delta)
+ (floor (* delta internal-time-units-per-second)))
+
+;;; Public interface
+
+(defun %schedule-timer (timer)
+ (let ((changed-p nil))
+ (when (eql 0 (priority-queue-remove *schedule* timer))
+ (setq changed-p t))
+ (when (zerop (priority-queue-insert *schedule* timer))
+ (setq changed-p t))
+ (when changed-p
+ (set-system-timer)))
+ (values))
+
+(defun schedule-timer (timer time &key repeat-interval absolute-p)
+ (with-scheduler-lock ()
+ (setf (%timer-expire-time timer) (+ (get-internal-real-time)
+ (delta->real
+ (if absolute-p
+ (- time (get-universal-time))
+ time)))
+ (%timer-repeat-interval timer) (if repeat-interval
+ (delta->real repeat-interval)
+ nil))
+ (%schedule-timer timer)))
+
+(defun unschedule-timer (timer)
+ (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)))
+ (values))
+
+(defun list-all-timers ()
+ (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)))
+
+;;; 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 set-system-timer ()
+ (assert (under-scheduler-lock-p))
+ (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))))
+
+(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)))))))
+
+(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))))
+
+(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)))))
(slot (slot itvo 'it-value) 'tv-usec))
which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
-(defmacro sb!ext:with-timeout (expires &body body)
- "Execute the body, interrupting it with a SIGALRM after at least
-EXPIRES seconds have passed. Uses Unix setitimer(), restoring any
-previous timer after the body has finished executing"
- (with-unique-names (saved-seconds saved-useconds s u)
- `(let (- ,saved-seconds ,saved-useconds)
- (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
- (unix-getitimer :real))
- (multiple-value-bind (,s ,u) (floor ,expires)
- (setf ,u (floor (* ,u 1000000)))
- (if (and (> ,expires 0)
- (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
- (> ,saved-seconds ,s)
- (and (= ,saved-seconds ,s)
- (> ,saved-useconds ,u))))
- (unwind-protect
- (progn
- (unix-setitimer :real 0 0 ,s ,u)
- ,@body)
- (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
- (progn
- ,@body))))))
\f
;;; FIXME: Many Unix error code definitions were deleted from the old
;;; CMU CL source code here, but not in the exports of SB-UNIX. I
`(progn
,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
-
-
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+(use-package :test-util)
+
+(with-test (:name (:timer :relative))
+ (let* ((has-run-p nil)
+ (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+ :name "simple timer")))
+ (sb-impl::schedule-timer timer 0.5)
+ (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*))))))
+
+(with-test (:name (:timer :absolute))
+ (let* ((has-run-p nil)
+ (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+ :name "simple timer")))
+ (sb-impl::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)))
+
+#+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)))
+
+(with-test (:name (:timer :repeat-and-unschedule))
+ (let* ((run-count 0)
+ timer)
+ (setq timer
+ (sb-impl::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)))
+ (sleep 1.3)
+ (assert (= 5 run-count))
+ (assert (sb-impl::timer-expired-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 ()
+ (setq has-run-p t)))))
+ (sb-impl::schedule-timer timer 0.2)
+ (sb-impl::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))
+ (sleep 2)
+ (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(defmacro raises-timeout-p (&body body)
+ `(handler-case (progn (progn ,@body) nil)
+ (sb-ext:timeout () t)))
+
+(with-test (:name (:with-timeout :timeout))
+ (assert (raises-timeout-p
+ (sb-ext:with-timeout 0.2
+ (sleep 1)))))
+
+(with-test (:name (:with-timeout :fall-through))
+ (assert (not (raises-timeout-p
+ (sb-ext:with-timeout 0.3
+ (sleep 0.1))))))
+
+(with-test (:name (:with-timeout :nested-timeout-smaller))
+ (assert(raises-timeout-p
+ (sb-ext:with-timeout 10
+ (sb-ext:with-timeout 0.5
+ (sleep 2))))))
+
+(with-test (:name (:with-timeout :nested-timeout-bigger))
+ (assert(raises-timeout-p
+ (sb-ext:with-timeout 0.5
+ (sb-ext:with-timeout 2
+ (sleep 2))))))
projects / sbcl.git / commitdiff