summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDan Leslie <dan@ironoxide.ca>2017-12-09 23:01:24 -0800
committerDan Leslie <dan@ironoxide.ca>2017-12-09 23:01:24 -0800
commit3fa575feefb14bf472d69f5c2041d4ab51c3dae9 (patch)
treeccc07285f98e8176187d605f47c16c9fbe4355bd
parent17fde7db7b03d61c7bf1f125669e2b3df8740db6 (diff)
downloadgeiser-guile-3fa575feefb14bf472d69f5c2041d4ab51c3dae9.tar.gz
geiser-guile-3fa575feefb14bf472d69f5c2041d4ab51c3dae9.tar.bz2
Improvements to Chicken completion speed
Removed all of the symbol-interning code, and in the process greatly reduced the amount of CPU time. Should resolve jaor/geiser#174
-rw-r--r--scheme/chicken/geiser/emacs.scm138
1 files changed, 59 insertions, 79 deletions
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
index d60cbb9..b6af65e 100644
--- a/scheme/chicken/geiser/emacs.scm
+++ b/scheme/chicken/geiser/emacs.scm
@@ -28,8 +28,7 @@
geiser-module-completions
geiser-macroexpand
geiser-chicken-use-debug-log
- geiser-chicken-load-paths
- geiser-chicken-symbol-match-limit)
+ geiser-chicken-load-paths)
(import chicken scheme)
(use
@@ -51,9 +50,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Symbol lists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (define geiser-chicken-symbol-match-limit
- (make-parameter 20))
(define geiser-r4rs-symbols
(make-parameter
@@ -226,47 +222,33 @@
(define (list-modules) (map car ##sys#module-table))
(define memo (make-parameter (make-hash-table)))
+ (define symbol-memo (make-parameter (make-hash-table)))
(define (clear-memo) (hash-table-clear! (memo)))
+ (define (memoize/tbl table tag thunk)
+ (if (hash-table-exists? table tag)
+ (begin
+ (write-to-log '[[Cache Hit]])
+ (hash-table-ref table tag))
+ (fluid-let ((memoize/tbl (lambda (table tag thunk) (thunk))))
+ (write-to-log '[[Cache Miss]])
+ (hash-table-set! table tag (thunk))
+
+ (hash-table-ref table tag))))
+
(define (memoize tag thunk)
- (let ((table (memo)))
- (if (hash-table-exists? table tag)
- (begin
- (write-to-log '[[Cache Hit]])
- (hash-table-ref table tag))
- (fluid-let ((memoize (lambda (tag thunk) (thunk))))
- (write-to-log '[[Cache Miss]])
- (hash-table-set! table tag (thunk))
-
- (hash-table-ref table tag)))))
-
- (define (symbol-information-list)
- (memoize
- '(symbol-information-list)
- (lambda ()
- (map (lambda (lst)
- (let* ((module (if (eq? (string->symbol "") (caar lst)) #f (symbol->string (caar lst))))
- (name (symbol->string (cdar lst))))
- (append (list name module) (cdr lst))))
- (apropos-information-list "" #:macros? #t)))))
+ (memoize/tbl (memo) tag thunk))
- (define (find-symbol-information prefix)
- (define (filter/limit pred? limit lst)
- (cond
- ((<= limit 0) '())
- ((or (null? lst) (not (list? lst))) '())
- ((pred? (car lst)) (cons (car lst) (filter/limit pred? (- limit 1) (cdr lst))))
- (else (filter/limit pred? limit (cdr lst)))))
- (define (find-symbol-information* prefix skipped)
- (let ((found (filter/limit
- (lambda (info)
- (string-has-prefix? (car info) prefix))
- (geiser-chicken-symbol-match-limit)
- (symbol-information-list))))
- (cons found skipped)))
+ (define empty-symbol (string->symbol ""))
+
+ (define (symbol-information-list partial-string)
(memoize
- `(find-symbol-information ,prefix)
- (lambda ()
- (find-symbol-information* (->string prefix) ""))))
+ `(symbol-information-list ,partial-string)
+ (lambda ()
+ (map (lambda (lst)
+ (let* ((module (if (eq? empty-symbol (caar lst)) #f (caar lst)))
+ (name (cdar lst)))
+ (append (list name module) (cdr lst))))
+ (apropos-information-list partial-string #:macros? #t)))))
(define debug-log (make-parameter #f))
(define (write-to-log form)
@@ -397,42 +379,47 @@
(any (cut eq? type <>) types)))
(match-nodes sym)))))
- (define (make-module-list sym module-sym prefix-exists)
+ (define (make-module-list sym module-sym)
(append
- (if prefix-exists '(fuzzy-match) '())
(if (not module-sym)
(find-standards-with-symbol sym)
(cons module-sym (find-standards-with-symbol sym)))))
+
+ (define (read* str)
+ (with-input-from-string str (lambda () (read))))
- (define (fmt node prefix)
+ (define (eval* str)
+ (cond
+ ((symbol? str) (eval str))
+ ((string? str) (eval (read* str)))
+ (else (eval* (->string str)))))
+
+ (define (fmt node)
(memoize
- `(fmt ,node ,prefix)
+ `(fmt ,node)
(lambda ()
- (let* ((original-entry (string->symbol (car node)))
- (fuzzy-entry (string->symbol (string-append prefix (car node))))
- (prefix-exists (not (= 0 (string-length prefix))))
- (module (cadr node))
- (module (if module (string->symbol module) #f))
+ (let* ((mod (cadr node))
+ (sym (car node))
(rest (cddr node))
(type (if (or (list? rest) (pair? rest)) (car rest) rest))
- (module-list (make-module-list fuzzy-entry module prefix-exists)))
+ (mod-list (make-module-list sym mod)))
(cond
((equal? 'macro type)
- `(,fuzzy-entry ("args" (("required" <macro>)
- ("optional" ...)
- ("key")))
- ("module" ,@module-list)))
+ `(,sym ("args" (("required" <macro>)
+ ("optional" ...)
+ ("key")))
+ ("module" ,@mod-list)))
((or (equal? 'variable type)
(equal? 'constant type))
- (if (not module)
- `(,fuzzy-entry ("value" . ,(eval original-entry)))
+ (if (not mod)
+ `(,sym ("value" . ,(eval* sym)))
(let* ((original-module (current-module))
- (desired-module (find-module module))
+ (desired-module (find-module mod))
(value (begin (switch-module desired-module)
- (eval original-entry))))
+ (eval* sym))))
(switch-module original-module)
- `(,fuzzy-entry ("value" . ,value)
- ("module" ,@module-list)))))
+ `(,sym ("value" . ,value)
+ ("module" ,@mod-list)))))
(else
(let ((reqs '())
(opts '())
@@ -441,7 +428,7 @@
(define (clean-arg arg)
(let ((s (->string arg)))
- (string->symbol (substring/shared s 0 (add1 (string-skip-right s char-set:digit))))))
+ (read* (substring/shared s 0 (add1 (string-skip-right s char-set:digit))))))
(define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
(when (not (null? args))
@@ -467,20 +454,18 @@
(collect-args args)
- `(,fuzzy-entry ("args" (("required" ,@reqs)
- ("optional" ,@opts)
- ("key" ,@keys)))
- ("module" ,@module-list)))))))))
+ `(,sym ("args" (("required" ,@reqs)
+ ("optional" ,@opts)
+ ("key" ,@keys)))
+ ("module" ,@mod-list)))))))))
;; Builds a signature list from an identifier
(define (find-signatures sym)
(memoize
`(find-signatures ,sym)
(lambda ()
- (let ((result (find-symbol-information sym)))
- (map
- (cut fmt <> (cdr result))
- (car result))))))
+ (let ((result (symbol-information-list sym)))
+ (map fmt result)))))
;; Builds the documentation from Chicken Doc for a specific symbol
(define (make-doc symbol #!optional (filter-for-type #f))
@@ -597,12 +582,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (geiser-completions prefix . rest)
- (let* ((result (find-symbol-information prefix))
- (prefix (cdr result))
- (result-list (car result)))
- (map
- (cut string-append prefix <>)
- (map car result-list))))
+ (let ((prefix (->string prefix)))
+ (filter (cut string-has-prefix? <> prefix)
+ (map ->string (map car (symbol-information-list prefix))))))
(define (geiser-module-completions prefix . rest)
(let ((prefix (->string prefix)))
@@ -613,8 +595,6 @@
((null? ids) '())
((not (list? ids))
(geiser-autodoc (list ids)))
- ((not (symbol? (car ids)))
- (geiser-autodoc (cdr ids)))
(else
(let ((details (find-signatures (car ids))))
(if (null? details)