;;;; -*- 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)
("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)
"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"
"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"
"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"))
(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))
(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)
()
--- /dev/null
+;;;; 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)))))
;; 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)
(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))
(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)
(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 ()
(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))
: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))
(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)
+
\f
;;;; 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
(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)))))))))
\f
;;; 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))
(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))))))
(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))))
: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
;; 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
\f
;;;; 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.
(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)
(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)
(/ 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
(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))
;;;; 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.
)
;;; 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))
\f
;;;; from the "Predicates" chapter:
;;; 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))
}
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
}
#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"
}
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;
--- /dev/null
+(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))))))))
;;; 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"
projects / sbcl.git / commitdiff