Author: ctian
Date: Tue Mar 29 07:49:05 2011
New Revision: 596
Log:
[SBCL] switch to a async unwind safe version of %WITH-TIMEOUT (Nikodemus Siivola)
Modified:
usocket/branches/0.5.x/backend/sbcl.lisp
Modified: usocket/branches/0.5.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.5.x/backend/sbcl.lisp (original)
+++ usocket/branches/0.5.x/backend/sbcl.lisp Tue Mar 29 07:49:05 2011
@@ -210,21 +210,42 @@
(close stream)
stream))
-;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads.
-;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29
+;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch
+;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS
+;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than
+;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus(a)random-state.net>
#+sbcl
-(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body)
- (let ((tag-sym (gensym))
- (timer-sym (gensym)))
- `(block ,tag-sym
- (let ((,timer-sym
- (sb-ext:make-timer
- #'(lambda ()
- (return-from ,tag-sym (progn ,@timeout-body))))))
- (sb-ext:schedule-timer ,timer-sym ,seconds)
- (unwind-protect (progn ,@timed-body)
- (sb-ext:unschedule-timer ,timer-sym))))))
+(defmacro %with-timeout ((seconds timeout-form) &body body)
+ "Runs BODY as an implicit PROGN with timeout of SECONDS. If
+timeout occurs before BODY has finished, BODY is unwound and
+TIMEOUT-FORM is executed with its values returned instead.
+
+Note that BODY is unwound asynchronously when a timeout occurs,
+so unless all code executed during it -- including anything
+down the call chain -- is asynch unwind safe, bad things will
+happen. Use with care."
+ (let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
+ (timeout (gensym)) (block (gensym)))
+ `(block ,block
+ (tagbody
+ (flet ((,unwind ()
+ (go ,timeout))
+ (,exec ()
+ ,@body))
+ (declare (dynamic-extent #',exec #',unwind))
+ (let ((,timer (sb-ext:make-timer #',unwind)))
+ (declare (dynamic-extent ,timer))
+ (sb-sys:without-interrupts
+ (unwind-protect
+ (progn
+ (sb-ext:schedule-timer ,timer ,seconds)
+ (return-from ,block
+ (sb-sys:with-local-interrupts
+ (,exec))))
+ (sb-ext:unschedule-timer ,timer)))))
+ ,timeout
+ (return-from ,block ,timeout-form)))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
