common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

1.0.5.9: experimental semi-synchronous deadlines

Browse source 
* 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.
This commit is contained in:
Nikodemus Siivola 2007-04-29 21:57:39 +00:00
parent ff218a24fb
commit fe962ba01d
15 changed files with 412 additions and 213 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
NEWS
View file

@ -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)

1
build-order.lisp-expr
View file

@ -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)

5
package-data-list.lisp-expr
View file

@ -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"))

13
src/code/condition.lisp
View file

@ -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)
()

125
src/code/deadline.lisp Normal file
View file

@ -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)))))

31
src/code/fd-stream.lisp
View file

@ -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))

204
src/code/serve-event.lisp
View file

@ -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))
(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)))
(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))
;; 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))))))

80
src/code/target-thread.lisp
View file

@ -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

80
src/code/unix.lisp
View file

@ -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))

10
src/compiler/fndb.lisp
View file

@ -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:

2
src/compiler/macros.lisp
View file

@ -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))

37
src/runtime/linux-os.c
View file

@ -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:
struct timespec timeout;
int t;
again:
if (sec<0) {
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;
return t;
}
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"

2
src/runtime/pthread-futex.c
View file

@ -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;

31
tests/deadline.impure.lisp Normal file
View file

@ -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))))))))

2
version.lisp-expr
View file

@ -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"