diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-13 00:01:47 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-13 00:01:47 +0100 |
commit | d9d671f76e0a77dfc643e487fa8d7db6be139366 (patch) | |
tree | e2528ed3331678c61aaa4ad1893eb539b2dace26 | |
parent | df8cd091f9ffd31a7f77337d2e804d6801ca61ee (diff) | |
download | guile-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.scm | 4 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 18 | ||||
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 6 | ||||
-rw-r--r-- | module/system/base/language.scm | 2 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 36 | ||||
-rw-r--r-- | module/system/repl/common.scm | 2 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 2 |
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))) |