diff options
| -rw-r--r-- | xc/unsupported/lib/CLX/buffer.l | 20 | ||||
| -rw-r--r-- | xc/unsupported/lib/CLX/display.l | 9 | ||||
| -rw-r--r-- | xc/unsupported/lib/CLX/gcontext.l | 174 | ||||
| -rw-r--r-- | xc/unsupported/lib/CLX/graphics.l | 14 | ||||
| -rw-r--r-- | xc/unsupported/lib/CLX/macros.l | 4 |
5 files changed, 131 insertions, 90 deletions
diff --git a/xc/unsupported/lib/CLX/buffer.l b/xc/unsupported/lib/CLX/buffer.l index 7469be68f..c54a58556 100644 --- a/xc/unsupported/lib/CLX/buffer.l +++ b/xc/unsupported/lib/CLX/buffer.l @@ -62,7 +62,14 @@ ;; exclusive access to the local buffer object for request generation and ;; reply processing. (if (and (null inline) (macroexpand '(use-closures) env)) - `(with-buffer-function ,buffer ,timeout #'(lambda () ,@body)) + `(with-buffer-function + ,buffer ,timeout + #'(lambda () + (macrolet ((with-buffer ((buffer &key timeout) &body body) + ;; Speedup hack for lexically nested with-buffers + `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) + ,@body))) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(macrolet ((with-buffer ((buffer &key timeout) &body body) ;; Speedup hack for lexically nested with-buffers @@ -282,6 +289,17 @@ (without-aborts (funcall request-function display))) (display-invoke-after-function display)))) +(defun with-buffer-request-function-nolock (display gc-force request-function) + (declare (type display display) + (type (or null gcontext) gc-force)) + (declare (type function request-function) + (downward-funarg request-function)) + (multiple-value-prog1 + (progn + (when gc-force (force-gcontext-changes-internal gc-force)) + (without-aborts (funcall request-function display))) + (display-invoke-after-function display))) + (defstruct (pending-command (:copier nil) (:predicate nil)) (sequence 0 :type card16) (reply-buffer nil :type (or null reply-buffer)) diff --git a/xc/unsupported/lib/CLX/display.l b/xc/unsupported/lib/CLX/display.l index 2c8694918..35ceeac22 100644 --- a/xc/unsupported/lib/CLX/display.l +++ b/xc/unsupported/lib/CLX/display.l @@ -205,7 +205,14 @@ &body body &environment env) ;; exclusive access to event queue (if (and (null inline) (macroexpand '(use-closures) env)) - `(with-event-queue-function ,display ,timeout #'(lambda () ,@body)) + `(with-event-queue-function + ,display ,timeout + #'(lambda () + (macrolet ((with-event-queue ((display &key timeout) &body body) + ;; Speedup hack for lexically nested with-event-queues + `(progn (progn ,display ,@(and timeout `(,timeout)) nil) + ,@body))) + ,@body))) (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(macrolet ((with-event-queue ((display &key timeout) &body body) ;; Speedup hack for lexically nested with-event-queues diff --git a/xc/unsupported/lib/CLX/gcontext.l b/xc/unsupported/lib/CLX/gcontext.l index ca74ffa2f..ed415b66e 100644 --- a/xc/unsupported/lib/CLX/gcontext.l +++ b/xc/unsupported/lib/CLX/gcontext.l @@ -406,98 +406,106 @@ (defun force-gcontext-changes-internal (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) + #.(declare-buffun) + (let ((display (gcontext-display gcontext)) (server-state (gcontext-server-state gcontext)) (local-state (gcontext-local-state gcontext))) (declare (type display display) (type gcontext-state server-state local-state)) + ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) (the fixnum (gcontext-internal-timestamp server-state))) - - ;; Because there is no locking on the local state we have to - ;; assume that state will change and set timestamps up front, - ;; otherwise by the time we figured out there were no changes - ;; and tried to store the server stamp as the local stamp, the - ;; local stamp might have since been modified. - (setf (gcontext-internal-timestamp local-state) - (incf-internal-timestamp server-state)) - - (block no-changes - (let ((last-request (buffer-last-request display))) - (with-buffer-request (display *x-changegc*) - (gcontext gcontext) - (progn - (do ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 12) - (mask 0) - (local 0)) - ((index>= i *gcontext-fast-change-length*) - (when (zerop mask) - ;; If nothing changed, restore last-request and quit - (setf (buffer-last-request display) - (if (zerop (buffer-last-request display)) - nil - last-request)) - (return-from no-changes nil)) - (card29-put 8 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql (the (or null card32) (svref server-state i)) - (setq local (the (or null card32) (svref local-state i)))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))))) - - ;; Update GContext extensions - (do ((extension *gcontext-extensions* (cdr extension)) - (i *gcontext-data-length* (index+ i 1)) - (local)) - ((endp extension)) - (unless (eql (svref server-state i) - (setq local (svref local-state i))) - (setf (svref server-state i) local) - (funcall (gcontext-extension-set-function (car extension)) gcontext local))) - - ;; Update clipping rectangles - (multiple-value-bind (local-clip server-clip) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip server-state))) - (unless (equalp local-clip server-clip) - (setf (gcontext-internal-clip server-state) nil) - (unless (null local-clip) - (with-buffer-request (display *x-setcliprectangles*) - (data (first local-clip)) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-clip-x local-state) 0) - (or (gcontext-internal-clip-y local-state) 0)) - ;; XXX this has both int16 and card16 values - ((sequence :format int16) (second local-clip))) - (setf (gcontext-internal-clip server-state) local-clip)))) - - ;; Update dashes - (multiple-value-bind (local-dash server-dash) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dash server-state))) - (unless (equalp local-dash server-dash) - (setf (gcontext-internal-dash server-state) nil) - (unless (null local-dash) - (with-buffer-request (display *x-setdashes*) + + ;; The display is already locked. + (macrolet ((with-buffer ((buffer &key timeout) &body body) + `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) + + ;; Because there is no locking on the local state we have to + ;; assume that state will change and set timestamps up front, + ;; otherwise by the time we figured out there were no changes + ;; and tried to store the server stamp as the local stamp, the + ;; local stamp might have since been modified. + (setf (gcontext-internal-timestamp local-state) + (incf-internal-timestamp server-state)) + + (block no-changes + (let ((last-request (buffer-last-request display))) + (with-buffer-request (display *x-changegc*) (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-dash-offset local-state) 0) - (length local-dash)) - ((sequence :format card8) local-dash)) - (setf (gcontext-internal-dash server-state) local-dash))))))) + (progn + (do ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 12) + (mask 0) + (local 0)) + ((index>= i *gcontext-fast-change-length*) + (when (zerop mask) + ;; If nothing changed, restore last-request and quit + (setf (buffer-last-request display) + (if (zerop (buffer-last-request display)) + nil + last-request)) + (return-from no-changes nil)) + (card29-put 8 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql (the (or null card32) (svref server-state i)) + (setq local (the (or null card32) (svref local-state i)))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))))) + + ;; Update GContext extensions + (do ((extension *gcontext-extensions* (cdr extension)) + (i *gcontext-data-length* (index+ i 1)) + (local)) + ((endp extension)) + (unless (eql (svref server-state i) + (setq local (svref local-state i))) + (setf (svref server-state i) local) + (funcall (gcontext-extension-set-function (car extension)) gcontext local))) + + ;; Update clipping rectangles + (multiple-value-bind (local-clip server-clip) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip server-state))) + (unless (equalp local-clip server-clip) + (setf (gcontext-internal-clip server-state) nil) + (unless (null local-clip) + (with-buffer-request (display *x-setcliprectangles*) + (data (first local-clip)) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-clip-x local-state) 0) + (or (gcontext-internal-clip-y local-state) 0)) + ;; XXX this has both int16 and card16 values + ((sequence :format int16) (second local-clip))) + (setf (gcontext-internal-clip server-state) local-clip)))) + + ;; Update dashes + (multiple-value-bind (local-dash server-dash) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dash server-state))) + (unless (equalp local-dash server-dash) + (setf (gcontext-internal-dash server-state) nil) + (unless (null local-dash) + (with-buffer-request (display *x-setdashes*) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-dash-offset local-state) 0) + (length local-dash)) + ((sequence :format card8) local-dash)) + (setf (gcontext-internal-dash server-state) local-dash)))))))) (defun force-gcontext-changes (gcontext) ;; Force any delayed changes. diff --git a/xc/unsupported/lib/CLX/graphics.l b/xc/unsupported/lib/CLX/graphics.l index aac82482e..27d605405 100644 --- a/xc/unsupported/lib/CLX/graphics.l +++ b/xc/unsupported/lib/CLX/graphics.l @@ -41,8 +41,9 @@ (type gcontext gcontext) (type int16 x y)) (let ((display (drawable-display drawable))) + (declare (type display display)) (with-display (display) - (force-gcontext-changes gcontext) + (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length *requestsize*) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) @@ -103,11 +104,12 @@ (type int16 x1 y1 x2 y2) (type boolean relative-p)) (let ((display (drawable-display drawable))) + (declare (type display display)) (when relative-p (incf x2 x1) (incf y2 y1)) (with-display (display) - (force-gcontext-changes gcontext) + (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length *requestsize*) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) @@ -195,8 +197,10 @@ (type boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*))) + (declare (type display display) + (type card16 request)) (with-display (display) - (force-gcontext-changes gcontext) + (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length *requestsize*) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) @@ -261,8 +265,10 @@ (type boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p *x-polyfillarc* *x-polyarc*))) + (declare (type display display) + (type card16 request)) (with-display (display) - (force-gcontext-changes gcontext) + (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length *requestsize*) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) diff --git a/xc/unsupported/lib/CLX/macros.l b/xc/unsupported/lib/CLX/macros.l index b4620ce06..bd08d5d1b 100644 --- a/xc/unsupported/lib/CLX/macros.l +++ b/xc/unsupported/lib/CLX/macros.l @@ -689,7 +689,9 @@ &body type-args &environment env) (declare (values request-number)) (if (and (null inline) (macroexpand '(use-closures) env)) - `(with-buffer-request-function + `(,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) + 'with-buffer-request-function-nolock + 'with-buffer-request-function) ,buffer ,gc-force #'(lambda (.display.) (declare (type display .display.)) |