diff -rN -u old-darcsbcl/contrib/sb-sprof/sb-sprof.lisp new-darcsbcl/contrib/sb-sprof/sb-sprof.lisp --- old-darcsbcl/contrib/sb-sprof/sb-sprof.lisp 2006-05-17 12:07:58.872395500 +0200 +++ new-darcsbcl/contrib/sb-sprof/sb-sprof.lisp 2006-05-17 12:07:59.784452500 +0200 @@ -572,8 +572,8 @@ ;;; SIGPROF handler. Record current PC and return address in ;;; *SAMPLES*. #+(or x86 x86-64) -(defun sigprof-handler (signal code scp) - (declare (ignore signal code) (type system-area-pointer scp)) +(defun %sigprof-handler (scp) + (declare (type system-area-pointer scp)) (sb-sys:with-interrupts (when (and *sampling* (< *samples-index* (length *samples*))) @@ -591,7 +591,7 @@ 4096) (dotimes (i +sample-size+) (record 0)) - (return-from sigprof-handler nil)) + (return-from %sigprof-handler nil)) (let* ((pc-ptr (sb-vm:context-pc scp)) (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))) (record (sap-int pc-ptr)) @@ -610,8 +610,7 @@ ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper ;; than one level. #-(or x86 x86-64) -(defun sigprof-handler (signal code scp) - (declare (ignore signal code)) +(defun %sigprof-handler (scp) (sb-sys:with-interrupts (when (and *sampling* (< *samples-index* (length *samples*))) @@ -626,6 +625,11 @@ (record (sap-int pc-ptr)) (record ra)))))))) +(defun sigprof-handler () + (%sigprof-handler (sb-impl::timer-current-signal-context))) + +(defvar *timer* (sb-ext:make-timer #'sigprof-handler :kind :profile)) + ;;; Map function FN over code objects in dynamic-space. FN is called ;;; with two arguments, the object and its size in bytes. (defun map-dynamic-space-code (fn) @@ -758,26 +762,21 @@ If true, the default, start sampling right away. If false, Start-Sampling can be used to turn sampling on." (unless *profiling* - (multiple-value-bind (secs usecs) - (multiple-value-bind (secs rest) - (truncate sample-interval) - (values secs (truncate (* rest 1000000)))) - (setq *samples* (make-array (* max-samples +sample-size+) - :element-type 'address)) - (setq *samples-index* 0) - (setq *sampling* sampling) - ;; Disabled for now, since this was causing some problems with the - ;; sampling getting turned off completely. --JES, 2004-06-19 - ;; - ;; BEFORE-GC-HOOKS have exceedingly bad interactions with - ;; threads. -- CSR, 2004-06-21 - ;; - ;; (pushnew 'turn-off-sampling *before-gc-hooks*) - (pushnew 'adjust-samples-for-address-changes *after-gc-hooks*) - (record-dyninfo) - (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler) - (unix-setitimer :profile secs usecs secs usecs) - (setq *profiling* t))) + (setq *samples* (make-array (* max-samples +sample-size+) + :element-type 'address)) + (setq *samples-index* 0) + (setq *sampling* sampling) + ;; Disabled for now, since this was causing some problems with the + ;; sampling getting turned off completely. --JES, 2004-06-19 + ;; + ;; BEFORE-GC-HOOKS have exceedingly bad interactions with + ;; threads. -- CSR, 2004-06-21 + ;; + ;; (pushnew 'turn-off-sampling *before-gc-hooks*) + (pushnew 'adjust-samples-for-address-changes *after-gc-hooks*) + (record-dyninfo) + (sb-ext:schedule-timer *timer* sample-interval :repeat-interval sample-interval) + (setq *profiling* t)) (values)) (defun stop-profiling () @@ -785,7 +784,7 @@ (when *profiling* (setq *after-gc-hooks* (delete 'adjust-samples-for-address-changes *after-gc-hooks*)) - (unix-setitimer :profile 0 0 0 0) + (sb-ext:unschedule-timer *timer*) ;; Even with the timer shut down we cannot be sure that there is ;; no undelivered sigprof. Besides, leaving the signal handler ;; installed won't hurt. 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-17 12:07:59.044406250 +0200 +++ new-darcsbcl/src/code/target-signal.lisp 2006-05-17 12:08:00.000466000 +0200 @@ -127,9 +127,19 @@ (define-signal-handler sigsys-handler "bad argument to a system call") (defun sigalrm-handler (signal info context) - (declare (ignore signal info context)) + (declare (ignore signal)) (declare (type system-area-pointer context)) - (sb!impl::run-expired-timers)) + (sb!impl::run-expired-timers :real info context)) + +(defun sigvtalrm-handler (signal info context) + (declare (ignore signal)) + (declare (type system-area-pointer context)) + (sb!impl::run-expired-timers :virtual info context)) + +(defun sigprof-handler (signal info context) + (declare (ignore signal)) + (declare (type system-area-pointer context)) + (sb!impl::run-expired-timers :profile info context)) (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-17 12:07:59.136412000 +0200 +++ new-darcsbcl/src/code/timer.lisp 2006-05-17 12:08:00.004466250 +0200 @@ -146,6 +146,26 @@ (sb!thread:with-recursive-lock (mutex) (setq cancelled-p t)))))) +;;; Additional information about the context in which a timer was +;;; triggered (i.e. required for profiling). When invoked, FUNCTION of +;;; timer can retrieve info and context as delivered to the signal +;;; handler by calling timer-current-signal-content or +;;; timer-current-signal-info. + +(defvar *signal-info*) +(defvar *signal-context*) + +(defun timer-current-signal-context () + "Returns signal-context as delivered to the timer signal +handler. Must be called within the dynamic extend of a timer +function." + *signal-context*) + +(defun timer-current-signal-info () + "Returns signal-info as delivered to the timer signal handler. Must +be called within the dynamic extend of a timer function." + *signal-info*) + ;;; timers (defstruct (timer @@ -160,7 +180,9 @@ 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 + kind) (def!method print-object ((timer timer) stream) (let ((name (%timer-name timer))) @@ -172,14 +194,18 @@ ;; identity )))) -(defun make-timer (function &key name (thread sb!thread:*current-thread*)) +(defun make-timer (function &key name (thread sb!thread:*current-thread*) + (kind :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)) +thread. Valid choices for KIND are :real (decrements in real +time), :virtual (decrements only when the process is executing), +and :profile (decrements both when the process executes and when +the system is executing on behalf of the process)." + (%make-timer :name name :function function :thread thread :kind kind)) (defun timer-name (timer) #!+sb-doc @@ -213,10 +239,17 @@ #!+sb-thread (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*))) -(defparameter *schedule* (make-priority-queue :key #'%timer-expire-time)) +(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)) + +(defun %kind-to-priority-queue (kind) + (ecase kind + (:real *schedule-real*) + (:virtual *schedule-virtual*) + (:profile *schedule-profile*))) -(defun peek-schedule () - (priority-queue-maximum *schedule*)) +(defun %timer-priority-queue (timer) (%kind-to-priority-queue (%timer-kind timer))) (defun time-left (timer) (- (%timer-expire-time timer) (get-internal-real-time))) @@ -230,21 +263,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-kind timer)))) (values)) (defun schedule-timer (timer time &key repeat-interval absolute-p) @@ -280,18 +313,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-kind 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,49 +346,60 @@ (list 0 1) (list s u))))) -(defun set-system-timer () +(defun set-system-timer (kind) + (declare (type (member :real :virtual :profile) kind)) (assert (under-scheduler-lock-p)) - (let ((next-timer (peek-schedule))) + (let* ((queue (%kind-to-priority-queue kind)) + (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)))) + kind 0 0 (real-time->sec-and-usec delta))) + (sb!unix:unix-setitimer kind 0 0 0 0)))) -(defun run-timer (timer) +(defun run-timer (timer info context) (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)) + (let ((*signal-info* info) + (*signal-context* context)) + (funcall function))) ((eq t thread) - (sb!thread:make-thread function)) + (sb!thread:make-thread (lambda () + (let ((*signal-info* info) + (*signal-context* context)) + (funcall function))))) (t (handler-case - (sb!thread:interrupt-thread thread function) + (sb!thread:interrupt-thread thread (lambda () + (let ((*signal-info* info) + (*signal-context* context)) + (funcall function)))) (sb!thread:interrupt-thread-error (c) (warn c))))))) ;; Called from the signal handler. -(defun run-expired-timers () +(defun run-expired-timers (kind info context) (unwind-protect (with-interrupts - (let (timer) + (let (timer + (queue (%kind-to-priority-queue kind))) (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)))) + (run-timer timer info context)))) (with-scheduler-lock () - (set-system-timer)))) + (set-system-timer kind)))) (defmacro sb!ext:with-timeout (expires &body body) #!+sb-doc diff -rN -u old-darcsbcl/tests/timer.impure.lisp new-darcsbcl/tests/timer.impure.lisp --- old-darcsbcl/tests/timer.impure.lisp 2006-05-17 12:07:59.736449500 +0200 +++ new-darcsbcl/tests/timer.impure.lisp 2006-05-17 12:08:00.248481500 +0200 @@ -13,16 +13,39 @@ (use-package :test-util) -(with-test (:name (:timer :relative)) +(with-test (:name (:timer :relative :real)) (let* ((has-run-p nil) (timer (make-timer (lambda () (setq has-run-p t)) - :name "simple timer"))) + :name "simple timer" + :kind :real))) (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*)))))) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*)))))) + +(with-test (:name (:timer :relative :virtual)) + (let* ((has-run-p nil) + (killed-p nil) + (timer (make-timer (lambda () (setq has-run-p t)) + :name "simple timer" + :kind :virtual)) + (timer-killer (make-timer (lambda () (setq killed-p t)) + :name "used for terminating a failing test case" + :kind :real))) + (schedule-timer timer 0.5) + (schedule-timer timer-killer 10) + ;; should not burn CPU time + (sleep 1) + (assert (not has-run-p)) + ;; burn CPU time with fallback to real time killer + (do () + ((or has-run-p killed-p))) + (assert (not killed-p)) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-virtual*)))) + (assert (not (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*))))) + (unschedule-timer timer-killer))) (with-test (:name (:timer :absolute)) (let* ((has-run-p nil) @@ -33,7 +56,7 @@ (assert (not has-run-p)) (sleep 0.5) (assert has-run-p) - (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*)))))) #+sb-thread (with-test (:name (:timer :other-thread)) @@ -65,7 +88,7 @@ (sleep 1.3) (assert (= 5 run-count)) (assert (not (timer-scheduled-p timer))) - (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*)))))) (with-test (:name (:timer :reschedule)) (let* ((has-run-p nil) @@ -75,14 +98,14 @@ (schedule-timer timer 0.3) (sleep 0.5) (assert has-run-p) - (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*)))))) (with-test (:name (:timer :stress)) (let ((time (1+ (get-universal-time)))) (loop repeat 200 do (schedule-timer (make-timer (lambda ())) time :absolute-p t)) (sleep 2) - (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) + (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule-real*)))))) (defmacro raises-timeout-p (&body body) `(handler-case (progn (progn ,@body) nil)