From: Gabor Melis Date: Sun, 4 Sep 2005 20:14:46 +0000 (+0000) Subject: 0.9.4.26: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=40a26a4dd7f2891e78421ba465b99bb67f892856;p=sbcl.git 0.9.4.26: * added timer/scheduler based on setitimer that works with threads (interface not public, yet) * with-timeout now uses said scheduler --- diff --git a/NEWS b/NEWS index 37f8e36..af54853 100644 --- a/NEWS +++ b/NEWS @@ -33,6 +33,7 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: ** bug fix: interrupt handlers are now per-process, RUN-PROGRAM and SB-SPROF do not die with 'no handler for signal XX in interrupt_handle_now(..)' anymore + ** bug fix: WITH-TIMEOUT works with multiple running threads * fixed some bugs revealed by Paul Dietz' test suite: ** ENSURE-GENERIC-FUNCTION should take a method class object for the :method-class keyword argument. diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 9db6817..380b26a 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -277,6 +277,7 @@ ("src/code/sort" :not-host) ("src/code/time" :not-host) + ("src/code/timer" :not-host) ("src/code/weak" :not-host) ("src/code/final" :not-host) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 97bc95e..4d3e40e 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -121,7 +121,7 @@ (defun sigalrm-handler (signal info context) (declare (ignore signal info context)) (declare (type system-area-pointer context)) - (cerror "Continue" 'sb!ext::timeout)) + (sb!impl::run-expired-timers)) (defun sigquit-handler (signal code context) (declare (ignore signal code context)) diff --git a/src/code/timer.lisp b/src/code/timer.lisp new file mode 100644 index 0000000..a38d98e --- /dev/null +++ b/src/code/timer.lisp @@ -0,0 +1,302 @@ +;;;; 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))))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 95f8fb1..1d922ef 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -782,28 +782,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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)))))) ;;; 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 @@ -1026,5 +1004,3 @@ previous timer after the body has finished executing" `(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)))) - - diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp new file mode 100644 index 0000000..d07a7a0 --- /dev/null +++ b/tests/timer.impure.lisp @@ -0,0 +1,109 @@ +;;;; 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)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 8b44167..1920ab4 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.25" +"0.9.4.26"