suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix text-drawing performance

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-09 07:26:53 -06:00
parent 909ee0f32d
commit 0e64be35b7
7 changed files with 68 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -223,15 +223,17 @@
(when pq (set-box! pq #f)))
(set! paint-queued #f)
(when (or (not b) (is-shown-to-root?))
(send dc reset-backing-retained) ; start with a clean slate
(send dc ensure-ready)
(send dc erase) ; start with a clean slate
(let ([bg (get-canvas-background)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(send dc suspend-flush)
(on-paint)
(send dc resume-flush)
(queue-backing-flush)))
(when req
(cancel-flush-delay req)))

10
collects/mred/private/wx/cocoa/window.rkt
View File

@ -449,7 +449,16 @@
;; Called in Cocoa event-handling mode
#f)
(define/private (pre-event-refresh key?)
;; Since we break the connection between the
;; Cocoa queue and event handling, we
;; re-sync the display in case a stream of
;; events (e.g., key repeat) have a corresponding
;; stream of screen updates.
(try-to-sync-refresh))
(define/public (dispatch-on-char/sync e)
(pre-event-refresh #t)
(dispatch-on-char e #f))
(define/public (dispatch-on-char e just-pre?)
(cond
@ -459,6 +468,7 @@
[else (when enabled? (on-char e)) #t]))
(define/public (dispatch-on-event/sync e)
(pre-event-refresh #f)
(dispatch-on-event e #f))
(define/public (dispatch-on-event e just-pre?)
(cond

5
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -32,7 +32,8 @@
(inherit call-with-cr-lock
internal-get-bitmap
internal-set-bitmap
reset-cr)
reset-cr
erase)
(super-new)
@ -68,7 +69,7 @@
(define/public (reset-backing-retained [proc void])
(let ([cr retained-cr])
(when cr
(when cr
(let ([bm (internal-get-bitmap)])
(set! retained-cr #f)
(internal-set-bitmap #f #t)

4
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -349,15 +349,17 @@
(lambda ()
(set! paint-queued? #f)
(set! now-drawing? #t)
(send dc reset-backing-retained) ; clean slate
(send dc ensure-ready)
(send dc erase) ; clean slate
(let ([bg (get-canvas-background)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(send dc suspend-flush)
(on-paint)
(send dc resume-flush)
(set! now-drawing? #f)
(when refresh-after-drawing?
(set! refresh-after-drawing? #f)

21
collects/racket/draw/dc.rkt
View File

@ -139,7 +139,11 @@
;;
;; Return #t if bitmap drawing with a mask is supported.
;; It's not supported for PostScirpt output, for example.
can-mask-bitmap?))
can-mask-bitmap?
;; erase : -> void
;; A public method: erases all drawing
erase))
(define default-dc-backend%
(class* object% (dc-backend<%>)
@ -198,6 +202,9 @@
(define/public (can-mask-bitmap?)
#t)
(define/public (erase)
(void))
(super-new)))
(define hilite-color (send the-color-database find-color "black"))
@ -571,6 +578,14 @@
(install-color cr bg 1.0)
(cairo_paint cr)))
(define/override (erase)
(with-cr
(void)
cr
(cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_set_operator cr CAIRO_OPERATOR_OVER)))
(define/private (make-pattern-surface cr col draw)
(let* ([s (cairo_surface_create_similar (cairo_get_target cr)
@ -963,7 +978,7 @@
(not (= 1.0 effective-scale-x))
(not (= 1.0 effective-scale-y)))
(values #f #f #f #f)
(let ([id (send font get-font-id)]
(let ([id (send font get-font-key)]
[sz (send font get-point-size)])
(let loop ([i offset] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
(if (= i (string-length s))
@ -1075,7 +1090,7 @@
(not (= 1.0 effective-scale-x))
(not (= 1.0 effective-scale-y)))
void
(let ([id (send font get-font-id)]
(let ([id (send font get-font-key)]
[sz (send font get-point-size)])
(lambda (ch w h d a)
(atomically

36
collects/racket/draw/font.rkt
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require scheme/class
ffi/unsafe/atomic
"syntax.ss"
"pango.ss"
"font-syms.ss"
@ -26,12 +27,19 @@
(define (size? v) (and (exact-positive-integer? v)
(byte? v)))
(define-local-member-name s-set-key)
(define-local-member-name s-set-table-key)
(define font-descs (make-weak-hash))
(define ps-font-descs (make-weak-hash))
(define keys (make-weak-hash))
(define-syntax-rule (atomically e)
(begin (start-atomic) (begin0 e (end-atomic))))
(defclass font% object%
(define key #f)
(define/public (s-set-key k) (set! key k))
(define table-key #f)
(define/public (s-set-table-key k) (set! table-key k))
(define cached-desc #f)
(define ps-cached-desc #f)
@ -39,15 +47,21 @@
(define/public (get-pango)
(create-desc #f
cached-desc
font-descs
(lambda (d) (set! cached-desc d))))
(define/public (get-ps-pango)
(create-desc #t
ps-cached-desc
ps-font-descs
(lambda (d) (set! ps-cached-desc d))))
(define/private (create-desc ps? cached-desc install!)
(define/private (create-desc ps? cached-desc font-descs install!)
(or cached-desc
(let ([desc (atomically (hash-ref font-descs key #f))])
(and desc
(install! desc)
desc))
(let* ([desc (pango_font_description_new)])
(pango_font_description_set_family desc
(if ps?
@ -73,6 +87,7 @@
(pango_font_description_set_absolute_size desc (* size PANGO_SCALE))
(pango_font_description_set_size desc (inexact->exact (floor (* size PANGO_SCALE)))))
(install! desc)
(atomically (hash-set! font-descs key desc))
desc)))
(define/public (get-pango-attrs)
@ -105,6 +120,7 @@
(def/public (get-weight) weight)
(def/public (get-font-id) id)
(def/public (get-font-key) key)
(def/public (screen-glyph-exists? [char? c]
[any? [for-label? #f]])
@ -151,7 +167,15 @@
(define id
(if face
(send the-font-name-directory find-or-create-font-id face family)
(send the-font-name-directory find-family-default-font-id family))))
(send the-font-name-directory find-family-default-font-id family)))
(define key
(let ([key (vector id size style weight underlined? smoothing size-in-pixels?)])
(let ([old-key (atomically (hash-ref keys key #f))])
(if old-key
(weak-box-value old-key)
(begin
(atomically (hash-set! keys key (make-weak-box key)))
key))))))
;; ----------------------------------------
@ -186,7 +210,7 @@
(ephemeron-value e))
(let* ([f (apply make-object font% (vector->list key))]
[e (make-ephemeron key f)])
(send f s-set-key key)
(send f s-set-table-key key)
(hash-set! fonts key e)
f))))))

1
collects/racket/draw/local.rkt
View File

@ -29,6 +29,7 @@
;; font%
get-ps-pango
get-font-key
;; dc-backend<%>
call-with-cr-lock