[mcclim-cvs] CVS mcclim/Experimental/freetype
ahefner
ahefner at common-lisp.net
Mon Jan 21 01:26:43 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory clnet:/tmp/cvs-serv24542/Experimental/freetype
Modified Files:
freetype-fonts.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/Experimental/freetype/freetype-fonts.lisp 2008/01/17 09:54:21 1.20
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/21 01:26:43 1.21
@@ -117,7 +117,7 @@
(let ((glyph-set (or (getf (xlib:display-plist display) 'the-glyph-set)
(setf (getf (xlib:display-plist display) 'the-glyph-set)
(xlib::render-create-glyph-set
- (first (xlib::find-matching-picture-formats display
+ (first (xlib::find-matching-picture-formats display
:alpha 8 :red 0 :green 0 :blue 0)))))))
(setf lookaside (cons display glyph-set))
glyph-set))))
@@ -289,54 +289,86 @@
(xlib:drawable-root drawable))))))
(defun gcontext-picture (drawable gcontext)
- (or (getf (xlib:gcontext-plist gcontext) 'picture)
- (setf (getf (xlib:gcontext-plist gcontext) 'picture)
- (let ((pixmap (xlib:create-pixmap :drawable drawable
- :depth (xlib:drawable-depth drawable)
- :width 1 :height 1)))
- (list
- (xlib::render-create-picture
- pixmap
- :format (xlib::find-window-picture-format (xlib:drawable-root drawable))
- :repeat :on)
- pixmap)))))
+ (flet ((update-foreground (picture)
+ ;; FIXME! This makes assumptions about pixel format, and breaks
+ ;; on 16 bpp displays.
+ (let ((fg (the xlib:card32 (xlib:gcontext-foreground gcontext))))
+ (xlib::render-fill-rectangle picture
+ :src
+ (list (ash (ldb (byte 8 16) fg) 8)
+ (ash (ldb (byte 8 8) fg) 8)
+ (ash (ldb (byte 8 0) fg) 8)
+ #xFFFF)
+ 0 0 1 1))))
+ (let* ((fg (xlib:gcontext-foreground gcontext))
+ (picture-info
+ (or (getf (xlib:gcontext-plist gcontext) 'picture)
+ (setf (getf (xlib:gcontext-plist gcontext) 'picture)
+ (let* ((pixmap (xlib:create-pixmap
+ :drawable drawable
+ :depth (xlib:drawable-depth drawable)
+ :width 1 :height 1))
+ (picture (xlib::render-create-picture
+ pixmap
+ :format (xlib::find-window-picture-format
+ (xlib:drawable-root drawable))
+ :repeat :on)))
+ (update-foreground picture)
+ (list fg
+ picture
+ pixmap))))))
+ (unless (eql fg (first picture-info))
+ (update-foreground (second picture-info))
+ (setf (first picture-info) fg))
+ (cdr picture-info))))
-(let ((buffer (make-array 1024 :element-type '(unsigned-byte 32) ; TODO: thread safety
+
+;;; Arbitrary restriction: No more than 65536 glyphs cached from
+;;; a single font. I don't think that's unreasonable.
+
+(let ((buffer (make-array 1024 :element-type '(unsigned-byte 16) ; TODO: thread safety
:adjustable nil :fill-pointer nil)))
- (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate)
- (declare (optimize (speed 3)))
+ (defun clim-clx::font-draw-glyphs (font #|(font freetype-face)|# mirror gc x y string
+ #|x0 y0 x1 y1|# &key start end translate)
+ (declare (optimize (speed 3))
+ (type #-sbcl (integer 0 #.array-dimension-limit)
+ #+sbcl sb-int:index
+ start end)
+ (type string string))
(when (< (length buffer) (- end start))
(setf buffer (make-array (* 256 (ceiling (- end start) 256))
- :element-type '(unsigned-byte 32)
+ :element-type '(unsigned-byte 16)
:adjustable nil :fill-pointer nil)))
(let ((display (xlib:drawable-display mirror)))
(destructuring-bind (source-picture source-pixmap) (gcontext-picture mirror gc)
- (let* ((fg (xlib:gcontext-foreground gc))
- (cache (slot-value font 'glyph-id-cache))
+ (let* ((cache (slot-value font 'glyph-id-cache))
(glyph-ids buffer))
+
(loop
for i from start below end ; TODO: Read optimization notes. Fix. Repeat.
for i* upfrom 0
as char = (aref string i)
as code = (char-code char)
do (setf (aref buffer i*)
- (or (gcache-get cache code)
- (gcache-set cache code (font-glyph-id font char)))))
+ (the (unsigned-byte 16)
+ (or (gcache-get cache code)
+ (gcache-set cache code (font-glyph-id font char))))))
+
+ ;; Debugging - show the text rectangle
+ ;(setf (xlib:gcontext-foreground gc) #xFF0000)
+ ;(xlib:draw-rectangle mirror gc x0 y0 (- x1 x0) (- y1 y0))
+
+ ;; Sync the picture-clip-mask with that of the gcontext.
+ (unless (eq (xlib::picture-clip-mask (drawable-picture mirror))
+ (xlib::gcontext-clip-mask gc))
+ (setf (xlib::picture-clip-mask (drawable-picture mirror))
+ (xlib::gcontext-clip-mask gc)))
- (xlib::render-fill-rectangle source-picture
- :src
- (list (ash (ldb (byte 8 16) fg) 8)
- (ash (ldb (byte 8 8) fg) 8)
- (ash (ldb (byte 8 0) fg) 8)
- #xFFFF)
- 0 0 1 1)
- (setf (xlib::picture-clip-mask (drawable-picture mirror))
- (xlib::gcontext-clip-mask gc))
(xlib::render-composite-glyphs
(drawable-picture mirror)
(display-the-glyph-set display)
source-picture
- x y
+ x y
glyph-ids
:end (- end start)))))))
@@ -533,15 +565,34 @@
(text-style-character-width text-style medium #\m))
(defmethod text-size ((medium clx-medium) string &key text-style (start 0) end)
+ (declare (optimize (speed 3)))
(when (characterp string)
(setf string (make-string 1 :initial-element string)))
+ (check-type string string)
(unless end (setf end (length string)))
+ (check-type start
+ #-sbcl (integer 0 #.array-dimension-limit)
+ #+sbcl sb-int:index)
+ (check-type end
+ #-sbcl (integer 0 #.array-dimension-limit)
+ #+sbcl sb-int:index)
(unless text-style (setf text-style (medium-text-style medium)))
(let ((xfont (text-style-to-X-font (port medium) text-style)))
(cond ((= start end)
(values 0 0 0 0 0))
(t
- (let ((position-newline (position #\newline string :start start)))
+ (let ((position-newline
+ (macrolet ((p (type)
+ `(locally
+ (declare (type ,type string))
+ (position #\newline string :start start))))
+ (typecase string
+ (simple-base-string (p simple-base-string))
+ #+SBCL (sb-kernel::simple-character-string (p sb-kernel::simple-character-string))
+ #+SBCL (sb-kernel::character-string (p sb-kernel::character-string))
+ (simple-string (p simple-string))
+ (string (p string))))))
+
(cond ((not (null position-newline))
(multiple-value-bind (width ascent descent left right
font-ascent font-descent direction
@@ -626,17 +677,18 @@
start end
align-x align-y
toward-x toward-y transform-glyphs)
- (declare (ignore toward-x toward-y transform-glyphs))
+ (declare (ignore toward-x toward-y transform-glyphs))
(with-transformed-position ((sheet-native-transformation (medium-sheet medium))
x y)
(with-clx-graphics (medium)
(when (characterp string)
(setq string (make-string 1 :initial-element string)))
(when (null end) (setq end (length string)))
- (multiple-value-bind (text-width text-height x-cursor y-cursor baseline)
+ (multiple-value-bind (text-width text-height x-cursor y-cursor baseline)
(text-size medium string :start start :end end)
(declare (ignore x-cursor y-cursor))
- (unless (and (eq align-x :left) (eq align-y :baseline))
+
+ (unless (and (eq align-x :left) (eq align-y :baseline))
(setq x (- x (ecase align-x
(:left 0)
(:center (round text-width 2))
@@ -645,17 +697,18 @@
(:top (+ y baseline))
(:center (+ y baseline (- (floor text-height 2))))
(:baseline y)
- (:bottom (+ y baseline (- text-height)))))))
- (let ((x (round-coordinate x))
- (y (round-coordinate y)))
- (when (and (<= #x-8000 x #x7FFF)
- (<= #x-8000 y #x7FFF))
- (multiple-value-bind (halt width)
- (font-draw-glyphs
- (text-style-to-X-font (port medium) (medium-text-style medium))
- mirror gc x y string
- :start start :end end
- :translate #'translate)))))))
+ (:bottom (+ y baseline (- text-height))))))
+
+ (let ((x (round-coordinate x))
+ (y (round-coordinate y)))
+ (when (and (<= #x-8000 x #x7FFF)
+ (<= #x-8000 y #x7FFF))
+ (font-draw-glyphs
+ (text-style-to-X-font (port medium) (medium-text-style medium))
+ mirror gc x y string
+ #| x (- y baseline) (+ x text-width) (+ y (- text-height baseline )) |#
+ :start start :end end
+ :translate #'translate)))))))
(defmethod (setf medium-text-style) :before (text-style (medium clx-medium))
@@ -679,5 +732,9 @@
(clim:region-intersection r (clim:sheet-region s)))))
(unless (eql r clim:+nowhere+)
(clim:with-drawing-options (m :clipping-region r)
- (clim:draw-design m r :ink clim:+background-ink+)
- (call-next-method s r)))))
+ ; This causes the logic cube to flicker. Is it critical?
+ ;(clim:draw-design m r :ink clim:+background-ink+)
+ (call-next-method s r)
+ ;; FIXME: Shouldn't McCLIM always do this?
+ (medium-force-output (sheet-medium s))))))
+
More information about the Mcclim-cvs
mailing list