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)

