Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] CVS: sbcl/src/code deadline.lisp, NONE,
1.1 condition.lisp, 1.79, 1.80 fd-stream.lisp, 1.108,
1.109 serve-event.lisp, 1.16, 1.17 target-thread.lisp, 1.72,
1.73 unix.lisp, 1.79, 1.80
From: Nikodemus Siivola <demoss@us...> - 2007-04-29 21:57
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12847/src/code
Modified Files:
condition.lisp fd-stream.lisp serve-event.lisp
target-thread.lisp unix.lisp
Added Files:
deadline.lisp
Log Message:
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.
--- NEW FILE: deadline.lisp ---
;;;; 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)))))
Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -d -r1.79 -r1.80
--- condition.lisp 18 Apr 2007 15:26:11 -0000 1.79
+++ condition.lisp 29 Apr 2007 21:57:40 -0000 1.80
@@ -1147,7 +1147,11 @@
(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 @@
(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)
()
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- fd-stream.lisp 19 Apr 2007 12:01:23 -0000 1.108
+++ fd-stream.lisp 29 Apr 2007 21:57:44 -0000 1.109
@@ -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))
Index: serve-event.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/serve-event.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- serve-event.lisp 13 Apr 2007 10:22:32 -0000 1.16
+++ serve-event.lisp 29 Apr 2007 21:57:44 -0000 1.17
@@ -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))))))
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -d -r1.72 -r1.73
--- target-thread.lisp 29 Apr 2007 17:17:26 -0000 1.72
+++ target-thread.lisp 29 Apr 2007 21:57:44 -0000 1.73
@@ -163,7 +163,8 @@
(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 @@
: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 @@
;; 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
Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -d -r1.79 -r1.80
--- unix.lisp 19 Apr 2007 12:01:35 -0000 1.79
+++ unix.lisp 29 Apr 2007 21:57:44 -0000 1.80
@@ -533,29 +533,52 @@
;;;; 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 @@
(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 @@
(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 @@
(/ 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 @@
(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))
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/code deadline.lisp, NONE, 1.1 condition.lisp, 1.79, 1.80 fd-stream.lisp, 1.108, 1.109 serve-event.lisp, 1.16, 1.17 target-thread.lisp, 1.72, 1.73 unix.lisp, 1.79, 1.80 | Nikodemus Siivola <demoss@us...> |