From fe962ba01d267b92f638c8f0d19be41054219f04 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 29 Apr 2007 21:57:39 +0000 Subject: [PATCH] 1.0.5.9: experimental semi-synchronous deadlines * WITH-DEADLINE provides an interface to a synchronous deadline/timeout facility that can interrupt execution only on blocking IO and when waiting on locks (latter Linux only for now.) * DECODE-DEADLINE provides an interface that implementors of blocking functions can use to hook into the deadline mechanism. * Add SB-IMPL::*ON-DANGEROUS-SELECT* for debugging: can be used to warn/ signal an error / obtain a backtrace when SBCL calls select without a timeout while interrupts are disabled. * Undocumented and unexported periodic polling functionality has been removed from SERVE-EVENT, but can be reinstated should it be desired. --- NEWS | 2 + build-order.lisp-expr | 1 + package-data-list.lisp-expr | 5 ++ src/code/condition.lisp | 13 ++- src/code/deadline.lisp | 125 ++++++++++++++++++++++++++ src/code/fd-stream.lisp | 31 +++++-- src/code/serve-event.lisp | 204 +++++++++++++++++-------------------------- src/code/target-thread.lisp | 80 +++++++++-------- src/code/unix.lisp | 80 +++++++++++------ src/compiler/fndb.lisp | 10 +-- src/compiler/macros.lisp | 2 +- src/runtime/linux-os.c | 37 +++++--- src/runtime/pthread-futex.c | 2 +- tests/deadline.impure.lisp | 31 +++++++ version.lisp-expr | 2 +- 15 files changed, 412 insertions(+), 213 deletions(-) create mode 100644 src/code/deadline.lisp create mode 100644 tests/deadline.impure.lisp diff --git a/NEWS b/NEWS index ab3c173..8b794b8 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.6 relative to sbcl-1.0.5: + * enhancement: a new, experimental synchronous timeout facility is + provided. Refer to SB-SYS:WITH-DEADLINE for details. * enhancement: when a symbol name conflict error arises, the conflicting symbols are always printed with a package prefix. (thanks to Kevin Reid) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 9987d27..09b1111 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -277,6 +277,7 @@ ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro + ("src/code/deadline" :not-host) ("src/code/serve-event" :not-host) ("src/code/fd-stream" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 80dfc3f..ecdaa68 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1956,7 +1956,10 @@ SB-KERNEL) have been undone, but probably more remain." "BREAKPOINT-ERROR" "CLOSE-SHARED-OBJECTS" "COMPILER-VERSION" + "DEADLINE-TIMEOUT" "DEALLOCATE-SYSTEM-MEMORY" + "DECODE-TIMEOUT" + "DECODE-INTERNAL-TIME" "DEFAULT-INTERRUPT" "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DYNAMIC-FOREIGN-SYMBOLS-P" @@ -2001,6 +2004,7 @@ SB-KERNEL) have been undone, but probably more remain." "SAP-REF-SAP" "SAP-REF-SINGLE" "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>=" "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" + "SIGNAL-DEADLINE" "SERVE-EVENT" "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-WORD" "SIGNED-SAP-REF-8" @@ -2014,6 +2018,7 @@ SB-KERNEL) have been undone, but probably more remain." "UNDEFINED-FOREIGN-SYMBOLS-P" "UPDATE-LINKAGE-TABLE" "VECTOR-SAP" "WAIT-UNTIL-FD-USABLE" + "WITH-DEADLINE" "WITH-FD-HANDLER" "WITH-INTERRUPTS" "WITH-PINNED-OBJECTS" "WITHOUT-GCING" "WITHOUT-INTERRUPTS" "WORDS")) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 2534c4a..5384c44 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1147,7 +1147,11 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) -(define-condition timeout (serious-condition) ()) +(define-condition timeout (serious-condition) + ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) + (:report (lambda (condition stream) + (format stream "Timeout occurred~@[ after ~A seconds~]." + (timeout-seconds condition))))) (define-condition io-timeout (stream-error timeout) ((direction :reader io-timeout-direction :initarg :direction)) @@ -1155,10 +1159,15 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (declare (type stream stream)) (format stream - "I/O timeout ~(~A~)ing ~S" + "I/O timeout ~(~A~)ing ~S." (io-timeout-direction condition) (stream-error-stream condition))))) +(define-condition deadline-timeout (timeout) () + (:report (lambda (condition stream) + (format stream "A deadline was reached after ~A seconds." + (timeout-seconds condition))))) + (define-condition declaration-type-conflict-error (reference-condition simple-error) () diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp new file mode 100644 index 0000000..3850da8 --- /dev/null +++ b/src/code/deadline.lisp @@ -0,0 +1,125 @@ +;;;; global deadlines for blocking functions: a threadsafe alternative +;;;; to asynch timeouts + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +;;; Current deadline as internal time units or NIL. +(defvar *deadline* nil) +(declaim (type (or unsigned-byte null) *deadline*)) + +;;; The relative number of seconds the current deadline corresponds +;;; to. Used for continuing from TIMEOUT conditions. +(defvar *deadline-seconds* nil) + +(declaim (inline seconds-to-internal-time)) +(defun seconds-to-internal-time (seconds) + (truncate (* seconds sb!xc:internal-time-units-per-second))) + +(defmacro with-deadline ((&key seconds override) + &body body) + "Arranges for a TIMEOUT condition to be signalled if an operation respecting +deadlines occurs either after the deadline has passed, or would take longer +than the time left to complete. + +Currently only blocking IO operations, GET-MUTEX, and CONDITION-WAIT respect +deadlines, but this includes their implicit uses inside SBCL itself. + +Experimental." + (with-unique-names (deadline-seconds deadline) + ;; We're operating on a millisecond precision, so a single-float + ;; is enough, and is an immediate on 64bit platforms. + `(let* ((,deadline-seconds (coerce ,seconds 'single-float)) + (,deadline + (+ (seconds-to-internal-time ,deadline-seconds) + (get-internal-real-time)))) + (multiple-value-bind (*deadline* *deadline-seconds*) + (if ,override + (values ,deadline ,deadline-seconds) + (let ((old *deadline*)) + (if (and old (< old ,deadline)) + (values old *deadline-seconds*) + (values ,deadline ,deadline-seconds)))) + ,@body)))) + +(declaim (inline decode-internal-time)) +(defun decode-internal-time (time) + #!+sb-doc + "Returns internal time value TIME decoded into seconds and microseconds." + (multiple-value-bind (sec frac) + (truncate time sb!xc:internal-time-units-per-second) + (values sec (* frac sb!unix::micro-seconds-per-internal-time-unit)))) + +(defun signal-timeout (datum &rest arguments) + #!+sb-doc + "Signals a timeout condition while inhibiting further timeouts due to +deadlines while the condition is being handled." + (let ((*deadline* nil)) + (apply #'error datum arguments))) + +(defun signal-deadline () + #!+sb-doc + "Signal a DEADLINE-TIMEOUT condition. Implementors of blocking functions +are responsible for calling this when a deadline is reached." + (signal-timeout 'deadline-timeout :seconds *deadline-seconds*)) + +;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP +;;; +;;; Takes *DEADLINE* into account: if it occurs before given SECONDS, +;;; the values are based on it, and DEADLINEP is true -- and the +;;; receipent of the values should call SIGNAL-TIMEOUT if the decoded +;;; timeout is reached. +;;; +;;; If SECONDS is NIL and there is no *DEADLINE* all returned values +;;; are NIL. +(defun decode-timeout (seconds) + #!+sb-doc + "Decodes a relative timeout in SECONDS into five values, taking any +global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC, +DEADLINEP. + +TO-SEC and TO-USEC indicate the relative timeout in seconds and microsconds. +STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and +microseconds. DEADLINEP is true if the returned values reflect a global +deadline instead of the local timeout indicated by SECONDS. + +If SECONDS is null and there is no global timeout all returned values will be +null. If a global deadline has already passed when DECODE-TIMEOUT is called, +it will signal a timeout condition." + (let* ((timeout (when seconds (seconds-to-internal-time seconds))) + (now (get-internal-real-time)) + (deadline *deadline*) + (deadline-timeout + (when deadline + (let ((time-left (- deadline now))) + (if (plusp time-left) + time-left + (signal-deadline)))))) + (multiple-value-bind (final-timeout final-deadline signalp) + ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout + ;; and deadline in internal-time units + (cond ((and deadline timeout) + (if (< timeout deadline-timeout) + (values timeout (+ timeout now) nil) + (values deadline-timeout deadline t))) + (deadline + (values deadline-timeout deadline t)) + (timeout + (values timeout (+ timeout now) nil)) + (t + (values nil nil nil))) + (if final-timeout + (multiple-value-bind (to-sec to-usec) + (decode-internal-time final-timeout) + (multiple-value-bind (stop-sec stop-usec) + (decode-internal-time final-deadline) + (values to-sec to-usec stop-sec stop-usec signalp))) + (values nil nil nil nil nil))))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 88b22af..2ae6c9a 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -98,8 +98,8 @@ ;; output flushed, but not written due to non-blocking io? (output-later nil) (handler nil) - ;; timeout specified for this stream, or NIL if none - (timeout nil :type (or index null)) + ;; timeout specified for this stream as seconds or NIL if none + (timeout nil :type (or single-float null)) ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null)) (external-format :default) @@ -748,7 +748,8 @@ (when (sysread-may-block-p stream) (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read))) + (signal-timeout 'io-timeout :stream stream :direction :read + :seconds (fd-stream-timeout stream)))) (multiple-value-bind (count errno) (sb!unix:unix-read fd (int-sap (+ (sap-int ibuf-sap) tail)) @@ -758,7 +759,9 @@ (progn (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read)) + (signal-timeout 'io-timeout + :stream stream :direction :read + :seconds (fd-stream-timeout stream))) (refill-buffer/fd stream)) (simple-stream-perror "couldn't read from ~S" stream errno))) ((zerop count) @@ -1972,6 +1975,19 @@ (fd-stream-set-file-position fd-stream arg1) (fd-stream-get-file-position fd-stream))))) +;; FIXME: Think about this. +;; +;; (defun finish-fd-stream-output (fd-stream) +;; (let ((timeout (fd-stream-timeout fd-stream))) +;; (loop while (fd-stream-output-later fd-stream) +;; ;; FIXME: SIGINT while waiting for a timeout will +;; ;; cause a timeout here. +;; do (when (and (not (serve-event timeout)) timeout) +;; (signal-timeout 'io-timeout +;; :stream fd-stream +;; :direction :write +;; :seconds timeout))))) + (defun finish-fd-stream-output (stream) (flush-output-buffer stream) (do () @@ -2096,7 +2112,7 @@ (format nil "file ~A" file) (format nil "descriptor ~W" fd))) auto-close) - (declare (type index fd) (type (or index null) timeout) + (declare (type index fd) (type (or real null) timeout) (type (member :none :line :full) buffering)) (cond ((not (or input-p output-p)) (setf input t)) @@ -2111,7 +2127,10 @@ :buffering buffering :dual-channel-p dual-channel-p :external-format external-format - :timeout timeout))) + :timeout + (if timeout + (coerce timeout 'single-float) + nil)))) (set-fd-stream-routines stream element-type external-format input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 50fce5d..ed5c8db 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -131,23 +131,12 @@ (dolist (handler bogus-handlers) (setf (handler-bogus handler) nil))) (continue () - :report "Go on, leaving handlers marked as bogus.")))) + :report "Go on, leaving handlers marked as bogus."))) + nil) + ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends -;;; Break a real timeout into seconds and microseconds. -(defun decode-timeout (timeout) - (declare (values (or index null) index)) - (typecase timeout - (integer (values timeout 0)) - (null (values nil 0)) - (real - (multiple-value-bind (q r) (truncate (coerce timeout 'single-float)) - (declare (type index q) (single-float r)) - (values q (the (values index t) (truncate (* r 1f6)))))) - (t - (error "Timeout is not a real number or NIL: ~S" timeout)))) - ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will ;;; timeout at the correct time irrespective of how many events are handled in @@ -155,97 +144,65 @@ (defun wait-until-fd-usable (fd direction &optional timeout) #!+sb-doc "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or - :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving - up." - (declare (type (or real null) timeout)) +:OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving +up." (let (usable) - (multiple-value-bind (to-sec to-usec) (decode-timeout timeout) - (declare (type (or index null) to-sec to-usec)) - (multiple-value-bind (stop-sec stop-usec) - (if to-sec - (multiple-value-bind (okay start-sec start-usec) - (sb!unix:unix-gettimeofday) - (declare (ignore okay)) - (let ((usec (+ to-usec start-usec)) - (sec (+ to-sec start-sec))) - (declare (type (unsigned-byte 31) usec sec)) - (if (>= usec 1000000) - (values (1+ sec) (- usec 1000000)) - (values sec usec)))) - (values 0 0)) - (declare (type (unsigned-byte 31) stop-sec stop-usec)) - (with-fd-handler (fd direction (lambda (fd) - (declare (ignore fd)) - (setf usable t))) - (loop - (sub-serve-event to-sec to-usec) - - (when usable - (return t)) - - (when timeout - (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday) - (declare (ignore okay)) - (when (or (> sec stop-sec) - (and (= sec stop-sec) (>= usec stop-usec))) - (return nil)) - (setq to-sec (- stop-sec sec)) - (cond ((> usec stop-usec) - (decf to-sec) - (setq to-usec (- (+ stop-usec 1000000) usec))) - (t - (setq to-usec (- stop-usec usec)))))))))))) + (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp) + (decode-timeout timeout) + (declare (type (or integer null) to-sec to-usec)) + (with-fd-handler (fd direction (lambda (fd) + (declare (ignore fd)) + (setf usable t))) + (loop + (sub-serve-event to-sec to-usec signalp) + (when usable + (return t)) + (when to-sec + (multiple-value-bind (sec usec) + (decode-internal-time (get-internal-real-time)) + (setf to-sec (- stop-sec sec)) + (cond ((> usec stop-usec) + (decf to-sec) + (setf to-usec (- (+ stop-usec 1000000) usec))) + (t + (setf to-usec (- stop-usec usec))))) + (when (or (minusp to-sec) (minusp to-usec)) + (if signalp + (signal-deadline) + (return nil))))))))) ;;; Wait for up to timeout seconds for an event to happen. Make sure all ;;; pending events are processed before returning. (defun serve-all-events (&optional timeout) #!+sb-doc "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If - SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout - 0 until all events have been served. SERVE-ALL-EVENTS returns T if - SERVE-EVENT did something and NIL if not." +SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a +timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns +T if SERVE-EVENT did something and NIL if not." (do ((res nil) (sval (serve-event timeout) (serve-event 0))) ((null sval) res) (setq res t))) -;;; Serve a single event. +;;; Serve a single set of events. (defun serve-event (&optional timeout) #!+sb-doc - "Receive on all ports and Xevents and dispatch to the appropriate handler - function. If timeout is specified, server will wait the specified time (in - seconds) and then return, otherwise it will wait until something happens. - Server returns T if something happened and NIL otherwise." - (multiple-value-bind (to-sec to-usec) (decode-timeout timeout) - (sub-serve-event to-sec to-usec))) - -;;; When a *periodic-polling-function* is defined the server will not -;;; block for more than the maximum event timeout and will call the -;;; polling function if it does time out. -(declaim (type (or null function) *periodic-polling-function*)) -(defvar *periodic-polling-function* nil) -(declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*)) -(defvar *max-event-to-sec* 1) -(defvar *max-event-to-usec* 0) + "Receive pending events on all FD-STREAMS and dispatch to the appropriate +handler functions. If timeout is specified, server will wait the specified +time (in seconds) and then return, otherwise it will wait until something +happens. Server returns T if something happened and NIL otherwise. Timeout +0 means polling without waiting." + (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp) + (decode-timeout timeout) + (declare (ignore stop-sec stop-usec)) + (sub-serve-event to-sec to-usec signalp))) ;;; Takes timeout broken into seconds and microseconds. -(defun sub-serve-event (to-sec to-usec) - (declare (type (or null (unsigned-byte 29)) to-sec to-usec)) - - (let ((call-polling-fn nil)) - (when (and *periodic-polling-function* - ;; Enforce a maximum timeout. - (or (null to-sec) - (> to-sec *max-event-to-sec*) - (and (= to-sec *max-event-to-sec*) - (> to-usec *max-event-to-usec*)))) - (setf to-sec *max-event-to-sec*) - (setf to-usec *max-event-to-usec*) - (setf call-polling-fn t)) +(defun sub-serve-event (to-sec to-usec deadlinep) + ;; Next, wait for something to happen. + (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) + (write-fds (sb!alien:struct sb!unix:fd-set))) - ;; Next, wait for something to happen. - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) - (write-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) (sb!unix:fd-zero write-fds) (let ((count 0)) @@ -266,37 +223,40 @@ (setf count fd)))))) (incf count) - (multiple-value-bind (value err) - (sb!unix:unix-fast-select count - (sb!alien:addr read-fds) - (sb!alien:addr write-fds) - nil to-sec to-usec) - #!+win32 (declare (ignorable err)) - (cond ((eql 0 value) - ;; Timed out. - (when call-polling-fn - (funcall *periodic-polling-function*))) - (value - ;; Call file descriptor handlers according to the - ;; readable and writable masks returned by select. - (dolist (handler - (select-descriptor-handlers - (lambda (handler) - (let ((fd (handler-descriptor handler))) - (ecase (handler-direction handler) - (:input (sb!unix:fd-isset fd read-fds)) - (:output (sb!unix:fd-isset fd write-fds))))))) - (funcall (handler-function handler) - (handler-descriptor handler))) - t) - #!-win32 - ((eql err sb!unix:eintr) - ;; We did an interrupt. - ;; - ;; FIXME: Why T here? - t) - (t - ;; One of the file descriptors is bad. - (handler-descriptors-error) - nil))))))) - + ;; Next, wait for something to happen. + (multiple-value-bind (value err) + (sb!unix:unix-fast-select count + (sb!alien:addr read-fds) + (sb!alien:addr write-fds) + nil to-sec to-usec) + #!+win32 + (declare (ignore err)) + ;; Now see what it was (if anything) + (cond ((not value) + ;; Interrupted or one of the file descriptors is bad. + ;; FIXME: Check for other errnos. Why do we return true + ;; when interrupted? + #!-win32 + (if (eql err sb!unix:eintr) + t + (handler-descriptors-error)) + #!+win32 + (handler-descriptors-error)) + ((plusp value) + ;; Got something. Call file descriptor handlers + ;; according to the readable and writable masks + ;; returned by select. + (dolist (handler + (select-descriptor-handlers + (lambda (handler) + (let ((fd (handler-descriptor handler))) + (ecase (handler-direction handler) + (:input (sb!unix:fd-isset fd read-fds)) + (:output (sb!unix:fd-isset fd write-fds))))))) + (funcall (handler-function handler) + (handler-descriptor handler))) + t) + ((zerop value) + (when deadlinep + (signal-deadline)) + nil)))))) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 59d0562..995847e 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -163,7 +163,8 @@ in future versions." (declaim (inline futex-wait futex-wake)) (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) + int (word unsigned-long) (old-value unsigned-long) + (to-sec long) (to-usec unsigned-long)) (sb!alien:define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) @@ -231,47 +232,53 @@ in future versions." :structure mutex :slot value)) -(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) +(defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t)) #!+sb-doc "Acquire MUTEX, setting it to NEW-VALUE or some suitable default -value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep +value if NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available." (declare (type mutex mutex) (optimize (speed 3))) (/show0 "Entering GET-MUTEX") (unless new-value (setq new-value *current-thread*)) #!-sb-thread - (let ((old-value (mutex-value mutex))) - (when (and old-value wait-p) - (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~ + (let ((old (mutex-value mutex))) + (when (and old waitp) + (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~ new-value ~S, but has already been acquired (with value ~S)." - mutex wait-p new-value old-value)) + mutex waitp new-value old)) (setf (mutex-value mutex) new-value) t) #!+sb-thread - (progn - (when (eql new-value (mutex-value mutex)) - (warn "recursive lock attempt ~S~%" mutex) - (format *debug-io* "Thread: ~A~%" *current-thread*) - (sb!debug:backtrace most-positive-fixnum *debug-io*) - (force-output *debug-io*)) - #!+sb-lutex - (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) - (if wait-p - (%lutex-lock lutex) - (%lutex-trylock lutex)))) - (setf (mutex-value mutex) new-value)) - #!-sb-lutex - (let (old) - (loop - (unless - (setf old - (compare-and-swap-mutex-value mutex nil new-value)) - (return t)) - (unless wait-p (return nil)) - (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (get-lisp-obj-address old))))))) + (when (eql new-value (mutex-value mutex)) + (warn "recursive lock attempt ~S~%" mutex) + (format *debug-io* "Thread: ~A~%" *current-thread*) + (sb!debug:backtrace most-positive-fixnum *debug-io*) + (force-output *debug-io*)) + ;; FIXME: Lutexes do not currently support deadlines, as at least + ;; on Darwin pthread_foo_timedbar functions are not supported: + ;; this means that we probably need to use the Carbon multiprocessing + ;; functions on Darwin. + #!+sb-lutex + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if waitp + (%lutex-lock lutex) + (%lutex-trylock lutex)))) + (setf (mutex-value mutex) new-value)) + #!-sb-lutex + (let (old) + (when (and (setf old (compare-and-exchange-mutex-value mutex nil new-value)) + waitp) + (loop while old + do (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (mutex old) + (futex-wait (mutex-value-address mutex) + (get-lisp-obj-address old) + (or to-sec -1) + (or to-usec 0)))) + (signal-deadline))) + (setf old (compare-and-exchange-mutex-value mutex nil new-value)))) + (not old))) (defun release-mutex (mutex) #!+sb-doc @@ -342,10 +349,15 @@ time we reacquire MUTEX and return to the caller." ;; manages to grab MUTEX and call CONDITION-NOTIFY during ;; this comment, it will change queue->data, and so ;; futex-wait returns immediately instead of sleeping. - ;; Ergo, no lost wakeup - (with-pinned-objects (queue me) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me)))) + ;; Ergo, no lost wakeup. We may get spurious wakeups, + ;; but that's ok. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (queue me) + (futex-wait (waitqueue-data-address queue) + (get-lisp-obj-address me) + (or to-sec -1) ;; our way if saying "no timeout" + (or to-usec 0)))) + (signal-deadline)))) ;; If we are interrupted while waiting, we should do these things ;; before returning. Ideally, in the case of an unhandled signal, ;; we should do them before entering the debugger, but this is diff --git a/src/code/unix.lisp b/src/code/unix.lisp index e85256e..d6ac73a 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -533,29 +533,52 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; sys/select.h +(defvar *on-dangerous-select* :warn) + +;;; Calling select in a bad place can hang in a nasty manner, so it's better +;;; to have some way to detect these. +(defun note-dangerous-select () + (let ((action *on-dangerous-select*) + (*on-dangerous-select* nil)) + (case action + (:warn + (warn "Starting a select without a timeout while interrupts are ~ + disabled.")) + (:error + (error "Starting a select without a timeout while interrupts are ~ + disabled.")) + (:backtrace + (write-line + "=== Starting a select without a timeout while interrupts are disabled. ===" + *debug-io*) + (sb!debug:backtrace))) + nil)) + ;;;; FIXME: Why have both UNIX-SELECT and UNIX-FAST-SELECT? ;;; Perform the UNIX select(2) system call. -(declaim (inline unix-fast-select)) ; (used to be a macro in CMU CL) +(declaim (inline unix-fast-select)) (defun unix-fast-select (num-descriptors read-fds write-fds exception-fds - timeout-secs &optional (timeout-usecs 0)) + timeout-secs timeout-usecs) (declare (type (integer 0 #.fd-setsize) num-descriptors) (type (or (alien (* (struct fd-set))) null) read-fds write-fds exception-fds) - (type (or null (unsigned-byte 31)) timeout-secs) - (type (unsigned-byte 31) timeout-usecs)) - ;; FIXME: CMU CL had - ;; (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - ;; here. Is that important for SBCL? If so, why? Profiling might tell us.. - (with-alien ((tv (struct timeval))) - (when timeout-secs - (setf (slot tv 'tv-sec) timeout-secs) - (setf (slot tv 'tv-usec) timeout-usecs)) - (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) - num-descriptors read-fds write-fds exception-fds - (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))) + (type (or null (unsigned-byte 31)) timeout-secs timeout-usecs)) + (flet ((select (tv-sap) + (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + num-descriptors read-fds write-fds exception-fds + tv-sap))) + (cond ((or timeout-secs timeout-usecs) + (with-alien ((tv (struct timeval))) + (setf (slot tv 'tv-sec) (or timeout-secs 0)) + (setf (slot tv 'tv-usec) (or timeout-usecs 0)) + (select (alien-sap (addr tv))))) + (t + (unless *interrupts-enabled* + (note-dangerous-select)) + (select (int-sap 0)))))) ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event ;;; to happen on one of them or to time out. @@ -595,9 +618,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (rdf (struct fd-set)) (wrf (struct fd-set)) (xpf (struct fd-set))) - (when to-secs - (setf (slot tv 'tv-sec) to-secs) - (setf (slot tv 'tv-usec) to-usecs)) + (cond (to-secs + (setf (slot tv 'tv-sec) to-secs + (slot tv 'tv-usec) to-usecs)) + ((not *interrupts-enabled*) + (note-dangerous-select))) (num-to-fd-set rdf rdfds) (num-to-fd-set wrf wrfds) (num-to-fd-set xpf xpfds) @@ -606,7 +631,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (int-sap 0) (alien-sap (addr ,alienvar))))) (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) + (* (struct fd-set)) (* (struct timeval))) (values result (fd-set-to-num nfds rdf) (fd-set-to-num nfds wrf) @@ -970,12 +995,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (/ 1000000 sb!xc:internal-time-units-per-second)) (declaim (inline system-internal-run-time - internal-real-time-values)) + system-real-time-values)) - (defun internal-real-time-values () - (multiple-value-bind (ignore seconds useconds) (unix-gettimeofday) - (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) - (values seconds (truncate useconds micro-seconds-per-internal-time-unit)))) + (defun system-real-time-values () + (multiple-value-bind (_ sec usec) (unix-gettimeofday) + (declare (ignore _) (type (unsigned-byte 32) sec usec)) + (values sec (truncate usec micro-seconds-per-internal-time-unit)))) ;; There are two optimizations here that actually matter (on 32-bit ;; systems): substract the epoch from seconds and milliseconds @@ -1003,16 +1028,17 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (type fixnum e-msec c-msec) (type unsigned-byte now)) (defun reinit-internal-real-time () - (setf (values e-sec e-msec) (internal-real-time-values) + (setf (values e-sec e-msec) (system-real-time-values) c-sec 0 c-msec 0)) ;; If two threads call this at the same time, we're still safe, I believe, ;; as long as NOW is updated before either of C-MSEC or C-SEC. Same applies ;; to interrupts. --NS (defun get-internal-real-time () - (multiple-value-bind (sec msec) (internal-real-time-values) + (multiple-value-bind (sec msec) (system-real-time-values) (unless (and (= msec c-msec) (= sec c-sec)) - (setf now (+ (* (- sec e-sec) sb!xc:internal-time-units-per-second) + (setf now (+ (* (- sec e-sec) + sb!xc:internal-time-units-per-second) (- msec e-msec)) c-msec msec c-sec sec)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6972590..e0bd99d 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -16,9 +16,9 @@ ;;;; information for known functions: (defknown coerce (t type-specifier) t - ;; Note: - ;; This is not FLUSHABLE because it's defined to signal errors. - (movable) + ;; Note: + ;; This is not FLUSHABLE because it's defined to signal errors. + (movable) ;; :DERIVE-TYPE RESULT-TYPE-SPEC-NTH-ARG 2 ? Nope... (COERCE 1 'COMPLEX) ;; returns REAL/INTEGER, not COMPLEX. ) @@ -29,8 +29,8 @@ ;;; These can be affected by type definitions, so they're not FOLDABLE. (defknown (sb!xc:upgraded-complex-part-type sb!xc:upgraded-array-element-type) - (type-specifier &optional lexenv-designator) type-specifier - (unsafely-flushable)) + (type-specifier &optional lexenv-designator) type-specifier + (unsafely-flushable)) ;;;; from the "Predicates" chapter: diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 015768c..9d331bf 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -456,7 +456,7 @@ ;;; keywords specify the initial values for various optimizers that ;;; the function might have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) - &rest keys) + &body keys) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index 236a33e..bcc5e9f 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -82,21 +82,30 @@ static inline int sys_futex (void *futex, int op, int val, struct timespec *rel) } int -futex_wait(int *lock_word, int oldval) +futex_wait(int *lock_word, int oldval, long sec, unsigned long usec) { - int t; - again: - t = sys_futex(lock_word,FUTEX_WAIT,oldval, 0); - - /* Interrupted FUTEX_WAIT calls may return early. - * - * If someone manages to wake the futex while we're spinning - * around it, we will just return with -1 and errno EWOULDBLOCK, - * because the value has changed, so that's ok. */ - if (t != 0 && errno == EINTR) - goto again; + struct timespec timeout; + int t; - return t; + again: + if (sec<0) { + t = sys_futex(lock_word,FUTEX_WAIT,oldval, 0); + } + else { + timeout.tv_sec = sec; + timeout.tv_nsec = usec * 1000; + t = sys_futex(lock_word,FUTEX_WAIT,oldval, &timeout); + } + if (t==0) + return 0; + else if (errno==ETIMEDOUT) + return 1; + else if (errno==EINTR) + /* spurious wakeup from interrupt */ + goto again; + else + /* EWOULDBLOCK and others, need to check the lock */ + return -1; } int @@ -172,7 +181,7 @@ os_init(char *argv[], char *envp[]) } #ifdef LISP_FEATURE_SB_THREAD #if !defined(LISP_FEATURE_SB_LUTEX) && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) - futex_wait(futex,-1); + futex_wait(futex,-1,-1,0); if(errno==ENOSYS) { lose("This version of SBCL is compiled with threading support, but your kernel\n" "is too old to support this. Please use a more recent kernel or\n" diff --git a/src/runtime/pthread-futex.c b/src/runtime/pthread-futex.c index 8a3da46..f010f9d 100644 --- a/src/runtime/pthread-futex.c +++ b/src/runtime/pthread-futex.c @@ -206,7 +206,7 @@ futex_relative_to_abs(struct timespec *tp, int relative) } int -futex_wait(int *lock_word, int oldval) +futex_wait(int *lock_word, int oldval, long sec, unsigned long usec) { int ret, result; struct futex *futex; diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp new file mode 100644 index 0000000..32d19f6 --- /dev/null +++ b/tests/deadline.impure.lisp @@ -0,0 +1,31 @@ +(defmacro assert-timeout (form) + (let ((ok (gensym "OK"))) + `(let ((,ok ',ok)) + (unless (eq ,ok + (handler-case ,form + (timeout () + ,ok))) + (error "No timeout from form:~% ~S" ',form))))) + + +(assert-timeout + (sb-impl::with-deadline (:seconds 1) + (run-program "sleep" '("5") :search t :wait t))) + +#+(and sb-thread (not sb-lutex)) +(progn + (assert-timeout + (let ((lock (sb-thread:make-mutex))) + (sb-thread:make-thread (lambda () (sb-thread:get-mutex lock) (sleep 5))) + (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)))) + + (assert-timeout + (sb-impl::with-deadline (:seconds 1) + (sb-thread:join-thread + (sb-thread:make-thread (lambda () (loop (sleep 1)))))))) diff --git a/version.lisp-expr b/version.lisp-expr index fabe34d..3f32811 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.5.8" +"1.0.5.9" -- 1.7.10.4