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

Adds an indicator that shows when framework prefs are being written.

Browse Source 
Performance grinds to a halt when the preference file is too large or
written too often. Hopefully the indicator will help us identify this
phenonmenon.
This commit is contained in:
Casey Klein 2010-12-02 15:56:08 -06:00
parent 5bb45d787f
commit fbd7bdff54
2 changed files with 127 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/framework/preferences.rkt
View File

@ -132,31 +132,58 @@ the state transitions / contracts are:
;; set : symbol any -> void
;; updates the preference
;; exported
(define (multi-set ps values)
(for-each
(λ (p value)
(cond
[(pref-default-set? p)
(let ([default (hash-ref defaults p)])
(unless ((default-checker default) value)
(error 'preferences:set
"tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'"
p value))
(check-callbacks p value)
(hash-set! preferences p value))]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:set "tried to set the preference ~e to ~e, but no default is set"
p
value)]))
ps values)
((preferences:low-level-put-preferences)
(map add-pref-prefix ps)
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(dynamic-wind
(λ ()
(call-pref-save-callbacks #t))
(λ ()
(for-each
(λ (p value)
(cond
[(pref-default-set? p)
(let ([default (hash-ref defaults p)])
(unless ((default-checker default) value)
(error 'preferences:set
"tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'"
p value))
(check-callbacks p value)
(hash-set! preferences p value))]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:set "tried to set the preference ~e to ~e, but no default is set"
p
value)]))
ps values)
((preferences:low-level-put-preferences)
(map add-pref-prefix ps)
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(λ ()
(call-pref-save-callbacks #f))))
(define pref-save-callbacks '())
(define (preferences:register-save-callback f)
(define key (gensym))
(set! pref-save-callbacks (cons (list key f) pref-save-callbacks))
key)
(define (preferences:unregister-save-callback k)
(set! pref-save-callbacks
(let loop ([callbacks pref-save-callbacks])
(cond
[(null? callbacks) '()]
[else
(let ([cb (car callbacks)])
(if (eq? (list-ref cb 0) k)
(cdr callbacks)
(cons cb (loop (cdr callbacks)))))]))))
(define (call-pref-save-callbacks b)
(for ([cb (in-list pref-save-callbacks)])
((list-ref cb 1) b)))
(define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference
@ -437,6 +464,24 @@ the state transitions / contracts are:
@{@scheme[(preferences:restore-defaults)] restores the users' configuration
to the default preferences.})
(proc-doc/names
preferences:register-save-callback
(-> (-> boolean? any) symbol?)
(callback)
@{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once
before the preferences file is written, with @racket[#t], and once after it is written, with
@racket[#f}. Registration returns a key for use with @racket{preferences:unregister-save-callback}.
Caveats:
@itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].}
@item{Pre- and post-write notifications are not necessarily paired; unregistration
may cancel the post-write notification before it occurs.}}})
(proc-doc/names
preferences:unregister-save-callback
(-> symbol? void?)
(key)
@{Unregisters the save callback associated with @racket{key}.})
(proc-doc/names
exn:make-unknown-preference
(string? continuation-mark-set? . -> . exn:unknown-preference?)

61
collects/framework/private/frame.rkt
View File

@ -560,6 +560,7 @@
(λ (l)
(if (memq outer-info-panel l)
(begin (unregister-collecting-blit gc-canvas)
(unregister-pref-save-callback)
(list rest-panel))
l)))]
[else
@ -569,6 +570,7 @@
l
(begin
(register-gc-blit)
(register-pref-save-callback)
(list rest-panel outer-info-panel)))))]))
[define close-panel-callback
@ -580,6 +582,7 @@
(define/augment (on-close)
(unregister-collecting-blit gc-canvas)
(unregister-pref-save-callback)
(close-panel-callback)
(memory-cleanup)
(inner (void) on-close))
@ -637,6 +640,12 @@
[(<= n 99) (format "0~a" n)]
[else (number->string n)]))
(define pref-save-canvas #f)
(when checkout-or-nightly?
(set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)])))
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
; only for checkouts and nightly build users
(when show-memory-text?
(let* ([panel (new horizontal-panel%
@ -657,7 +666,6 @@
(set! memory-canvases (remq ec memory-canvases))))
(send panel stretchable-width #f)))
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
[define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))]
(define/private (register-gc-blit)
(let ([onb (icon:get-gc-on-bitmap)]
@ -670,6 +678,25 @@
(send onb get-height)
onb offb))))
(define pref-save-callback-registration #f)
(inherit get-eventspace)
(define/private (register-pref-save-callback)
(when pref-save-canvas
(set! pref-save-callback-registration
(preferences:register-save-callback
(λ (start?)
(cond
[(eq? (current-thread) (eventspace-handler-thread (get-eventspace)))
(send pref-save-canvas set-on? start?)]
[else
(queue-callback
(λ ()
(send pref-save-canvas set-on? start?)))]))))))
(define/private (unregister-pref-save-callback)
(when pref-save-callback-registration
(preferences:unregister-save-callback pref-save-callback-registration)))
(register-pref-save-callback)
(unless (preferences:get 'framework:show-status-line)
(send super-root change-children
(λ (l)
@ -2415,14 +2442,16 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new)))
(define memory-canvases '())
(define show-memory-text?
(define checkout-or-nightly?
(or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(directory-exists? (collection-path "repo-time-stamp")))
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(let ([fw (collection-path "framework")])
(directory-exists? (build-path fw 'up 'up ".git"))))))
(define memory-canvases '())
(define show-memory-text? checkout-or-nightly?)
(define bday-click-canvas%
(class canvas%
(define/override (on-event evt)
@ -2434,6 +2463,32 @@
[else (super on-event evt)]))
(super-new)))
(define pref-save-canvas%
(class canvas%
(define on? #f)
(define indicator "P")
(define/override (on-paint)
(cond
[on?
(let-values ([(cw ch) (get-client-size)])
(send (get-dc) draw-text indicator
(- (/ cw 2) (/ indicator-width 2))
(- (/ ch 2) (/ indicator-height 2))))]))
(define/public (set-on? new-on?)
(set! on? new-on?)
(send (get-dc) erase)
(on-paint)
(flush))
(inherit get-dc flush get-client-size min-width)
(super-new [stretchable-width #f]
[style '(transparent)])
(define-values (indicator-width indicator-height)
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)])
(values tw th)))
(min-width (+ (inexact->exact (ceiling indicator-width)) 4))))
(define basic% (register-group-mixin (basic-mixin frame%)))
(define size-pref% (size-pref-mixin basic%))
(define info% (info-mixin basic%))