X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftimer.lisp;h=065b4c22e6e6007733b14b4a7d5ad19eba787472;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=d7c0c13db3586ffb5cda7fee21261e428d1d5dcd;hpb=ae09f8fd7765f6cab6ad317a13e27ff22ab0c11e;p=sbcl.git

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index d7c0c13..065b4c2 100644
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -16,7 +16,7 @@
 (declaim (inline heap-parent heap-left heap-right))
 
 (defun heap-parent (i)
-  (ash i -1))
+  (ash (1- i) -1))
 
 (defun heap-left (i)
   (1+ (ash i 1)))
@@ -363,11 +363,19 @@ triggers."
       (when (or (null timer)
                 (< (get-internal-real-time)
                    (%timer-expire-time timer)))
+        ;; Seemingly this is a spurious SIGALRM, but play it safe and
+        ;; reset the system timer because if the system clock was set
+        ;; back after the SIGALRM had been delivered then we won't get
+        ;; another chance.
+        (set-system-timer)
         (return-from run-expired-timers nil))
       (assert (eq timer (priority-queue-extract-maximum *schedule*)))
       (set-system-timer))
     (run-timer timer)))
 
+(defun timeout-cerror ()
+  (cerror "Continue" 'sb!ext::timeout))
+
 (defmacro sb!ext:with-timeout (expires &body body)
   #!+sb-doc
   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
@@ -390,14 +398,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)))))