summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-11 22:08:04 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-11 22:08:04 +0100
commite14679bd52ce8b6ea700845cc5c8139725bcec1a (patch)
tree21c896489fe8746b59dbd01048d7e656390f0da5 /module/system/base/syntax.scm
parent8899057d65da670da74c90ae44e3ce78ec695ddd (diff)
downloadguile-e14679bd52ce8b6ea700845cc5c8139725bcec1a.tar.gz
speed up record-case
* module/language/ghil.scm: Whoops, export some unquote-splicing accessors that we didn't have exported before. * module/system/base/syntax.scm: Speed up record-case, by syntactically determining the predicates and accessors. Nasty, in a way; but also much faster.
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r--module/system/base/syntax.scm43
1 files changed, 36 insertions, 7 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index b7b995034..e4d3efeff 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -102,6 +102,34 @@
(car in)
out)))))))
+;; So, dear reader. It is pleasant indeed around this fire or at this
+;; cafe or in this room, is it not? I think so too.
+;;
+;; This macro used to generate code that looked like this:
+;;
+;; `(((record-predicate ,record-type) ,r)
+;; (let ,(map (lambda (slot)
+;; (if (pair? slot)
+;; `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+;; `(,slot ((record-accessor ,record-type ',slot) ,r))))
+;; slots)
+;; ,@body)))))
+;;
+;; But this was a hot spot, so computing all those predicates and
+;; accessors all the time was getting expensive, so we did a terrible
+;; thing: we decided that since above we're already defining accessors
+;; and predicates with computed names, we might as well just rely on that fact here.
+;;
+;; It's a bit nasty, I agree. But it is fast.
+;;
+;;scheme@(guile-user)> (with-statprof #:hz 1000 #:full-stacks? #t (resolve-module '(oop goops)))% cumulative self
+;; time seconds seconds name
+;; 8.82 0.03 0.01 glil->assembly
+;; 8.82 0.01 0.01 record-type-fields
+;; 5.88 0.01 0.01 %compute-initargs
+;; 5.88 0.01 0.01 list-index
+
+
(define-macro (record-case record . clauses)
(let ((r (gensym)))
(define (process-clause clause)
@@ -110,13 +138,14 @@
(let ((record-type (caar clause))
(slots (cdar clause))
(body (cdr clause)))
- `(((record-predicate ,record-type) ,r)
- (let ,(map (lambda (slot)
- (if (pair? slot)
- `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
- `(,slot ((record-accessor ,record-type ',slot) ,r))))
- slots)
- ,@body)))))
+ (let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>)))))
+ `((,(symbol-append stem '?) ,r)
+ (let ,(map (lambda (slot)
+ (if (pair? slot)
+ `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
+ `(,slot (,(symbol-append stem '- slot) ,r))))
+ slots)
+ ,@body))))))
`(let ((,r ,record))
(cond ,@(let ((clauses (map process-clause clauses)))
(if (assq 'else clauses)