yduJ@LUCID.COM (Judy Anderson) (02/10/89)
The following diffs are for release TWO (sorry, we've been in a tearing hurry and haven't used release three yet) of X11 CLX, running under Lucid 3.0. They assume you have applied my previous patches (sent out to bug-clx only several months ago). There are two purposes in these patches: 1: adding several places where more process locking is required to prevent "Received a reply when none was expected" errors, and 2: I/O speedups. The file dependent.l is the one directed towards I/O speedups, the rest are process locking. I hope to start using R3 soon and send out a message saying either "the same patches will work" or "here's a new set for R3". However, since announcing at the X conference that I had changes to CLX I've been being deluged with fan mail asking for the changes, so here they are, a bit early and only guaranteed for R2. The I/O speedups rely on Lucid's 3.0 I/O system, which is incompatible with Lucid 2.1, so all of these hacks are under #+LCL3.0. yduJ (Judy Anderson) Lucid East yduJ@lucid.com edsel!yduJ@labrea.stanford.edu ...!sun!edsel!yduJ (617)784-6114 (415)329-8400x4500 --------------------------------------------------------------------------- *** lib/CLX/dependent.l Fri Oct 21 22:40:11 1988 --- lib/LUCID-CLX/dependent.lisp Thu Feb 9 10:44:32 1989 *************** *** 428,437 **** (defun radians->int16 (value) ;; Short floats are good enough ! (declare (type float value)) (declare-values int16) (declare-buffun) ! (the int16 (identity (round (* value 180.0s0 64.0s0) #.(coerce pi 'short-float))))) (defun int16->radians (value) ;; Short floats are good enough --- 428,439 ---- (defun radians->int16 (value) ;; Short floats are good enough ! ;; Note that this gets called with integer zero sometimes and not all ! ;; implementations will have integer zero and float zero the same... --yduJ ! ; (declare (type float value)) (declare-values int16) (declare-buffun) ! (the int16 (identity (round (* (float value) 180.0s0 64.0s0) #.(coerce pi 'short-float))))) (defun int16->radians (value) ;; Short floats are good enough *************** *** 886,897 **** (minusp (c-read-bytes fd vector start end)))))))))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. ! #-(or symbolics-3600 explorer excl) (defmacro CL-read-bytes (stream vector start end) `(do* ((i ,start (index+ i 1)) (c nil)) --- 888,963 ---- (minusp (c-read-bytes fd vector start end)))))))))) + #+lcl3.0 + (defmacro fast-read-bytes (stream vector start end) + `(do* ((i ,start (index+ i 1)) + (c nil)) + ((index>= i ,end) nil) + (declare (type array-index i) + (type (or null card8) c)) + (setq c (lcl:fast-read-byte ,stream (unsigned-byte 8) nil nil)) + (if c + (setf (aref ,vector i) c) + (return t)))) + + #+lcl3.0 + (defmacro extract-underlying-stream (stream display direction) + ;;;Our job is to quickly get at the underlying stream for this display's + ;;;input stream structure. + `(let ((pair (assoc ,direction (display-plist ,display)))) + (if pair (second pair) + (progn + (push (list ,direction + (lucid::underlying-stream ,stream ,direction)) + (display-plist ,display)) + (second (assoc ,direction (display-plist ,display))))))) + + #+lcl3.0 + (defun buffer-read-default (display vector start end timeout) + ;;Note that LISTEN must still be done on "slow stream" or the I/O system + ;;gets confused. But reading should be done from "fast stream" for speed. + ;;We inhibit scheduling when reading because there seem to be races in + ;;Lucid's multitasking implementation. + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout) + (optimize (speed 3) + (safety 0))) + (let* ((stream (display-input-stream display)) + (fast-stream (extract-underlying-stream stream display :input))) + (cond ((or (null timeout) + (listen stream)) + (lcl:with-scheduling-inhibited + (fast-read-bytes fast-stream vector start end)) + nil) ;return NIL, it expects that + ((or (minusp timeout) (zerop timeout)) + ;;negative timeout means try once, Jerry's hack. Zerop seems + ;;to *also* mean try once; don't understand why Jerry wanted -1. + (if (listen stream) + (lcl:with-scheduling-inhibited + (fast-read-bytes fast-stream vector start end)) + :timeout)) + (timeout ;otherwise we have a bona-fide timeout on our hands which + ;we should wait for. + (let ((input-appeared + (lucid::waiting-for-input-from-stream fast-stream + (lucid::with-io-unlocked + (lcl:process-wait-with-timeout + "Waiting for CLX server response" + timeout #'listen stream))))) + (if input-appeared + (lcl:with-scheduling-inhibited + (fast-read-bytes fast-stream vector start end)) + :timeout)))))) + + ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. ! #-(or symbolics-3600 explorer excl lcl3.0) (defmacro CL-read-bytes (stream vector start end) `(do* ((i ,start (index+ i 1)) (c nil)) *************** *** 904,913 **** (return t)))) ;; Poll for input every *buffer-read-polling-time* SECONDS. ! #-(or symbolics-3600 explorer excl) (defparameter *buffer-read-polling-time* 0.5) ! #-(or symbolics-3600 explorer excl) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) --- 970,979 ---- (return t)))) ;; Poll for input every *buffer-read-polling-time* SECONDS. ! #-(or symbolics-3600 explorer excl lcl3.0) (defparameter *buffer-read-polling-time* 0.5) ! #-(or symbolics-3600 explorer excl lcl3.0) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) *************** *** 955,960 **** --- 1021,1042 ---- vector start end)) (error "X write failed: socket dead!"))) + #+lcl3.0 + (defun buffer-write-default (vector display start end) + ;;We inhibit scheduling here because there seem to be races in Lucid's + ;;multitasking implementation. Anyway, when we take it out we get bugs! + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (optimize (:tail-merge nil) + (speed 3) + (safety 0))) + (lcl:with-scheduling-inhibited + (lcl:write-array + (extract-underlying-stream + (display-output-stream display) display :output) + vector start end))) + ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. *************** *** 961,967 **** ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. ! #-(or symbolics-3600 explorer excl) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) --- 1043,1049 ---- ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. ! #-(or symbolics-3600 explorer excl lcl3.0) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) *** lib/CLX/attributes.l Thu Apr 7 14:27:34 1988 --- lib/LUCID-CLX/attributes.lisp Mon Feb 6 12:24:13 1989 *************** *** 269,288 **** (deallocate-gcontext-state (state-geometry-changes state-entry)) (setf (state-geometry-changes state-entry) nil)) ;; Get drawable attributes ! (with-buffer-request (display *x-getgeometry* :no-after) ! (drawable drawable)) ! (let ((buffer (or (state-geometry state-entry) ! (allocate-context)))) ! (wait-for-reply display *geometry-size*) ! ;; Copy into event from reply buffer ! (buffer-replace (reply-ibuf8 buffer) ! (reply-ibuf8 (buffer-reply-buffer display)) ! 0 ! *geometry-size*) ! (when state-entry ! (setf (state-geometry state-entry) buffer)) ! (display-invoke-after-function display) ! buffer)))))) (defun put-window-attribute-changes (window changes) ;; change window attributes --- 269,289 ---- (deallocate-gcontext-state (state-geometry-changes state-entry)) (setf (state-geometry-changes state-entry) nil)) ;; Get drawable attributes ! (with-input-lock (display) ! (with-buffer-request (display *x-getgeometry* :no-after) ! (drawable drawable)) ! (let ((buffer (or (state-geometry state-entry) ! (allocate-context)))) ! (wait-for-reply display *geometry-size*) ! ;; Copy into event from reply buffer ! (buffer-replace (reply-ibuf8 buffer) ! (reply-ibuf8 (buffer-reply-buffer display)) ! 0 ! *geometry-size*) ! (when state-entry ! (setf (state-geometry state-entry) buffer)) ! (display-invoke-after-function display) ! buffer))))))) (defun put-window-attribute-changes (window changes) ;; change window attributes *** lib/CLX/macros.l Wed Jun 29 17:46:39 1988 --- lib/LUCID-CLX/macros.lisp Mon Feb 6 12:24:24 1989 *************** *** 725,733 **** (declare-arglist (buffer &optional size &key sizes) &body body) (let ((buf (gensym))) `(let ((,buf ,buffer)) ! (wait-for-reply ,buf ,size) ! (reading-buffer-reply (,buf ,@options) ! ,@body)))) (defmacro compare-request ((index) &body body) `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) --- 725,735 ---- (declare-arglist (buffer &optional size &key sizes) &body body) (let ((buf (gensym))) `(let ((,buf ,buffer)) ! ;;;This better always be called with a display. ! (with-input-lock (,buf) ! (wait-for-reply ,buf ,size) ! (reading-buffer-reply (,buf ,@options) ! ,@body))))) (defmacro compare-request ((index) &body body) `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) *** lib/CLX/graphics.l Wed Jun 29 17:47:57 1988 --- lib/LUCID-CLX/graphics.lisp Mon Feb 6 12:24:21 1989 *************** *** 422,438 **** (let ((display (drawable-display drawable)) seq depth visual) (with-display (display) ! (with-buffer-request (display *x-getimage* :no-after) ! ((data (member error :xy-pixmap :z-pixmap)) format) ! (drawable drawable) ! (int16 x y) ! (card16 width height) ! (card32 plane-mask)) ! (with-buffer-reply (display nil :sizes (8 32)) ! (setq depth (card8-get 1) ! visual (resource-id-get 8)) ! (let ((length (* 4 (card32-get 4)))) ! (setq seq (sequence-get :result-type result-type :format card8 ! :length length :start start :data data))))) (display-invoke-after-function display) (values seq depth visual))) --- 422,439 ---- (let ((display (drawable-display drawable)) seq depth visual) (with-display (display) ! (with-input-lock (display) ! (with-buffer-request (display *x-getimage* :no-after) ! ((data (member error :xy-pixmap :z-pixmap)) format) ! (drawable drawable) ! (int16 x y) ! (card16 width height) ! (card32 plane-mask)) ! (with-buffer-reply (display nil :sizes (8 32)) ! (setq depth (card8-get 1) ! visual (resource-id-get 8)) ! (let ((length (* 4 (card32-get 4)))) ! (setq seq (sequence-get :result-type result-type :format card8 ! :length length :start start :data data)))))) (display-invoke-after-function display) (values seq depth visual))) *** lib/CLX/requests.l Mon Jul 18 13:59:12 1988 --- lib/LUCID-CLX/requests.lisp Mon Feb 6 12:24:26 1989 *************** *** 1085,1091 **** (declare (type colormap colormap) (type card16 colors planes) (type boolean contiguous-p) ! (type t result-type)) ;; CL type (declare-values (sequence pixel) (sequence mask)) (let ((display (colormap-display colormap)) pixel-sequence mask-sequence) --- 1085,1091 ---- (declare (type colormap colormap) (type card16 colors planes) (type boolean contiguous-p) ! (type t result-type));; CL type (declare-values (sequence pixel) (sequence mask)) (let ((display (colormap-display colormap)) pixel-sequence mask-sequence) *************** *** 1094,1106 **** ((data boolean) contiguous-p) (colormap colormap) (card16 colors planes)) ! (with-buffer-reply (display nil :sizes 16) ! (let ((npixels (card16-get 8)) ! (nmasks (card16-get 10))) ! (setq pixel-sequence ! (sequence-get :result-type result-type :length npixels)) ! (setq mask-sequence ! (sequence-get :result-type result-type :length nmasks))))) (display-invoke-after-function display) (values pixel-sequence mask-sequence))) --- 1094,1107 ---- ((data boolean) contiguous-p) (colormap colormap) (card16 colors planes)) ! (with-input-lock (display) ! (with-buffer-reply (display nil :sizes 16) ! (let ((npixels (card16-get 8)) ! (nmasks (card16-get 10))) ! (setq pixel-sequence ! (sequence-get :result-type result-type :length npixels)) ! (setq mask-sequence ! (sequence-get :result-type result-type :length nmasks)))))) (display-invoke-after-function display) (values pixel-sequence mask-sequence))) *************** *** 1201,1219 **** (let ((display (colormap-display colormap)) sequence) (with-display (display) ! (with-buffer-request (display *x-querycolors* :no-after) ! (colormap colormap) ! (sequence pixels)) ! (wait-for-reply display nil) ! (reading-buffer-reply (display :sizes (8 16)) ! (let* ((ncolors (card16-get 8))) ! (setq sequence (make-sequence result-type ncolors)) ! (dotimes (i ncolors sequence) ! (buffer-input display buffer-bbuf 0 8) ! (setf (elt sequence i) ! (make-color :red (rgb-val-get 0) ! :green (rgb-val-get 2) ! :blue (rgb-val-get 4))))))) (display-invoke-after-function display) sequence)) --- 1202,1221 ---- (let ((display (colormap-display colormap)) sequence) (with-display (display) ! (with-input-lock (display) ! (with-buffer-request (display *x-querycolors* :no-after) ! (colormap colormap) ! (sequence pixels)) ! (wait-for-reply display nil) ! (reading-buffer-reply (display :sizes (8 16)) ! (let* ((ncolors (card16-get 8))) ! (setq sequence (make-sequence result-type ncolors)) ! (dotimes (i ncolors sequence) ! (buffer-input display buffer-bbuf 0 8) ! (setf (elt sequence i) ! (make-color :red (rgb-val-get 0) ! :green (rgb-val-get 2) ! :blue (rgb-val-get 4)))))))) (display-invoke-after-function display) sequence))