cache code that looks up the documentation for an identifier

related to #633
racket · Aug 14, 2023 · 2657eaf · 2657eaf
1 parent e9e5656
commit 2657eaf
Show file tree

Hide file tree

Showing 2 changed files with 38 additions and 22 deletions.
diff --git a/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt b/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt
@@ -860,7 +860,8 @@
                             #:to-start to-start #:to-width to-span
                             #:to-dx to-dx #:to-dy to-dy)))))
 
-  (annotate-counts connections))
+  (annotate-counts connections)
+  (flush-index-entry-cache))
 
 ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t]
 ;;             -> void

diff --git a/drracket-tool-text-lib/drracket/private/syncheck/xref.rkt b/drracket-tool-text-lib/drracket/private/syncheck/xref.rkt
@@ -1,7 +1,9 @@
 #lang racket/base
 (require setup/xref 
-         scribble/xref)
-(provide get-index-entry-info)
+         scribble/xref
+         racket/match)
+(provide get-index-entry-info
+         flush-index-entry-cache)
 
 (define xref (load-collections-xref))
 
@@ -10,28 +12,36 @@
 (define thd
   (thread
    (λ ()
+     (define cache (make-hash))
+     (define (lookup-binding-info binding-info)
+       (let/ec escape
+         (define (fail) (escape #f))
+         (define definition-tag (xref-binding->definition-tag xref binding-info #f))
+         (unless definition-tag (fail))
+         (define-values (path tag) (xref-tag->path+anchor xref definition-tag))
+         (unless path (fail))
+         (define index-entry (xref-tag->index-entry xref definition-tag))
+         (and index-entry
+              (list (entry-desc index-entry)
+                    path
+                    definition-tag
+                    tag))))
+
      (let loop ()
-       (define-values (binding-info cd resp-chan nack-evt) (apply values (channel-get req-chan)))
-       (define resp
-         (parameterize ([current-directory cd])
-           (and xref
-                (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
-                  (and definition-tag
-                       (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
-                         (and path
-                              (let ([index-entry (xref-tag->index-entry xref definition-tag)])
-                                (and index-entry
-                                     (list (entry-desc index-entry)
-                                           path
-                                           definition-tag
-                                           tag))))))))))
-       (thread
-        (λ ()
-          (sync (channel-put-evt resp-chan resp)
-                nack-evt)))
+       (match (channel-get req-chan)
+         [(list binding-info cd resp-chan nack-evt)
+          (define resp
+            (parameterize ([current-directory cd])
+              (and xref
+                   (hash-ref! cache binding-info (λ () (lookup-binding-info binding-info))))))
+          (thread
+           (λ ()
+             (sync (channel-put-evt resp-chan resp)
+                   nack-evt)))]
+         [#f (set! cache (make-hash))])
        (loop)))))
 
-;; this function is called from a thread that might be killed
+;; these functions are called from a thread that might be killed
 ;; (but the body of this module is run in a context where it is
 ;; guaranteed that that custodian doesn't get shut down)
 (define (get-index-entry-info binding-info)
@@ -42,3 +52,8 @@
            (define resp-chan (make-channel))
            (channel-put req-chan (list binding-info (current-directory) resp-chan nack-evt))
            resp-chan)))))
+
+(define (flush-index-entry-cache)
+  (unless (thread-dead? thd)
+    (thread (λ () (channel-put-evt req-chan #f)))
+    (void)))