mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

no keyword arguments in GHIL / GLIL, just optional args -- faster compiles

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-02-13 00:01:47 +01:00
parent df8cd091f9
commit d9d671f76e
7 changed files with 52 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/ghil.scm
View file

@ -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)))))

18
module/language/ghil/compile-glil.scm
View file

@ -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)

6
module/language/scheme/compile-ghil.scm
View file

@ -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)

2
module/system/base/language.scm
View file

@ -34,7 +34,7 @@
;;; Language class
;;;
(define-record <language>
(define-record/keywords <language>
name
title
version

36
module/system/base/syntax.scm
View file

@ -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))
;;;
@ -48,6 +49,39 @@
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define-macro (define-record 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) '())))
,(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))

2
module/system/repl/common.scm
View file

@ -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)

2
module/system/vm/debug.scm
View file

@ -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)))