Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24542

Modified Files: graphics.lisp medium.lisp recording.lisp sheets.lisp Log Message: Drawing optimizations, with a focus on eliminating clipping rectangle changes and transformation cache invalidations (the latter generally caused by the former). Shortcuts for special cases in d-g-w-o-internal, merge-text-styles, regions. Further mcclim-freetype optimization - minimize modification of picture-clip-rectangle and painting of the foreground tile (this used to happen for every single draw-text call). One or two optimizations in output record playback.

The mcclim-freetype changes require a fix to CLX, available in Christophe's CLX in darcs, or from here:

http://vintage-digital.com/hefner/mcclim/xrender-clip-state.diff

--- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/09 16:57:54 1.59 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/21 01:26:42 1.60 @@ -89,26 +89,29 @@ (changed-line-style line-style-p) (changed-text-style text-style-p)) (unwind-protect - (progn + (progn (when (eq ink old-ink) (setf ink nil))

- (if ink + (when ink (setf (medium-ink medium) ink)) - (if transformation + (when transformation (setf (medium-transformation medium) (compose-transformations old-transform transformation)))

(when (and clipping-region old-clip - (region-equal clipping-region old-clip)) - (setf clipping-region nil)) - - (if clipping-region - (setf (medium-clipping-region medium) - (region-intersection (if transformation - (transform-region transformation old-clip) - old-clip) - clipping-region))) - (if (null line-style) + (or (eq clipping-region +everywhere+) + (eq clipping-region old-clip) + (region-contains-region-p clipping-region old-clip)) + #+NIL (region-equal clipping-region old-clip)) + (setf clipping-region nil)) + + (when clipping-region + (setf (medium-clipping-region medium) + (region-intersection (if transformation + (transform-region transformation old-clip) + old-clip) + clipping-region))) + (when (null line-style) (setf line-style old-line-style)) (when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape) (setf changed-line-style t) @@ -128,7 +131,7 @@ (if text-style-p (setf text-style (merge-text-styles text-style (medium-merged-text-style medium))) - (setf text-style (medium-merged-text-style medium))) + (setf text-style (medium-merged-text-style medium))) (when (or text-family-p text-face-p text-size-p) (setf changed-text-style t) (setf text-style (merge-text-styles (make-text-style text-family --- /project/mcclim/cvsroot/mcclim/medium.lisp 2007/03/20 01:41:17 1.63 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2008/01/21 01:26:42 1.64 @@ -199,7 +199,8 @@ (defun device-font-text-style-p (s) (typep s 'device-font-text-style))

-(defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style)) +(defmethod text-style-equalp ((style1 device-font-text-style) + (style2 device-font-text-style)) (eq style1 style2))

(defmethod text-style-mapping ((port basic-port) text-style @@ -236,6 +237,10 @@ ;;; Text-style utilities

(defmethod merge-text-styles (s1 s2) + (when (and (typep s1 'text-style) + (typep s2 'text-style) + (eq s1 s2)) + (return-from merge-text-styles s1)) (setq s1 (parse-text-style s1)) (setq s2 (parse-text-style s2)) (if (and (not (device-font-text-style-p s1)) @@ -398,7 +403,7 @@

(defmethod (setf medium-clipping-region) :after (region (medium medium)) (declare (ignore region)) - (let ((sheet (medium-sheet medium))) + (let ((sheet (medium-sheet medium))) (when sheet (invalidate-cached-regions sheet))))

--- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/09/07 16:49:11 1.135 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 01:26:42 1.136 @@ -518,6 +518,7 @@ ;; since an enqueued repaint does not occur immediately, and highlight ;; rectangles are not recorded, newer highlighting gets wiped out ;; shortly after being drawn. So, we aren't ready for this yet. + ;; ..Actually, it isn't necessarily faster. Depends on the app. #+NIL (queue-repaint stream (make-instance 'window-repaint-event :sheet stream @@ -1030,15 +1031,21 @@ (apply function (tree-output-record-entry-record child) function-args)))

(defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args) - (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last + (map-over-tree-output-records function record + (%record-to-spatial-tree-rectangle record) :most-recent-last function-args))

-(defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args) +(defmethod map-over-output-records-containing-position + (function (record standard-tree-output-record) x y + &optional x-offset y-offset &rest function-args) (declare (ignore x-offset y-offset)) - (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first + (map-over-tree-output-records function record + (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first function-args))

-(defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args) +(defmethod map-over-output-records-overlapping-region + (function (record standard-tree-output-record) region + &optional x-offset y-offset &rest function-args) (declare (ignore x-offset y-offset)) (typecase region (everywhere-region (map-over-output-records-1 function record function-args)) @@ -1122,8 +1129,12 @@ (defmethod replay-output-record :around ((record gs-clip-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) - (with-drawing-options (stream :clipping-region (graphics-state-clip record)) - (call-next-method))) + (let ((clipping-region (graphics-state-clip record))) + (if (or (eq clipping-region +everywhere+) ; !!! + (region-contains-region-p clipping-region (medium-clipping-region stream))) + (call-next-method) + (with-drawing-options (stream :clipping-region (graphics-state-clip record)) + (call-next-method)))))

(defrecord-predicate gs-clip-mixin ((:clipping-region clip)) (if-supplied (clip) @@ -1719,7 +1730,7 @@ (:bottom (incf top (- point-y descent)) (incf bottom (- point-y descent))) (:center (incf top (+ point-y (ceiling (- ascent descent) 2))) - (incf bottom (+ point-y (ceiling (- ascent descent) 2))))) + (incf bottom (+ point-xy (ceiling (- ascent descent) 2))))) (values left top right bottom))))

(defmethod* (setf output-record-position) :around @@ -1875,6 +1886,11 @@ ;; the styled strings here not simply be output ;; records? Then we could just replay them and all ;; would be well. -- CSR, 20060528. + ;; But then we'd have to implement the output record + ;; protocols for them. Are we allowed no internal + ;; structure of our own? -- Hefner, 20080118 + + ;; Some optimization might be possible here. (with-drawing-options (stream :ink (graphics-state-ink substring) :clipping-region (graphics-state-clip substring) @@ -2131,6 +2147,7 @@ line string-width &optional (start 0) end) + (when (and (stream-recording-p stream) (slot-value stream 'local-record-p)) (let* ((medium (sheet-medium stream)) @@ -2150,9 +2167,10 @@ :text-style text-style)) height ascent)))) + (when (stream-drawing-p stream) (without-local-recording stream - (call-next-method)))) + (call-next-method))))

#+nil (defmethod stream-write-char :around ((stream standard-output-recording-stream) char) --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2007/03/20 01:43:55 1.54 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/01/21 01:26:42 1.55 @@ -643,8 +643,8 @@ (update-mirror-geometry sheet))

(defmethod sheet-native-region ((sheet mirrored-sheet-mixin)) - (with-slots (native-region) sheet - (unless native-region + (with-slots (native-region) sheet + (unless native-region (let ((this-region (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (parent (sheet-parent sheet)))