From: Yaroslav K. <kav...@je...> - 2007-05-02 06:44:51
|
> Added Files: > deadline.lisp > Log Message: > 1.0.5.9: experimental semi-synchronous deadlines ... > (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)))) sb!unix::micro-seconds-per-internal-time-unit is not defined on win-32 -- WBR, Yaroslav Kavenchuk. |
I haven't tracked it down yet, but something in 1.0.5.9 seems to have =20= broken x86-64/darwin building: ; /Users/sly/projects/sf.net/builds/darwin-x86-64+sb-thread/sbcl/obj/=20 from-xc/src/pcl/walk.lisp-obj-tmp written ; compilation finished in 0:00:01 T * (#P"obj/from-xc/src/code/show.lisp-obj" #P"obj/from-xc/src/code/early-source-location.lisp-obj" #P"obj/from-xc/src/code/backq.lisp-obj" #P"obj/from-xc/src/code/globals.lisp-obj" #P"obj/from-xc/src/code/defsetfs.lisp-obj" ...) * T * [undoing binding stack and other enclosing state... done] [saving current Lisp image into /Users/sly/projects/sf.net/builds/=20 darwin-x86-64+sb-thread/sbcl/output/after-xc.core: scanning space for lutexes... writing 1920 bytes from the read-only space at 0x04000000 scanning space for lutexes... writing 2096 bytes from the static space at 0x08000000 scanning space for lutexes... fatal error encountered in SBCL pid 2372(tid 2684407744): no size function for object at 0x1042b5bc (widetag 0xbc) Looks like the futex stuff changed in this build, so the lutex stuff =20 probably did too. The x86/darwin/thread builds work however. Cyrus Begin forwarded message: > From: Nikodemus Siivola <de...@us...> > Date: April 29, 2007 2:57:47 PM PDT > To: sbc...@li... > Subject: [Sbcl-commits] CVS: sbcl/src/code deadline.lisp, NONE, 1.1 =20= > condition.lisp, 1.79, 1.80 fd-stream.lisp, 1.108, 1.109 serve-=20 > event.lisp, 1.16, 1.17 target-thread.lisp, 1.72, 1.73 unix.lisp, =20 > 1.79, 1.80 > > 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/=20 > 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 =20= > respecting > deadlines occurs either after the deadline has passed, or would =20 > take longer > than the time left to complete. > > Currently only blocking IO operations, GET-MUTEX, and CONDITION-=20 > 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 =20 > 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-=20 > unit)))) > > (defun signal-timeout (datum &rest arguments) > #!+sb-doc > "Signals a timeout condition while inhibiting further timeouts =20 > 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 =20 > 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, =20= > 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 =20 > microsconds. > STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and > microseconds. DEADLINEP is true if the returned values reflect a =20 > global > deadline instead of the local timeout indicated by SECONDS. > > If SECONDS is null and there is no global timeout all returned =20 > values will be > null. If a global deadline has already passed when DECODE-TIMEOUT =20 > 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 > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > 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 =20 > seconds." > + (timeout-seconds condition))))) > + > (define-condition declaration-type-conflict-error (reference-=20 > condition > simple-error) > () > > Index: fd-stream.lisp > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > 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 =20 > 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 =20 > stream :direction :read)) > + (signal-timeout 'io-timeout > + :stream stream :direction :read > + :seconds (fd-stream-timeout =20 > stream))) > (refill-buffer/fd stream)) > (simple-stream-perror "couldn't read from ~S" =20 > 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 > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > 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) > + > =0C > ;;;; 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-=20 > 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 =20 > serve-event is > ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-=20 > USABLE will > ;;; timeout at the correct time irrespective of how many events =20 > 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 =20 > either :INPUT or > - :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait =20 > before giving > - up." > - (declare (type (or real null) timeout)) > +:OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait =20 > 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 (>=3D 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-=20 > gettimeofday) > - (declare (ignore okay)) > - (when (or (> sec stop-sec) > - (and (=3D sec stop-sec) (>=3D 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))))))))) > =0C > ;;; Wait for up to timeout seconds for an event to happen. Make =20 > 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 =20= > 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 =20 > with a > +timeout of 0 until there are no more events to serve. SERVE-ALL-=20 > 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 =20 > appropriate handler > - function. If timeout is specified, server will wait the =20 > specified time (in > - seconds) and then return, otherwise it will wait until something =20= > 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-=20= > usec*)) > -(defvar *max-event-to-sec* 1) > -(defvar *max-event-to-usec* 0) > + "Receive pending events on all FD-STREAMS and dispatch to the =20 > appropriate > +handler functions. If timeout is specified, server will wait the =20 > specified > +time (in seconds) and then return, otherwise it will wait until =20 > something > +happens. Server returns T if something happened and NIL otherwise. =20= > 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 (=3D 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-=20 > 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 =20 > handler))) > - (ecase (handler-direction handler) > - (:input (sb!unix:fd-isset fd =20 > read-fds)) > - (:output (sb!unix:fd-isset fd =20 > 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 =20 > 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-=20 > fds)) > + (:output (sb!unix:fd-isset fd write-=20= > fds))))))) > + (funcall (handler-function handler) > + (handler-descriptor handler))) > + t) > + ((zerop value) > + (when deadlinep > + (signal-deadline)) > + nil)))))) > > Index: target-thread.lisp > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > 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*) =20 > (wait-p t)) > +(defun get-mutex (mutex &optional (new-value *current-thread*) =20 > (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-=20 > P ~S and ~ > + (let ((old (mutex-value mutex))) > + (when (and old waitp) > + (error "In unithread mode, mutex ~S was requested with WAITP =20= > ~S and ~ > new-value ~S, but has already been acquired (with =20 > 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-=20 > 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 =20 > 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 =20 > nil new-value)) > + waitp) > + (loop while old > + do (multiple-value-bind (to-sec to-usec) (decode-=20 > timeout nil) > + (when (=3D 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 =20 > 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 (=3D 1 (with-pinned-objects (queue me) > + (futex-wait (waitqueue-data-address queue) > + (get-lisp-obj-address me) > + (or to-sec -1) ;; our way if =20= > saying "no timeout" > + (or to-usec 0)))) > + (signal-deadline)))) > ;; If we are interrupted while waiting, we should do these =20 > things > ;; before returning. Ideally, in the case of an unhandled =20 > signal, > ;; we should do them before entering the debugger, but this is > > Index: unix.lisp > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > 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 @@ > =0C > ;;;; sys/select.h > > +(defvar *on-dangerous-select* :warn) > + > +;;; Calling select in a bad place can hang in a nasty manner, so =20 > 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 =20= > are ~ > + disabled.")) > + (:error > + (error "Starting a select without a timeout while =20 > interrupts are ~ > + disabled.")) > + (:backtrace > + (write-line > + "=3D=3D=3D Starting a select without a timeout while = interrupts =20 > are disabled. =3D=3D=3D" > + *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 =20= > 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-=20 > set)) > - (* (struct fd-set)) (* (struct timeval))) > - num-descriptors read-fds write-fds exception-fds > - (if timeout-secs (alien-sap (addr tv)) (int-sap =20 > 0))))) > + (type (or null (unsigned-byte 31)) timeout-secs timeout-=20= > usecs)) > + (flet ((select (tv-sap) > + (int-syscall ("select" int (* (struct fd-set)) (* =20 > (struct fd-set)) > + (* (struct fd-set)) (* (struct =20 > timeval))) > + num-descriptors read-fds write-fds =20 > 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 =20 > 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-=20 > gettimeofday) > - (declare (ignore ignore) (type (unsigned-byte 32) seconds =20 > useconds)) > - (values seconds (truncate useconds micro-seconds-per-=20 > 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-=20 > 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 =20 > safe, I believe, > ;; as long as NOW is updated before either of C-MSEC or C-SEC. =20= > 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 (=3D msec c-msec) (=3D sec c-sec)) > - (setf now (+ (* (- sec e-sec) sb!xc:internal-time-units-=20 > per-second) > + (setf now (+ (* (- sec e-sec) > + sb!xc:internal-time-units-per-second) > (- msec e-msec)) > c-msec msec > c-sec sec)) > > > ----------------------------------------------------------------------=20= > --- > This SF.net email is sponsored by DB2 Express > Download DB2 Express C - the FREE version of DB2 express and take > control of your XML. No limits. Just data. Click to get it now. > http://sourceforge.net/powerbar/db2/ > _______________________________________________ > Sbcl-commits mailing list > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-commits |
From: Nikodemus S. <nik...@ra...> - 2007-05-04 08:42:28
|
Cyrus Harmon wrote: > I haven't tracked it down yet, but something in 1.0.5.9 seems to have > broken x86-64/darwin building: > > ; /Users/sly/projects/sf.net/builds/darwin-x86-64+sb-thread/sbcl/obj/ > from-xc/src/pcl/walk.lisp-obj-tmp written > ; compilation finished in 0:00:01 > T > * > (#P"obj/from-xc/src/code/show.lisp-obj" > #P"obj/from-xc/src/code/early-source-location.lisp-obj" > #P"obj/from-xc/src/code/backq.lisp-obj" > #P"obj/from-xc/src/code/globals.lisp-obj" > #P"obj/from-xc/src/code/defsetfs.lisp-obj" ...) > * > T > * [undoing binding stack and other enclosing state... done] > [saving current Lisp image into /Users/sly/projects/sf.net/builds/ > darwin-x86-64+sb-thread/sbcl/output/after-xc.core: > scanning space for lutexes... > writing 1920 bytes from the read-only space at 0x04000000 > scanning space for lutexes... > writing 2096 bytes from the static space at 0x08000000 > scanning space for lutexes... > fatal error encountered in SBCL pid 2372(tid 2684407744): > no size function for object at 0x1042b5bc (widetag 0xbc) > > Looks like the futex stuff changed in this build, so the lutex stuff > probably did too. The x86/darwin/thread builds work however. It should not have changed: the deadlines aren't used on timeouts. But this is Not Good. I have observed that x86/Darwin has been getting increasingly erratic lately: changes that logically should be fine are causing unhandled SIGILLs, with LDB backtraces that usually in (probably bogus) os_get_runtime_executable_path(). Then there is the SIGILL during backtrace in threads.impure.lisp, which occurs only sometimes. My guess: we're doing something wrong with our contexts, which could easily cause GC trouble as well. Cheers, -- Nikodemus > > Cyrus > > Begin forwarded message: > >> From: Nikodemus Siivola <de...@us...> >> Date: April 29, 2007 2:57:47 PM PDT >> To: sbc...@li... >> Subject: [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 >> >> 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)) >> >> >> ---------------------------------------------------------------------- >> --- >> This SF.net email is sponsored by DB2 Express >> Download DB2 Express C - the FREE version of DB2 express and take >> control of your XML. No limits. Just data. Click to get it now. >> http://sourceforge.net/powerbar/db2/ >> _______________________________________________ >> Sbcl-commits mailing list >> Sbc...@li... >> https://lists.sourceforge.net/lists/listinfo/sbcl-commits > > > ------------------------------------------------------------------------- > This SF.net email is sponsored by DB2 Express > Download DB2 Express C - the FREE version of DB2 express and take > control of your XML. No limits. Just data. Click to get it now. > http://sourceforge.net/powerbar/db2/ > _______________________________________________ > Sbcl-devel mailing list > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-devel |
From: Nikodemus S. <nik...@ra...> - 2007-05-04 08:59:01
|
Nikodemus Siivola wrote: > It should not have changed: the deadlines aren't used on timeouts. I meant to say deadlines aren't used on lutexes. > But this is Not Good. I have observed that x86/Darwin has been > getting increasingly erratic lately: changes that logically should > be fine are causing unhandled SIGILLs, with LDB backtraces > that usually in (probably bogus) os_get_runtime_executable_path(). > Then there is the SIGILL during backtrace in threads.impure.lisp, > which occurs only sometimes. > > My guess: we're doing something wrong with our contexts, which > could easily cause GC trouble as well. Cheers, -- Nikodemus |
On May 4, 2007, at 1:42 AM, Nikodemus Siivola wrote: > It should not have changed: the deadlines aren't used on timeouts. hrm... I wonder what broke things then. yes, this is not good. > But this is Not Good. I have observed that x86/Darwin has been > getting increasingly erratic lately: changes that logically should > be fine are causing unhandled SIGILLs, with LDB backtraces > that usually in (probably bogus) os_get_runtime_executable_path(). > Then there is the SIGILL during backtrace in threads.impure.lisp, > which occurs only sometimes. I think gdb reports os_get_runtime_exectuable_path when when we're actually signal_emulation_wrapper (or something similar). It seems to be reporting the function before/after (I can't remember which). not sure why it's not getting that right. So it seems there are a couple of problems (or at least a couple of symptoms): 1. subtle changes causing build failures - this smacks of stack alignment, but we've tried pretty hard to get this right. that damn print vop being the most recent example that springs to mind. 2. x86-64/darwin/threads build failure - this may or may not be the same as 1. 3. threads.impure.lisp failures on x86/darwin/threads. The threads tests have actually gotten much more reliable lately, thanks to your hard work here, I presume. However, "much more" means that I can occasionally get the test to pass. Getting it to occasionally fail instead would be better and to reliably pass better still. 4. threads.impure.lisp on x86-64/darwin/threads. Threads seem much more broken than on x86. The tests die rather early in the gc or interrupt tests (I forget which). 5. the x86-64/darwin debugger problems. I never revisited the nth- interrupt-context solution proposed by jsnell at ILC and committed and subsequently backed out by me. This would be good to do. Alastair was talking about some fairly radical calling convention changes so that we wouldn't have to guess wether we were in a lisp or C calling frame. Not sure what the status of this work is, but that offers one path out of this morass. gbyers' email on openmcl-devel (even if it was meant for another destination) is good reading re: mach exception handlers. I think it would be nice to develop some sort of test program that mixes mach exceptions, posix/bsd signals, allocating memory and atomically changing values and seeing if we can get things to break there. One other thing I don't like is that we're mallocing inside our signal emulation wrapper. This is also a workaround for the calling conventions as, thanks to nyef's sleuthing, we were blowing up trying to walk the stack and guessing wrong as to whether it was a lisp or a C frame a while back. Oh, and while I'm at it, the way we allocate mach exception ports and use the pointer as the mach_port_t is totally bogus on x86-64. This will fail if the malloc call returns a value > 32 bits. We need to have some sort of lookup table from port identifiers to the actual thread, unfortunately, as mach ports are only a 32-bit value. Cyrus |
From: Nikodemus S. <nik...@ra...> - 2007-05-05 11:21:05
|
My current pet theory is that there is some point on Darwin where a GC can happen without the context being in thread->interrupt_contexts, in other words, a point where sig_stop_for_gc isn't blocked and fake_foreign_function_call hasn't been done yet. Cheers, -- Nikodemus |
From: Yaroslav K. <kav...@tu...> - 2007-05-06 08:41:12
Attachments:
deadline.lisp.diff
|
I wrote: >> Added Files: >> deadline.lisp >> Log Message: >> 1.0.5.9: experimental semi-synchronous deadlines > ... >> (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)))) > > sb!unix::micro-seconds-per-internal-time-unit is not defined on win-32 > Maybe so? -- WBR, Yaroslav Kavenchuk. |