summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-13 00:01:47 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-13 00:01:47 +0100
commitd9d671f76e0a77dfc643e487fa8d7db6be139366 (patch)
treee2528ed3331678c61aaa4ad1893eb539b2dace26
parentdf8cd091f9ffd31a7f77337d2e804d6801ca61ee (diff)
downloadguile-d9d671f76e0a77dfc643e487fa8d7db6be139366.tar.gz
no keyword arguments in GHIL / GLIL, just optional args -- faster compiles
* module/system/base/syntax.scm (define-record): So, in the generated constructors, allow optional arguments, but not keyword arguments. Conses much less in the constructors. (define-record/keywords): And the old define-record is here. * module/language/ghil.scm (parse-ghil): * module/language/ghil/compile-glil.scm (codegen): * module/language/scheme/compile-ghil.scm (translate-1, quote) (quasiquote): Don't use keywords in this compiler hotpath. * module/system/base/language.scm (<language>): * module/system/repl/common.scm (<repl>): * module/system/vm/debug.scm (<debugger>): Use define-record/keywords.
-rw-r--r--module/language/ghil.scm4
-rw-r--r--module/language/ghil/compile-glil.scm18
-rw-r--r--module/language/scheme/compile-ghil.scm6
-rw-r--r--module/system/base/language.scm2
-rw-r--r--module/system/base/syntax.scm36
-rw-r--r--module/system/repl/common.scm2
-rw-r--r--module/system/vm/debug.scm2
7 files changed, 52 insertions, 18 deletions
diff --git a/module/language/ghil.scm b/module/language/ghil.scm
index 2e373942e..505e0075c 100644
--- a/module/language/ghil.scm
+++ b/module/language/ghil.scm
@@ -352,7 +352,7 @@
((ref ,sym) (guard (symbol? sym))
(make-ghil-ref env #f (ghil-var-for-ref! env sym)))
- (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
+ (('quote ,exp) (make-ghil-quote env loc exp))
((void) (make-ghil-void env loc))
@@ -417,7 +417,7 @@
(make-ghil-reified-env env loc))
((quasiquote ,exp)
- (make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
+ (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
(else
(error "unrecognized GHIL" exp)))))
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index 4230549ba..de8d27c07 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -178,7 +178,7 @@
(return-code! #f *ia-void*))
;; return object if necessary
(define (return-object! loc obj)
- (return-code! loc (make-glil-const #:obj obj)))
+ (return-code! loc (make-glil-const obj)))
;;
;; dispatch
(record-case tree
@@ -210,7 +210,7 @@
(comp-push exp)
(push-call! #f 'list-break '()))))
((constant? x)
- (push-code! #f (make-glil-const #:obj x)))
+ (push-code! #f (make-glil-const x)))
(else
(error "element of quasiquote can't be compiled" x))))
(maybe-drop)
@@ -330,7 +330,7 @@
(let ((MV (make-label)))
(comp-push producer)
(push-code! loc (make-glil-mv-call 0 MV))
- (push-code! #f (make-glil-const #:obj 1))
+ (push-code! #f (make-glil-const 1))
(push-label! MV)
(push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
@@ -361,9 +361,9 @@
(drop ;; (lambda () (values 1 2) 3)
(for-each comp-drop values))
(else ;; (lambda () (list (values 10 12) 1))
- (push-code! #f (make-glil-const #:obj 'values))
- (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
- (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+ (push-code! #f (make-glil-const 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 0))
(push-call! loc 'call values))))
((<ghil-values*> env loc values)
@@ -372,9 +372,9 @@
(drop ;; (lambda () (apply values '(1 2)) 3)
(for-each comp-drop values))
(else ;; (lambda () (list (apply values '(10 12)) 1))
- (push-code! #f (make-glil-const #:obj 'values))
- (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
- (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+ (push-code! #f (make-glil-const 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 0))
(push-call! loc 'apply values))))
((<ghil-call> env loc proc args)
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 3693b3867..f27ae7a43 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -150,7 +150,7 @@
;; fixme: non-self-quoting objects like #<foo>
(else
- (make-ghil-quote e l #:obj x)))))
+ (make-ghil-quote e l x)))))
(define (valid-bindings? bindings . it-is-for-do)
(define (valid-binding? b)
@@ -179,11 +179,11 @@
(define-scheme-translator quote
;; (quote OBJ)
- ((,obj) (make-ghil-quote e l #:obj obj)))
+ ((,obj) (make-ghil-quote e l obj)))
(define-scheme-translator quasiquote
;; (quasiquote OBJ)
- ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0))))
+ ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
(define-scheme-translator define
;; (define NAME VAL)
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 2dac2091b..70000c551 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -34,7 +34,7 @@
;;; Language class
;;;
-(define-record <language>
+(define-record/keywords <language>
name
title
version
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index e4d3efeff..67bcdb61b 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -21,7 +21,8 @@
(define-module (system base syntax)
#:export (%compute-initargs)
- #:export-syntax (define-type define-record record-case))
+ #:export-syntax (define-type define-record define-record/keywords
+ record-case))
;;;
@@ -56,6 +57,39 @@
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
,@(if printer (list printer) '())))
+ ,(let* ((reqs (let lp ((slots slots))
+ (if (or (null? slots) (not (symbol? (car slots))))
+ '()
+ (cons (car slots) (lp (cdr slots))))))
+ (opts (list-tail slots (length reqs)))
+ (tail (gensym)))
+ `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
+ (let ,(map (lambda (o)
+ `(,(car o) (cond ((null? ,tail) ,(cadr o))
+ (else (let ((_x (car ,tail)))
+ (set! ,tail (cdr ,tail))
+ _x)))))
+ opts)
+ (make-struct ,name 0 ,@slot-names))))
+ (define ,(symbol-append stem '?) (record-predicate ,name))
+ ,@(map (lambda (sname)
+ `(define ,(symbol-append stem '- sname)
+ (make-procedure-with-setter
+ (record-accessor ,name ',sname)
+ (record-modifier ,name ',sname))))
+ slot-names))))
+
+;; like the former, but accepting keyword arguments in addition to
+;; optional arguments
+(define-macro (define-record/keywords name-form . slots)
+ (let* ((name (if (pair? name-form) (car name-form) name-form))
+ (printer (and (pair? name-form) (cadr name-form)))
+ (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+ slots))
+ (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+ `(begin
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names
+ ,@(if printer (list printer) '())))
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 03c63bd74..bc3242375 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -35,7 +35,7 @@
;;; Repl type
;;;
-(define-record <repl> vm language options tm-stats gc-stats vm-stats)
+(define-record/keywords <repl> vm language options tm-stats gc-stats vm-stats)
(define repl-default-options
'((trace . #f)
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 03eb2ecaa..3c5cfa201 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -31,7 +31,7 @@
;;; Debugger
;;;
-(define-record <debugger> vm chain index)
+(define-record/keywords <debugger> vm chain index)
(define (vm-debugger vm)
(let ((chain (vm-last-frame-chain vm)))