Files old-darcsbcl/clean.sh-binary.tar and new-darcsbcl/clean.sh-binary.tar differ diff -rN -u old-darcsbcl/src/code/target-signal.lisp new-darcsbcl/src/code/target-signal.lisp --- old-darcsbcl/src/code/target-signal.lisp 2006-05-04 10:30:31.747488750 +0200 +++ new-darcsbcl/src/code/target-signal.lisp 2006-05-04 10:30:32.239519500 +0200 @@ -129,7 +129,17 @@ (defun sigalrm-handler (signal info context) (declare (ignore signal info context)) (declare (type system-area-pointer context)) - (sb!impl::run-expired-timers)) + (sb!impl::run-expired-timers :real)) + +(defun sigvtalrm-handler (signal info context) + (declare (ignore signal info context)) + (declare (type system-area-pointer context)) + (sb!impl::run-expired-timers :virtual)) + +(defun sigprof-handler (signal info context) + (declare (ignore signal info context)) + (declare (type system-area-pointer context)) + (sb!impl::run-expired-timers :profile)) (defun sigterm-handler (signal code context) (declare (ignore signal code context)) @@ -158,6 +168,8 @@ (enable-interrupt sigsys #'sigsys-handler) (ignore-interrupt sigpipe) (enable-interrupt sigalrm #'sigalrm-handler) + (enable-interrupt sigvtalrm #'sigvtalrm-handler) + (enable-interrupt sigprof #'sigprof-handler) (sb!unix::reset-signal-mask) (values)) diff -rN -u old-darcsbcl/src/code/timer.lisp new-darcsbcl/src/code/timer.lisp --- old-darcsbcl/src/code/timer.lisp 2006-05-04 10:30:31.747488750 +0200 +++ new-darcsbcl/src/code/timer.lisp 2006-05-04 10:30:32.239519500 +0200 @@ -160,7 +160,10 @@ repeat-interval (thread nil :type (or sb!thread:thread (member t nil))) interrupt-function - cancel-function) + cancel-function + ;; timer type, see "which" parameter in setitimer + which + priority-queue) (def!method print-object ((timer timer) stream) (let ((name (%timer-name timer))) @@ -172,14 +175,14 @@ ;; identity )))) -(defun make-timer (function &key name (thread sb!thread:*current-thread*)) +(defun make-timer (function &key name (thread sb!thread:*current-thread*) (which :real)) #!+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)) + (%make-timer :name name :function function :thread thread :which which :priority-queue (%which-to-priority-queue which))) (defun timer-name (timer) #!+sb-doc @@ -213,10 +216,16 @@ #!+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*)) +(defparameter *schedule-real* (make-priority-queue :key #'%timer-expire-time)) +(defparameter *schedule-virtual* (make-priority-queue :key #'%timer-expire-time)) +(defparameter *schedule-profile* (make-priority-queue :key #'%timer-expire-time)) + +(declaim (inline %which-to-priority-queue)) +(defun %which-to-priority-queue (which) + (ecase which + (:real *schedule-real*) + (:virtual *schedule-virtual*) + (:profile *schedule-profile*))) (defun time-left (timer) (- (%timer-expire-time timer) (get-internal-real-time))) @@ -230,21 +239,21 @@ (defun %schedule-timer (timer) (let ((changed-p nil) - (old-position (priority-queue-remove *schedule* timer))) + (old-position (priority-queue-remove (%timer-priority-queue timer) 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)) + (when (zerop (priority-queue-insert (%timer-priority-queue timer) 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))) + (set-system-timer (%timer-which timer)))) (values)) (defun schedule-timer (timer time &key repeat-interval absolute-p) @@ -280,18 +289,18 @@ (with-scheduler-lock () (setf (%timer-expire-time timer) nil (%timer-repeat-interval timer) nil) - (let ((old-position (priority-queue-remove *schedule* timer))) + (let ((old-position (priority-queue-remove (%timer-priority-queue timer) timer))) (when old-position (funcall (%timer-cancel-function timer))) (when (eql 0 old-position) - (set-system-timer)))) + (set-system-timer (%timer-which 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*)))) + (concatenate 'list (%pqueue-contents *schedule-real*) (%pqueue-contents *schedule-virtual*) (%pqueue-contents *schedule-profile*)))) ;;; Not public, but related @@ -313,15 +322,17 @@ (list 0 1) (list s u))))) -(defun set-system-timer () +(defun set-system-timer (which) + (declare (type (member :real :virtual :profile) which)) (assert (under-scheduler-lock-p)) - (let ((next-timer (peek-schedule))) + (let* ((queue (%which-to-priority-queue which)) + (next-timer (priority-queue-maximum queue))) (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)))) + which 0 0 (real-time->sec-and-usec delta))) + (sb!unix:unix-setitimer which 0 0 0 0)))) (defun run-timer (timer) (symbol-macrolet ((function (%timer-function timer)) @@ -340,22 +351,23 @@ (warn c))))))) ;; Called from the signal handler. -(defun run-expired-timers () +(defun run-expired-timers (which) (unwind-protect (with-interrupts - (let (timer) + (let (timer + (queue (%which-to-priority-queue which))) (loop (with-scheduler-lock () - (setq timer (peek-schedule)) + (setq timer (priority-queue-maximum queue)) (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*)))) + (assert (eq timer (priority-queue-extract-maximum queue)))) ;; run the timer without the lock (run-timer timer)))) (with-scheduler-lock () - (set-system-timer)))) + (set-system-timer which)))) (defmacro sb!ext:with-timeout (expires &body body) #!+sb-doc