[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Patches for CLX under Lucid 3.0 and X11R2
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))