diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-14 00:24:32 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-14 00:24:32 +0100 |
commit | abd6af11cd1ab62c2f337dcd23a9d9c37b9d169e (patch) | |
tree | 0f3d56c1c703e96fd509fee652f75db6f237a0b5 | |
parent | e177058bc4599c68308e6d7fcfbd3f2a0e695f84 (diff) | |
download | guile-abd6af11cd1ab62c2f337dcd23a9d9c37b9d169e.tar.gz |
generate the fixed-offset accessors at compile-time
* module/language/scheme/compile-ghil.scm (define-scheme-translator):
Only add an else clause if the transformer didn't have one.
* module/oop/goops.scm (min-fixnum, max-fixnum): Define at compile-time
as well.
(@slot-ref, @slot-set!): Only define transformers for these at
compile-time. Avoids loading up the compiler unnecessarily. Also, allow
for the `n' to be determined lexically, in which case we dispatch to
the primitive.
(num-standard-pre-cache, define-standard-accessor-method)
(bound-check-get, standard-get, standard-set): Rework the fixed-offset
getters and setters so that they can be computed at compile-time.
Accessors to fields with n > num-standard-pre-cache will be dispatched
to the primitive instead of within the VM.
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 5 | ||||
-rw-r--r-- | module/oop/goops.scm | 95 |
2 files changed, 52 insertions, 48 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index f27ae7a43..2821c1e70 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -174,8 +174,9 @@ (define syntax-error (@ (system base compile) syntax-error)) (pmatch (cdr exp) ,@clauses - (else - (syntax-error l (format #f "bad ~A" ',sym) exp)))))) + ,@(if (assq 'else clauses) '() + '((else + (syntax-error l (format #f "bad ~A" ',sym) exp)))))))) (define-scheme-translator quote ;; (quote OBJ) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 35020f840..db946f4be 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -88,9 +88,10 @@ (oop goops compile)) -(define min-fixnum (- (expt 2 29))) - -(define max-fixnum (- (expt 2 29) 1)) +(eval-case + ((load-toplevel compile-toplevel) + (define min-fixnum (- (expt 2 29))) + (define max-fixnum (- (expt 2 29) 1)))) ;; ;; goops-error @@ -1035,27 +1036,13 @@ (procedure-environment proc))) (lambda (o) (assert-bound (proc o) o))))) -(define n-standard-accessor-methods 10) - -(define bound-check-get-methods (make-vector n-standard-accessor-methods #f)) -(define standard-get-methods (make-vector n-standard-accessor-methods #f)) -(define standard-set-methods (make-vector n-standard-accessor-methods #f)) - -(define (standard-accessor-method make methods) - (lambda (index) - (cond ((>= index n-standard-accessor-methods) (make index)) - ((vector-ref methods index)) - (else (let ((m (make index))) - (vector-set! methods index m) - m))))) - ;; the idea is to compile the index into the procedure, for fastest ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. (eval-case - ((load-toplevel compile-toplevel) + ((compile-toplevel) (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) - ((language ghil) :select (make-ghil-inline)) + ((language ghil) :select (make-ghil-inline make-ghil-call)) (system base pmatch)) ;; unfortunately, can't use define-inline because these are primitive @@ -1064,38 +1051,54 @@ ((,obj ,index) (guard (integer? index) (>= index 0) (< index max-fixnum)) (make-ghil-inline #f #f 'slot-ref - (list (retrans obj) (retrans index))))) + (list (retrans obj) (retrans index)))) + (else + (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))) (define-scheme-translator @slot-set! ((,obj ,index ,val) (guard (integer? index) (>= index 0) (< index max-fixnum)) (make-ghil-inline #f #f 'slot-set - (list (retrans obj) (retrans index) (retrans val))))))) - -;; Irritatingly, we can't use `compile' here, as the module shadows -;; the binding. -(define (make-bound-check-get index) - ((@ (system base compile) compile) - `(lambda (o) (let ((x (@slot-ref o ,index))) - (if (unbound? x) - (slot-unbound obj) - x))) - #:env *goops-module*)) - -(define (make-get index) - ((@ (system base compile) compile) - `(lambda (o) (@slot-ref o ,index)) - #:env *goops-module*)) - -(define (make-set index) - ((@ (system base compile) compile) - `(lambda (o v) (@slot-set! o ,index v)) - #:env *goops-module*)) - -(define bound-check-get - (standard-accessor-method make-bound-check-get bound-check-get-methods)) -(define standard-get (standard-accessor-method make-get standard-get-methods)) -(define standard-set (standard-accessor-method make-set standard-set-methods)) + (list (retrans obj) (retrans index) (retrans val)))) + (else + (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))) + +(eval-case + ((load-toplevel compile-toplevel) + (define num-standard-pre-cache 20))) + +(define-macro (define-standard-accessor-method form . body) + (let ((name (caar form)) + (n-var (cadar form)) + (args (cdr form))) + (define (make-one x) + (define (body-trans form) + (cond ((not (pair? form)) form) + ((eq? (car form) '@slot-ref) + `(,(car form) ,(cadr form) ,x)) + ((eq? (car form) '@slot-set!) + `(,(car form) ,(cadr form) ,x ,(cadddr form))) + (else + (map body-trans form)))) + `(lambda ,args ,@(map body-trans body))) + `(define ,name + (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache))))) + (lambda (n) + (if (< n ,num-standard-pre-cache) + (vector-ref cache n) + ((lambda (,n-var) (lambda ,args ,@body)) n))))))) + +(define-standard-accessor-method ((bound-check-get n) o) + (let ((x (@slot-ref o n))) + (if (unbound? x) + (slot-unbound obj) + x))) + +(define-standard-accessor-method ((standard-get n) o) + (@slot-ref o n)) + +(define-standard-accessor-method ((standard-set n) o v) + (@slot-set! o n v)) ;;; compute-getters-n-setters ;;; |