From b93cd5f21f8161783f8d40fb6ade28aa04ecf193 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Sun, 28 Mar 2010 17:35:37 +0000 Subject: [PATCH] 1.0.37.6: Add SB-SYS:CANCEL-DEADLINE restart to DEADLINE-TIMEOUTs. * Establish an SB-SYS:CANCEL-DEADLINE restart in SIGNAL-DEADLINE. * Add an SB-SYS:CANCEL-DEADLINE restart function. * Make SB-INT:READ-EVALUATED-FORM take an optional prompt. This function is commonly used to query the user for input in restarts. Use it in the SB-SYS:DEFER-DEADLINE restart in SIGNAL-DEADLINE. * Bind *DEADLINE-SECONDS* in SB-THREAD:MAKE-THREAD. Not binding it does not seem to have severe consequences, but that's not obvious so just bind both so humans won't waste brain cycles on it. SB-KERNEL:SUB-GC also binds both. * Add usage of WITH-TEST to tests/deadline.impure.lisp. Also add a test case for the new CANCEL-DEADLINE restart. --- NEWS | 2 + package-data-list.lisp-expr | 1 + src/code/deadline.lisp | 19 +++++-- src/code/target-error.lisp | 7 ++- src/code/target-thread.lisp | 1 + tests/deadline.impure.lisp | 126 ++++++++++++++++++++++++++----------------- version.lisp-expr | 2 +- 7 files changed, 103 insertions(+), 55 deletions(-) diff --git a/NEWS b/NEWS index c0d524e..9873b69 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,8 @@ changes relative to sbcl-1.0.36: SB-THREAD:WAIT-ON-SEMAPHORE. * new feature: SB-EXT:ATOMIC-DECF has been added as a companion to SB-EXT:ATOMIC-INCF. + * new feature: a CANCEL-DEADLINE is associated with DEADLINE-TIMEOUT + conditions to defer the deadline for forever. * enhancement: *STANDARD-OUTPUT*, *STANDARD-INPUT*, and *ERROR-OUTPUT* are now bivalent. * enhancement: errors from NO-APPLICABLE-METHOD and diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 87913c8..3352d07 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2251,6 +2251,7 @@ SB-KERNEL) have been undone, but probably more remain." "ALLOW-WITH-INTERRUPTS" "BEEP" "BREAKPOINT-ERROR" + "CANCEL-DEADLINE" "CLOSE-SHARED-OBJECTS" "DEADLINE-TIMEOUT" "DEALLOCATE-SYSTEM-MEMORY" diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 6deb829..97a147b 100644 --- a/src/code/deadline.lisp +++ b/src/code/deadline.lisp @@ -88,20 +88,31 @@ for calling this when a deadline is reached." (error 'deadline-timeout :seconds *deadline-seconds*) (defer-deadline (&optional (seconds *deadline-seconds*)) :report "Defer the deadline for SECONDS more." + :interactive (lambda () + (sb!int:read-evaluated-form + "By how many seconds shall the deadline ~ + be deferred?: ")) (let* ((new-deadline-seconds (coerce seconds 'single-float)) (new-deadline (+ (seconds-to-internal-time new-deadline-seconds) (get-internal-real-time)))) (setf *deadline* new-deadline - *deadline-seconds* new-deadline-seconds))))) + *deadline-seconds* new-deadline-seconds))) + (cancel-deadline () + :report "Cancel the deadline and continue." + (setf *deadline* nil *deadline-seconds* nil)))) nil) (defun defer-deadline (seconds &optional condition) "Find the DEFER-DEADLINE restart associated with CONDITION, and -calls it with SECONDS as argument (deferring the deadline by that many -seconds.) Continues from the indicated restart, or returns NIL if the -restart is not found." +invoke it with SECONDS as argument (deferring the deadline by that many +seconds.) Otherwise return NIL if the restart is not found." (try-restart 'defer-deadline condition seconds)) +(defun cancel-deadline (&optional condition) + "Find and invoke the CANCEL-DEADLINE restart associated with +CONDITION, or return NIL if the restart is not found." + (try-restart 'cancel-deadline condition)) + ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP ;;; ;;; Takes *DEADLINE* into account: if it occurs before given SECONDS, diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 035d44a..85b2215 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -156,8 +156,11 @@ with that condition (or with no condition) will be returned." ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros ;;; and by CHECK-TYPE. -(defun read-evaluated-form () - (format *query-io* "~&Type a form to be evaluated:~%") +(defun read-evaluated-form (&optional (prompt-control nil promptp) + &rest prompt-args) + (apply #'format *query-io* + (if promptp prompt-control "~&Type a form to be evaluated: ") + prompt-args) (list (eval (read *query-io*)))) (defun check-type-error (place place-value type type-string) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index eaf1692..48417e7 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -918,6 +918,7 @@ around and can be retrieved by JOIN-THREAD." (*handler-clusters* (sb!kernel::initial-handler-clusters)) (*condition-restarts* nil) (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp index 10bae09..e4b077e 100644 --- a/tests/deadline.impure.lisp +++ b/tests/deadline.impure.lisp @@ -1,3 +1,7 @@ +(in-package :cl-user) + +(use-package :test-util) + (defmacro assert-timeout (form) (let ((ok (gensym "OK"))) `(let ((,ok ',ok)) @@ -7,60 +11,86 @@ ,ok))) (error "No timeout from form:~% ~S" ',form))))) +(defun run-sleep (seconds) + (sb-ext:run-program "sleep" (list (format nil "~D" seconds)) + :search t :wait t)) -(assert-timeout - (sb-sys:with-deadline (:seconds 1) - (run-program "sleep" '("3") :search t :wait t))) +(with-test (:name (:deadline :run-program :trivial)) + (assert-timeout (sb-sys:with-deadline (:seconds 1) + (run-sleep 3)))) -(let ((n 0) - (final nil)) - (handler-case - (handler-bind ((sb-sys:deadline-timeout (lambda (c) - (when (< n 2) - (incf n) - (sb-sys:defer-deadline 0.1 c))))) - (sb-sys:with-deadline (:seconds 1) - (run-program "sleep" '("2") :search t :wait t))) - (sb-sys:deadline-timeout (c) - (setf final c))) - (assert (= n 2)) - (assert final)) +(with-test (:name (:deadline :defer-deadline-1)) + (let ((n 0) + (final nil)) + (handler-case + (handler-bind ((sb-sys:deadline-timeout + #'(lambda (c) + (when (< n 2) + (incf n) + (sb-sys:defer-deadline 0.1 c))))) + (sb-sys:with-deadline (:seconds 1) + (run-sleep 2))) + (sb-sys:deadline-timeout (c) + (setf final c))) + (assert (= n 2)) + (assert final))) -(let ((n 0) - (final nil)) - (handler-case - (handler-bind ((sb-sys:deadline-timeout (lambda (c) - (incf n) - (sb-sys:defer-deadline 0.1 c)))) - (sb-sys:with-deadline (:seconds 1) - (run-program "sleep" '("2") :search t :wait t))) - (sb-sys:deadline-timeout (c) - (setf final c))) - (assert (plusp n)) - (assert (not final))) +(with-test (:name (:deadline :defer-deadline-2)) + (let ((n 0) + (final nil)) + (handler-case + (handler-bind ((sb-sys:deadline-timeout + #'(lambda (c) + (incf n) + (sb-sys:defer-deadline 0.1 c)))) + (sb-sys:with-deadline (:seconds 1) + (run-sleep 2))) + (sb-sys:deadline-timeout (c) + (setf final c))) + (assert (plusp n)) + (assert (not final)))) + +(with-test (:name (:deadline :cancel-deadline)) + (let ((n 0) + (final nil)) + (handler-case + (handler-bind ((sb-sys:deadline-timeout + #'(lambda (c) + (incf n) + (sb-sys:cancel-deadline c)))) + (sb-sys:with-deadline (:seconds 1) + (run-sleep 2))) + (sb-sys:deadline-timeout (c) + (setf final c))) + (assert (= n 1)) + (assert (not final)))) #+(and sb-thread (not sb-lutex)) (progn - (assert-timeout - (let ((lock (sb-thread:make-mutex)) - (waitp t)) - (sb-thread:make-thread (lambda () - (sb-thread:get-mutex lock) - (setf waitp nil) - (sleep 5))) - (loop while waitp do (sleep 0.01)) - (sb-impl::with-deadline (:seconds 1) - (sb-thread:get-mutex lock)))) - (assert-timeout - (let ((sem (sb-thread::make-semaphore :count 0))) - (sb-impl::with-deadline (:seconds 1) - (sb-thread::wait-on-semaphore sem)))) + (with-test (:name (:deadline :get-mutex)) + (assert-timeout + (let ((lock (sb-thread:make-mutex)) + (waitp t)) + (sb-thread:make-thread (lambda () + (sb-thread:get-mutex lock) + (setf waitp nil) + (sleep 5))) + (loop while waitp do (sleep 0.01)) + (sb-sys:with-deadline (:seconds 1) + (sb-thread:get-mutex lock))))) + + (with-test (:name (:deadline :wait-on-semaphore)) + (assert-timeout + (let ((sem (sb-thread::make-semaphore :count 0))) + (sb-sys:with-deadline (:seconds 1) + (sb-thread::wait-on-semaphore sem))))) - (assert-timeout - (sb-impl::with-deadline (:seconds 1) - (sb-thread:join-thread - (sb-thread:make-thread (lambda () (loop (sleep 1))))))) + (with-test (:name (:deadline :join-thread)) + (assert-timeout + (sb-sys:with-deadline (:seconds 1) + (sb-thread:join-thread + (sb-thread:make-thread (lambda () (loop (sleep 1)))))))) (with-test (:name (:deadline :futex-wait-eintr)) (let ((lock (sb-thread:make-mutex)) @@ -74,7 +104,7 @@ (lambda () (let ((start (get-internal-real-time))) (handler-case - (sb-impl::with-deadline (:seconds 1) + (sb-sys:with-deadline (:seconds 1) (sb-thread:get-mutex lock)) (sb-sys:deadline-timeout (x) (declare (ignore x)) @@ -86,4 +116,4 @@ (sb-thread:interrupt-thread thread (lambda () 42)) (let ((seconds-passed (sb-thread:join-thread thread))) (format t "Deadline in ~S~%" seconds-passed) - (assert (< seconds-passed 1.2))))))) + (assert (< seconds-passed 1.2))))))) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index c9ae3d3..6978031 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.37.10" +"1.0.37.11" -- 1.7.10.4