Many lisps lack both a timeout form and timer functionality. On these
platforms, TRIVIAL-TIMEOUT:WITH-TIMEOUT runs its body in a separate
thread. This causes several issues:
- Dynamic bindings aren't accessible within the body. For example,
(defparameter *var* nil)
(let ((*var* t)) (with-timeout (1) (print *var*)))
will print NIL.
- Transfer of control to an exit point outside the body signals an
error in the body's thread.
- When WITH-TIMEOUT forms are nested, if an inner form times out
before an outer form, the TIMEOUT-ERROR it signals does not
propagate outside of the outer form's body.
On threadless SBCL, WITH-TIMEOUT runs the body in the current thread,
but first creates a timer that transfers control outside the body when
it runs out. This approach has the potential to overcome all of the
problems listed above, but the implementation is severely flawed:
- The result of the body is not preserved. When it returns,
WITH-TIMEOUT always returns NIL, regardless of the body.
- The timer is never destroyed, causing problems when the body
finishes before the timeout. There seems to have been a patch for
this a while back, but it does not seem to have been applied.
- When WITH-TIMEOUT forms are nested, each one always signals an error
when it times out, regardless of whether an error has been signalled
already.
This change fixes all of the above problems, and also adds support for
more implementations. It does this using the timer approach, but does so
in a way that avoids the problems trivial-timeout has heretofore had
with this approach on threadless SBCL. On implementations without timers,
timers are simulated by creating a thread which sleeps for the timeout
duration, and interrupts the main thread when it finishes.
To describe the improved implementation support, we'll need some
definitions. trivial-timeout is fully working on an implementation if
WITH-TIMEOUT forms timeout successfully, and none of the problems
described above exist. trivial-timeout is minimally working on an
implementation if it simply executes the body without ever timing out,
but nontheless without the above problems. trivial-timeout is working
poorly on an implementation if WITH-TIMEOUT forms time out successfully,
but some of the above problems still exist.
Here is the state of implementation support with this change:
Armed Bear: fully working (was: minimally working)
Allegro: fully working
Clozure: fully working (was: working poorly)
Threadless CLISP: minimally working
Threaded CLISP: fully working (was: minimally working)
CMU: minimally working (was: not working)
ECL: fully working (was: minimally working)
LispWorks: fully working (was: working poorly)
Threaded SBCL: fully working
Threadless SBCL: fully working (was: working poorly)
Note that CMU is here listed as minimally working, when by all rights it
ought to be fully working. This is because CMU's built-in with-timeout
form is only minimally working, at least for me. This is possibly just a
problem with my setup, but also possibly a problem with CMU itself. I
doubt this is a problem with trivial-timeout, given how trivial the code
is. This needs further investigation.
---
Notes:
If you're going to test this, remember that lift contains its own copy of
with-timeout, which might interfere with testing. In the future, You might
consider making trivial-timeout an external dependency of lift.
The code in with-timeout.lisp had weird indentation. This seems to be the
result of replacing tabs that represented eight spaces with only four
spaces. Are you sure you meant to do this?
dev/with-timeout.lisp | 239 ++++++++++++++++++++++--------------------
1 file changed, 123 insertions(+), 116 deletions(-)
diff --git a/dev/with-timeout.lisp b/dev/with-timeout.lisp
index 4f68591..fed5d06 100644
--- a/dev/with-timeout.lisp
+++ b/dev/with-timeout.lisp
@@ -1,123 +1,138 @@
(in-package #:com.metabang.trivial-timeout)
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(unless (and (find-symbol (symbol-name '#:with-timeout)
- '#:com.metabang.trivial-timeout)
- (fboundp (find-symbol (symbol-name '#:with-timeout)
- '#:com.metabang.trivial-timeout)))
(define-condition timeout-error (error)
- ()
+ ()
(:report (lambda (c s)
- (declare (ignore c))
- (format s "Process timeout")))
+ (declare (ignore c))
+ (format s "Process timeout")))
(:documentation "An error signaled when the duration specified in
the [with-timeout][] is exceeded."))
-#+allegro
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- `(mp:with-timeout (,seconds-symbol (error 'timeout-error))
- (,doit-symbol)))
+(define-condition interrupt () ())
+
+#+(or abcl digitool openmcl ccl ecl)
+(progn
+ (defvar *counter* 0)
+ (defun make-process-name ()
+ (format nil "Timing Process #~D" (prog1 *counter* (incf *counter*)))))
+
+#+abcl
+(progn
+ (defun schedule-timer (seconds deferred-function)
+ (let ((current (threads:current-thread))
+ (res (cons nil nil)))
+ (setf (cdr res)
+ (threads:make-thread
+ (lambda ()
+ (sleep seconds)
+ (unless (car res)
+ (threads:interrupt-thread current deferred-function)))
+ :name (make-process-name)))
+ res))
+
+ (defun unschedule-timer (timer)
+ ;; In ABCL, interrupting a sleeping thread can cause that thread to stop
+ ;; sleeping prematurely. Setting this to true ensures that we only interrupt
+ ;; threads when we want them to stop sleeping.
+ (setf (car timer) t)
+ (threads:destroy-thread (cdr timer))))
+#+(or digitool openmcl ccl)
+(progn
+ (defun schedule-timer (seconds deferred-function)
+ (let ((current ccl:*current-process*))
+ (ccl:process-run-function
+ (make-process-name)
+ (lambda ()
+ (sleep seconds)
+ (ccl:process-interrupt current deferred-function)))))
+
+ (defun unschedule-timer (timer) (ccl:process-kill timer)))
+
+#+ecl
+(progn
+ (defun schedule-timer (seconds deferred-function)
+ (let ((current mp:*current-process*)
+ (res (cons nil nil)))
+ (setf (cdr res)
+ (mp:process-run-function
+ (make-process-name)
+ (lambda ()
+ (sleep seconds)
+ ;; ECL hates seeing inactive processes interrupted.
+ (when (and (not (car res)) (mp:process-active-p current))
+ (ignore-errors
+ (mp:interrupt-process current deferred-function))))))
+ res))
+
+ (defun unschedule-timer (timer)
+ ;; Seemingly a similar issue to ABCL above, but the circumstances where it
+ ;; happens are more difficult to pin down.
+ (setf (car timer) t)
+ (when (mp:process-active-p (cdr timer))
+ (ignore-errors (mp:process-kill (cdr timer))))))
-#+(and sbcl (not sb-thread))
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- (let ((glabel (gensym "label-"))
- (gused-timer? (gensym "used-timer-")))
- `(let ((,gused-timer? nil))
- (catch ',glabel
- (sb-ext:schedule-timer
- (sb-ext:make-timer (lambda ()
- (setf ,gused-timer? t)
- (throw ',glabel nil)))
- ,seconds-symbol)
- (,doit-symbol))
- (when ,gused-timer?
- (error 'timeout-error)))))
+#+lispworks
+(progn
+ (defun schedule-timer (seconds deferred-function)
+ (let ((current (mp:get-current-process)))
+ (mp:schedule-timer-relative
+ (mp:make-timer
+ (lambda ()
+ (mp:process-interrupt current deferred-function)))
+ seconds)))
-#+(and sbcl sb-thread)
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- `(handler-case
- (sb-ext:with-timeout ,seconds-symbol (,doit-symbol))
- (sb-ext::timeout (c)
- (declare (ignore c))
+ (defun unschedule-timer (timer) (mp:unschedule-timer timer)))
+
+#+(and sbcl (not sb-thread))
+(progn
+ (defun schedule-timer (seconds deferred-function)
+ (let ((timer (sb-ext:make-timer deferred-function)))
+ (sb-ext:schedule-timer timer seconds)
+ timer))
+
+ (defun unschedule-timer (timer) (sb-ext:unschedule-timer timer)))
+
+#+(or abcl digitool openmcl ccl ecl lispworks (and sbcl (not sb-thread)))
+(defun timeout-call (seconds doit-function)
+ (handler-case
+ (let ((timer (schedule-timer
+ seconds (lambda ()
+ (restart-case (signal 'interrupt)
+ (continue ()))))))
+ (unwind-protect (return-from timeout-call (funcall doit-function))
+ (unschedule-timer timer)))
+ (interrupt ()))
+ (loop
+ ;; When with-timeout forms are nested, this handler ensures that only one
+ ;; error will be signalled.
+ (handler-bind ((interrupt (lambda (e)
+ (declare (ignore e))
+ (invoke-restart 'continue))))
(error 'timeout-error))))
-#+cmu
-;;; surely wrong
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- `(handler-case
- (mp:with-timeout (seconds-symbol) (,doit-symbol))
+#+(or allegro cmu)
+(defun timeout-call (seconds doit-function)
+ (mp:with-timeout (seconds (error 'timeout-error))
+ (funcall doit-function)))
+
+#+(and clisp mt)
+(defun timeout-call (seconds doit-function)
+ (mt:with-timeout (seconds (error 'timeout-error))
+ (funcall doit-function)))
+
+#+(and sbcl sb-thread)
+(defun timeout-call (seconds doit-function)
+ (handler-case
+ (sb-ext:with-timeout seconds (funcall doit-function))
(sb-ext::timeout (c)
(declare (ignore c))
(error 'timeout-error))))
-#+(or digitool openmcl ccl)
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- (let ((checker-process (format nil "Checker ~S" (gensym)))
- (waiting-process (format nil "Waiter ~S" (gensym)))
- (result (gensym))
- (process (gensym)))
- `(let* ((,result nil)
- (,process (ccl:process-run-function
- ,checker-process
- (lambda ()
- (setf ,result (multiple-value-list (,doit-symbol)))))))
- (ccl:process-wait-with-timeout
- ,waiting-process
- (* ,seconds-symbol #+(or openmcl ccl)
- ccl:*ticks-per-second* #+digitool 60)
- (lambda ()
- (not (ccl::process-active-p ,process))))
- (when (ccl::process-active-p ,process)
- (ccl:process-kill ,process)
- (cerror "Timeout" 'timeout-error))
- (values-list ,result))))
-
-#+(or digitool openmcl ccl)
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- (let ((gsemaphore (gensym "semaphore"))
- (gresult (gensym "result"))
- (gprocess (gensym "process")))
- `(let* ((,gsemaphore (ccl:make-semaphore))
- (,gresult)
- (,gprocess
- (ccl:process-run-function
- ,(format nil "Timed Process ~S" gprocess)
- (lambda ()
- (setf ,gresult (multiple-value-list (,doit-symbol)))
- (ccl:signal-semaphore ,gsemaphore)))))
- (cond ((ccl:timed-wait-on-semaphore ,gsemaphore ,seconds-symbol)
- (values-list ,gresult))
- (t
- (ccl:process-kill ,gprocess)
- (error 'timeout-error))))))
-
-#+lispworks
-(defun generate-platform-specific-code (seconds-symbol doit-symbol)
- (let ((gresult (gensym "result-"))
- (gprocess (gensym "process-")))
- `(let* (,gresult
- (,gprocess (mp:process-run-function
- "WITH-TIMEOUT"
- '()
- (lambda ()
- (setq ,gresult (multiple-value-list (,doit-symbol)))))))
- (unless (mp:process-wait-with-timeout
- "WITH-TIMEOUT"
- ,seconds-symbol
- (lambda ()
- (not (mp:process-alive-p ,gprocess))))
- (mp:process-kill ,gprocess)
- (cerror "Timeout" 'timeout-error))
- (values-list ,gresult))))
-
-(unless (let ((symbol
- (find-symbol (symbol-name '#:generate-platform-specific-code)
- '#:com.metabang.trivial-timeout)))
- (and symbol (fboundp symbol)))
- (defun generate-platform-specific-code (seconds-symbol doit-symbol)
- (declare (ignore seconds-symbol))
- `(,doit-symbol)))
+#-(or abcl allegro digitool openmcl ccl cmu ecl (and clisp mt) lispworks sbcl)
+(defun timeout-call (seconds doit-function)
+ (declare (ignore seconds))
+ (funcall doit-function))
(defmacro with-timeout ((seconds) &body body)
"Execute `body` for no more than `seconds` time.
@@ -126,18 +141,10 @@ If `seconds` is exceeded, then a [timeout-error][] will be signaled.
If `seconds` is nil, then the body will be run normally until it completes
or is interrupted."
- (build-with-timeout seconds body))
-
-(defun build-with-timeout (seconds body)
(let ((gseconds (gensym "seconds-"))
- (gdoit (gensym "doit-")))
+ (gdoit (gensym "doit-")))
`(let ((,gseconds ,seconds))
(flet ((,gdoit ()
- (progn ,@body)))
- (cond (,gseconds
- ,(generate-platform-specific-code gseconds gdoit))
- (t
- (,gdoit)))))))
-
-
-))
\ No newline at end of file
+ (progn ,@body)))
+ (cond (,gseconds (timeout-call ,gseconds #',gdoit))
+ (t (,gdoit)))))))
--
2.31.1
