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

improve check syntax so opening the context-sensitive menu is faster

Browse Source 
in certain situations

Specifically, don't compute the identifiers-hash before opening the
menu but, when it does need to be computed, avoid consider the same
arrows over and over. This makes an especially big difference when a
region of text is selected that contains lots of arrow heads that all
point to a place that has lots of arrows.

Specifically, the time to compute the identifers hash for the example in
the PR is now about 200x faster (altho this still takes 200 msec, which
is why it isn't computed at all in that sequence of steps any more).

closes PR 14586
This commit is contained in:
Robby Findler 2014-06-19 19:55:45 -05:00
parent 4aa438937a
commit 0c5239fb51
1 changed files with 48 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt
View File

@ -690,14 +690,14 @@ If the namespace does not, they are colored the unbound color.
(define/public (syncheck:rename-identifier text) (define/public (syncheck:rename-identifier text)
(define canvas (send text get-canvas)) (define canvas (send text get-canvas))
(define-values (binding-identifiers identifiers-hash) (define-values (binding-identifiers make-identifiers-hash)
(position->matching-identifiers-hash text (position->matching-identifiers-hash text
(send text get-start-position) (send text get-start-position)
(send text get-end-position) (send text get-end-position)
#t)) #t))
(unless (null? binding-identifiers) (unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers)) (define name-to-offer (find-name-to-offer binding-identifiers))
(rename-menu-callback identifiers-hash (rename-menu-callback make-identifiers-hash
name-to-offer name-to-offer
binding-identifiers binding-identifiers
(and canvas (send canvas get-top-level-window))))) (and canvas (send canvas get-top-level-window)))))
@ -718,11 +718,8 @@ If the namespace does not, they are colored the unbound color.
(when arrows (when arrows
(tack/untack-callback arrows)))) (tack/untack-callback arrows))))
;; rename-callback : (non-empty-listof identifier?)
;; (union #f (is-a?/c top-level-window<%>))
;; -> void
;; callback for the rename popup menu item ;; callback for the rename popup menu item
(define/private (rename-menu-callback identifiers-hash name-to-offer (define/private (rename-menu-callback make-identifiers-hash name-to-offer
binding-identifiers parent) binding-identifiers parent)
(define (name-dup? x) (define (name-dup? x)
(for/or ([var-arrow (in-list binding-identifiers)]) (for/or ([var-arrow (in-list binding-identifiers)])
@ -760,7 +757,7 @@ If the namespace does not, they are colored the unbound color.
(when do-renaming? (when do-renaming?
(define edit-sequence-txts (list this)) (define edit-sequence-txts (list this))
(define per-txt-positions (make-hash)) (define per-txt-positions (make-hash))
(for ([(k _) (in-hash identifiers-hash)]) (for ([(k _) (in-hash (make-identifiers-hash))])
(define-values (txt start-pos end-pos) (apply values k)) (define-values (txt start-pos end-pos) (apply values k))
(hash-set! per-txt-positions txt (hash-set! per-txt-positions txt
(cons (cons start-pos end-pos) (cons (cons start-pos end-pos)
@ -1270,7 +1267,7 @@ If the namespace does not, they are colored the unbound color.
(for ([f (in-list add-menus)]) (for ([f (in-list add-menus)])
(f menu)) (f menu))
(define-values (binding-identifiers identifiers-hash) (define-values (binding-identifiers make-identifiers-hash)
(position->matching-identifiers-hash text pos (+ pos 1) #t)) (position->matching-identifiers-hash text pos (+ pos 1) #t))
(unless (null? binding-identifiers) (unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers)) (define name-to-offer (find-name-to-offer binding-identifiers))
@ -1281,7 +1278,7 @@ If the namespace does not, they are colored the unbound color.
[callback [callback
(λ (x y) (λ (x y)
(let ([frame-parent (find-menu-parent menu)]) (let ([frame-parent (find-menu-parent menu)])
(rename-menu-callback identifiers-hash (rename-menu-callback make-identifiers-hash
name-to-offer name-to-offer
binding-identifiers binding-identifiers
frame-parent)))])) frame-parent)))]))
@ -1329,12 +1326,14 @@ If the namespace does not, they are colored the unbound color.
(un/highlight #f) (un/highlight #f)
(set! current-matching-identifiers (set! current-matching-identifiers
(if (and cursor-text cursor-pos) (cond
(let-values ([(_binders hash) (position->matching-identifiers-hash [(and cursor-text cursor-pos)
cursor-text cursor-pos cursor-pos (define-values (_binders make-identifiers-hash)
#f)]) (position->matching-identifiers-hash cursor-text cursor-pos cursor-pos
hash) #f))
(make-hash))) (make-identifiers-hash)]
[else
(make-hash)]))
(un/highlight #t) (un/highlight #t)
@ -1376,31 +1375,41 @@ If the namespace does not, they are colored the unbound color.
(var-arrow-start-pos-right candidate-binder))) (var-arrow-start-pos-right candidate-binder)))
(add-binding-arrow candidate-binder))))]))))) (add-binding-arrow candidate-binder))))])))))
(define identifiers-hash (make-hash)) (define identifiers-hash #f)
(define (add-one txt start end) (define (add-one txt start end)
(hash-set! identifiers-hash (list txt start end) #t)) (hash-set! identifiers-hash (list txt start end) #t))
(for ([binding-arrow (in-list binding-arrows)]) (define (get-identifiers-hash)
(add-one (var-arrow-start-text binding-arrow) (unless identifiers-hash
(var-arrow-start-pos-left binding-arrow) (set! identifiers-hash (make-hash))
(var-arrow-start-pos-right binding-arrow)) (define already-considered (make-hash))
(for ([pos (in-range (var-arrow-start-pos-left binding-arrow) (for ([binding-arrow (in-list binding-arrows)])
(var-arrow-start-pos-right binding-arrow))]) (add-one (var-arrow-start-text binding-arrow)
(for ([arrow (in-list (fetch-arrow-records (var-arrow-start-text binding-arrow) (var-arrow-start-pos-left binding-arrow)
pos))]) (var-arrow-start-pos-right binding-arrow))
(when (var-arrow? arrow) (define range-to-consider
(when (or include-require-arrows? (cons (var-arrow-start-pos-left binding-arrow)
(not (var-arrow-require-arrow? arrow))) (var-arrow-start-pos-right binding-arrow)))
(when (and (equal? (var-arrow-start-text arrow) (unless (hash-ref already-considered range-to-consider #f)
(var-arrow-start-text binding-arrow)) (hash-set! already-considered range-to-consider #t)
(equal? (var-arrow-start-pos-left arrow) (for ([pos (in-range (car range-to-consider) (cdr range-to-consider))])
(var-arrow-start-pos-left binding-arrow)) (for ([arrow (in-list (fetch-arrow-records
(equal? (var-arrow-start-pos-right arrow) (var-arrow-start-text binding-arrow)
(var-arrow-start-pos-right binding-arrow))) pos))])
(add-one (var-arrow-end-text arrow) (when (var-arrow? arrow)
(var-arrow-end-pos-left arrow) (when (or include-require-arrows?
(var-arrow-end-pos-right arrow)))))))) (not (var-arrow-require-arrow? arrow)))
(when (and (equal? (var-arrow-start-text arrow)
(var-arrow-start-text binding-arrow))
(equal? (var-arrow-start-pos-left arrow)
(var-arrow-start-pos-left binding-arrow))
(equal? (var-arrow-start-pos-right arrow)
(var-arrow-start-pos-right binding-arrow)))
(add-one (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow))))))))))
identifiers-hash)
(values binding-arrows identifiers-hash)) (values binding-arrows get-identifiers-hash))
;; Sometimes when this is called, the calls to 'tooltip-info->ltrb' ;; Sometimes when this is called, the calls to 'tooltip-info->ltrb'
;; fail and we get no information back. When that happens, we return ;; fail and we get no information back. When that happens, we return
@ -1580,10 +1589,10 @@ If the namespace does not, they are colored the unbound color.
;; jump-to-next-callback : num text boolean? -> void ;; jump-to-next-callback : num text boolean? -> void
;; callback for the jump popup menu item ;; callback for the jump popup menu item
(define/private (jump-to-next-callback start-pos end-pos txt backwards?) (define/private (jump-to-next-callback start-pos end-pos txt backwards?)
(define-values (_binders identifiers-hash) (define-values (_binders make-identifiers-hash)
(position->matching-identifiers-hash txt start-pos end-pos #t)) (position->matching-identifiers-hash txt start-pos end-pos #t))
(define orig-arrows (define orig-arrows
(sort (hash-map identifiers-hash (sort (hash-map (make-identifiers-hash)
(λ (x y) x)) (λ (x y) x))
(λ (x y) (if backwards? (λ (x y) (if backwards?
(not (syncheck:compare-bindings x y)) (not (syncheck:compare-bindings x y))