[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: improved version of CLX available
Here is a copy of my recent locking + Lucid IO speedup patch made for
CLX R3, in theory in a format acceptable to the patch program. Lucid
IO speedups are all in dependent.l. More process locking is in the
other files. The files are in alphabetical order in this message.
This patch is only for R3; the previous version sent out was for R2.
If you applied the R2 patch to R3 (which works sort of; you have to
edit the patch a little bit) don't apply this one...
yduJ (Judy Anderson)
Lucid East
yduJ@lucid.com
edsel!yduJ@labrea.stanford.edu
...!sun!edsel!yduJ
(617)784-6114
---------------------------------------------------------------------------
*** /x11-r3/lib/CLX/attributes.l Wed Mar 16 12:27:11 1988
--- /x11r3/lucid-clx/attributes.lisp Mon Mar 6 14:03:28 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
*** /x11-r3/lib/CLX/dependent.l Sat Oct 22 10:43:42 1988
--- /x11r3/lucid-clx/dependent.lisp Mon Mar 6 14:02:50 1989
***************
*** 479,488 ****
(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
--- 479,490 ----
(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
***************
*** 1035,1046 ****
(c-read-bytes fd vector start howmany)
)))))))))))))
;;; 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 genera explorer excl)
(defmacro CL-read-bytes (stream vector start end)
`(do* ((i ,start (index+ i 1))
(c nil))
--- 1037,1110 ----
(c-read-bytes fd vector start howmany)
)))))))))))))
+ #+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.
+ `(or (getf (display-plist ,display) ,direction)
+ (setf (getf (display-plist ,display) ,direction)
+ (lucid::underlying-stream ,stream (if (eq ,direction 'input)
+ :input
+ :output)))))
+
+ #+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 genera explorer excl lcl3.0)
(defmacro CL-read-bytes (stream vector start end)
`(do* ((i ,start (index+ i 1))
(c nil))
***************
*** 1053,1062 ****
(return t))))
;; Poll for input every *buffer-read-polling-time* SECONDS.
! #-(or genera explorer excl)
(defparameter *buffer-read-polling-time* 0.5)
! #-(or genera explorer excl)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
--- 1117,1126 ----
(return t))))
;; Poll for input every *buffer-read-polling-time* SECONDS.
! #-(or genera explorer excl lcl3.0)
(defparameter *buffer-read-polling-time* 0.5)
! #-(or genera explorer excl lcl3.0)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
***************
*** 1104,1109 ****
--- 1168,1189 ----
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.
***************
*** 1110,1116 ****
;;; You are STRONGLY encouraged to write a specialized version
;;; of buffer-write-default that does block transfers.
! #-(or genera 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)
--- 1190,1196 ----
;;; You are STRONGLY encouraged to write a specialized version
;;; of buffer-write-default that does block transfers.
! #-(or genera 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)
*** /x11-r3/lib/CLX/graphics.l Thu Aug 11 17:34:28 1988
--- /x11r3/lucid-clx/graphics.lisp Mon Mar 6 14:03:15 1989
***************
*** 421,437 ****
(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)))
--- 421,438 ----
(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)))
*** /x11-r3/lib/CLX/macros.l Tue Aug 30 07:58:24 1988
--- /x11r3/lucid-clx/macros.lisp Mon Mar 6 14:03:11 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)))
*** /x11-r3/lib/CLX/requests.l Sat Sep 3 06:59:22 1988
--- /x11r3/lucid-clx/requests.lisp Mon Mar 6 14:03:07 1989
***************
*** 1086,1092 ****
(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)
--- 1086,1092 ----
(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)
***************
*** 1095,1107 ****
((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)))
--- 1095,1108 ----
((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)))
***************
*** 1202,1220 ****
(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))
--- 1203,1222 ----
(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))