From fbd7bdff5454465e2df0f99defdb64a304c1a135 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 15:56:08 -0600 Subject: [PATCH] Adds an indicator that shows when framework prefs are being written. 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. --- collects/framework/preferences.rkt | 93 +++++++++++++++++++++------- collects/framework/private/frame.rkt | 61 +++++++++++++++++- 2 files changed, 127 insertions(+), 27 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 9c74cff455..ad4a248277 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -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?) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 0e9fa3d2d9..c42b2d8954 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -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%))