summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
authorDan Leslie <dan@ironoxide.ca>2017-12-10 08:45:16 -0800
committerDan Leslie <dan@ironoxide.ca>2017-12-10 08:45:16 -0800
commit473ef183d6c2c205699b7a865a206f579e60ce17 (patch)
tree65999f53856de6cf783e360640f3bff7618880b5 /scheme
parent49b78de1b0819d82187f0d1ded65e7c678540aed (diff)
downloadgeiser-guile-473ef183d6c2c205699b7a865a206f579e60ce17.tar.gz
geiser-guile-473ef183d6c2c205699b7a865a206f579e60ce17.tar.bz2
Remove memoization
It now _slows_ performance rather than improves it. Removing it speeds up the issue described in jaor/geiser#174
Diffstat (limited to 'scheme')
-rw-r--r--scheme/chicken/geiser/emacs.scm210
1 files changed, 91 insertions, 119 deletions
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
index b6af65e..908f768 100644
--- a/scheme/chicken/geiser/emacs.scm
+++ b/scheme/chicken/geiser/emacs.scm
@@ -221,34 +221,14 @@
(define module-name ##sys#module-name)
(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)
- (memoize/tbl (memo) tag thunk))
-
(define empty-symbol (string->symbol ""))
(define (symbol-information-list partial-string)
- (memoize
- `(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)))))
+ (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)
@@ -395,77 +375,71 @@
(else (eval* (->string str)))))
(define (fmt node)
- (memoize
- `(fmt ,node)
- (lambda ()
- (let* ((mod (cadr node))
- (sym (car node))
- (rest (cddr node))
- (type (if (or (list? rest) (pair? rest)) (car rest) rest))
- (mod-list (make-module-list sym mod)))
- (cond
- ((equal? 'macro type)
- `(,sym ("args" (("required" <macro>)
- ("optional" ...)
- ("key")))
- ("module" ,@mod-list)))
- ((or (equal? 'variable type)
- (equal? 'constant type))
- (if (not mod)
- `(,sym ("value" . ,(eval* sym)))
- (let* ((original-module (current-module))
- (desired-module (find-module mod))
- (value (begin (switch-module desired-module)
- (eval* sym))))
- (switch-module original-module)
- `(,sym ("value" . ,value)
- ("module" ,@mod-list)))))
- (else
- (let ((reqs '())
- (opts '())
- (keys '())
- (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
-
- (define (clean-arg arg)
- (let ((s (->string arg)))
- (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))
- (cond
- ((or (pair? args) (list? args))
- (cond
- ((eq? '#!key (car args))
- (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
- ((eq? '#!optional (car args))
- (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
- (else
- (begin
- (cond
- (reqs?
- (set! reqs (append reqs (list (clean-arg (car args))))))
- (opts?
- (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
- (keys?
- (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
- (collect-args (cdr args))))))
- (else
- (set! opts (list (clean-arg args) '...))))))
-
- (collect-args args)
-
- `(,sym ("args" (("required" ,@reqs)
- ("optional" ,@opts)
- ("key" ,@keys)))
- ("module" ,@mod-list)))))))))
+ (let* ((mod (cadr node))
+ (sym (car node))
+ (rest (cddr node))
+ (type (if (or (list? rest) (pair? rest)) (car rest) rest))
+ (mod-list (make-module-list sym mod)))
+ (cond
+ ((equal? 'macro type)
+ `(,sym ("args" (("required" <macro>)
+ ("optional" ...)
+ ("key")))
+ ("module" ,@mod-list)))
+ ((or (equal? 'variable type)
+ (equal? 'constant type))
+ (if (not mod)
+ `(,sym ("value" . ,(eval* sym)))
+ (let* ((original-module (current-module))
+ (desired-module (find-module mod))
+ (value (begin (switch-module desired-module)
+ (eval* sym))))
+ (switch-module original-module)
+ `(,sym ("value" . ,value)
+ ("module" ,@mod-list)))))
+ (else
+ (let ((reqs '())
+ (opts '())
+ (keys '())
+ (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+ (define (clean-arg arg)
+ (let ((s (->string arg)))
+ (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))
+ (cond
+ ((or (pair? args) (list? args))
+ (cond
+ ((eq? '#!key (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
+ ((eq? '#!optional (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
+ (else
+ (begin
+ (cond
+ (reqs?
+ (set! reqs (append reqs (list (clean-arg (car args))))))
+ (opts?
+ (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
+ (keys?
+ (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
+ (collect-args (cdr args))))))
+ (else
+ (set! opts (list (clean-arg args) '...))))))
+
+ (collect-args args)
+
+ `(,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 (symbol-information-list sym)))
- (map fmt 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))
@@ -488,29 +462,29 @@
;; Basically all non-core functions pass through geiser-eval
- (define (geiser-eval module form . rest)
- (define (form-has-safe-geiser? form)
- (any (cut eq? (car form) <>)
- '(geiser-no-values geiser-newline geiser-completions
- geiser-autodoc geiser-object-signature geiser-symbol-location
- geiser-symbol-documentation geiser-module-exports
- geiser-module-path geiser-module-location
- geiser-module-completions geiser-chicken-use-debug-log)))
-
- (define (form-has-any-geiser? form)
- (string-has-prefix? (->string (car form)) "geiser-"))
-
- (define (form-defines-any-module? form)
- (or
- ;; Geiser seems to send buffers as (begin ..buffer contents..)
- (and (eq? (car form) 'begin)
- (form-defines-any-module? (cadr form)))
- (any (cut eq? (car form) <>)
- '(module define-library))))
-
- (define (module-matches-defined-module? module)
- (any (cut eq? module <>) (list-modules)))
+ (define (form-has-safe-geiser? form)
+ (any (cut eq? (car form) <>)
+ '(geiser-no-values geiser-newline geiser-completions
+ geiser-autodoc geiser-object-signature geiser-symbol-location
+ geiser-symbol-documentation geiser-module-exports
+ geiser-module-path geiser-module-location
+ geiser-module-completions geiser-chicken-use-debug-log)))
+ (define (form-has-any-geiser? form)
+ (string-has-prefix? (->string (car form)) "geiser-"))
+
+ (define (form-defines-any-module? form)
+ (or
+ ;; Geiser seems to send buffers as (begin ..buffer contents..)
+ (and (eq? (car form) 'begin)
+ (form-defines-any-module? (cadr form)))
+ (any (cut eq? (car form) <>)
+ '(module define-library))))
+
+ (define (module-matches-defined-module? module)
+ (any (cut eq? module <>) (list-modules)))
+
+ (define (geiser-eval module form . rest)
(when (and module (not (symbol? module)))
(error "Module should be a symbol"))
@@ -527,10 +501,8 @@
(write-to-log form)
(if is-safe-geiser?
- (call-with-result #f (lambda () (memoize form thunk)))
- (begin
- (clear-memo)
- (call-with-result host-module thunk)))))
+ (call-with-result #f thunk)
+ (call-with-result host-module thunk))))
;; Load a file