refactor GET-TOPLEVEL-FORM &co between debugger and disassembler

[sbcl.git] / src / code / timer.lisp

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index 5a1f4fa..88b9c1d 100644 (file)
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -156,14 +156,15 @@ future versions."
 
 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
   #!+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. When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION
-and the ordering guarantees of INTERRUPT-THREAD also apply here.
-FUNCTION always runs with interrupts disabled but WITH-INTERRUPTS is
-allowed."
+  "Create a timer that runs FUNCTION when triggered.
+
+If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
+T, a new thread is created for FUNCTION each time the timer is
+triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
+
+When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
+ordering guarantees of INTERRUPT-THREAD apply. FUNCTION runs with
+interrupts disabled but WITH-INTERRUPTS is allowed."
   (%make-timer :name name :function function :thread thread))
 
 (defun timer-name (timer)
@@ -285,6 +286,8 @@ triggers."
     (setf (%timer-expire-time timer) nil
           (%timer-repeat-interval timer) nil)
     (let ((old-position (priority-queue-remove *schedule* timer)))
+      ;; Don't use cancel-function as the %timer-cancel-function
+      ;; may have changed before we got the scheduler lock.
       (when old-position
         (funcall (%timer-cancel-function timer)))
       (when (eql 0 old-position)
@@ -355,18 +358,29 @@ triggers."
               (warn "Timer ~S failed to interrupt thread ~S."
                     timer thread)))))))
 
-;;; Called from the signal handler.
+;;; Called from the signal handler. We loop until all the expired timers
+;;; have been run.
 (defun run-expired-timers ()
-  (let (timer)
-    (with-scheduler-lock ()
-      (setq timer (peek-schedule))
-      (when (or (null timer)
-                (< (get-internal-real-time)
-                   (%timer-expire-time timer)))
-        (return-from run-expired-timers nil))
-      (assert (eq timer (priority-queue-extract-maximum *schedule*)))
-      (set-system-timer))
-    (run-timer timer)))
+  (loop
+    (let ((now (get-internal-real-time))
+          (timers nil))
+      (flet ((run-timers ()
+               (dolist (timer (nreverse timers))
+                 (run-timer timer))))
+        (with-scheduler-lock ()
+          (loop for timer = (peek-schedule)
+                when (or (null timer) (< now (%timer-expire-time timer)))
+                ;; No more timers to run for now, reset the system timer.
+                do (run-timers)
+                   (set-system-timer)
+                   (return-from run-expired-timers nil)
+                else
+                do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
+                   (push timer timers)))
+        (run-timers)))))
+
+(defun timeout-cerror ()
+  (cerror "Continue" 'sb!ext::timeout))
 
 (defmacro sb!ext:with-timeout (expires &body body)
   #!+sb-doc
@@ -390,14 +404,13 @@ against asynchronous unwinds, this doesn't solve the fundamental issue, as all
 the frames potentially unwound through need to be proofed, which includes both
 system and application code -- and in essence proofing everything will make
 the system uninterruptible."
-  (with-unique-names (timer)
-    ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
-    ;; unwinds are handled revisit it.
-    `(if (> ,expires 0)
-         (let ((,timer (make-timer (lambda ()
-                                     (cerror "Continue" 'sb!ext::timeout)))))
-           (schedule-timer ,timer ,expires)
-           (unwind-protect
-                (progn ,@body)
-             (unschedule-timer ,timer)))
-         (progn ,@body))))
+  `(dx-flet ((timeout-body () ,@body))
+     (let ((expires ,expires))
+       ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
+       ;; unwinds are handled revisit it.
+       (if (> expires 0)
+           (let ((timer (make-timer #'timeout-cerror)))
+             (schedule-timer timer expires)
+             (unwind-protect (timeout-body)
+               (unschedule-timer timer)))
+           (timeout-body)))))