From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 5 May 2009 10:53:16 +0000 (+0000)
Subject: 1.0.28.13: quiet WITH-TIMEOUT when used with constant EXPIRES argument
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=80356ce0ff12379e93a9df74dd65433c415f7aae;p=sbcl.git

1.0.28.13: quiet WITH-TIMEOUT when used with constant EXPIRES argument

 * Don't copy the body so as to avoid the compiler note for deleting
   either leg, which happens when EXPIRES is a constant.
---

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index 5a1f4fa..b84168a 100644
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -368,6 +368,9 @@ triggers."
       (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 +393,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)))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f2cba5f..14603df 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2871,3 +2871,9 @@
                          (adjust-array y '(3 5))
                          (array-dimension y 0))))))
     (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
+
+(with-test (:name :with-timeout-code-deletion-note)
+  (handler-bind ((sb-ext:code-deletion-note #'error))
+    (compile nil `(lambda ()
+                    (sb-ext:with-timeout 0
+                      (sleep 1))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index de59ab4..5e6d68f 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.12"
+"1.0.28.13"