summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-14 00:24:32 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-14 00:24:32 +0100
commitabd6af11cd1ab62c2f337dcd23a9d9c37b9d169e (patch)
tree0f3d56c1c703e96fd509fee652f75db6f237a0b5
parente177058bc4599c68308e6d7fcfbd3f2a0e695f84 (diff)
downloadguile-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.scm5
-rw-r--r--module/oop/goops.scm95
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
;;;