summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-05-20 13:59:42 +0200
committerAndy Wingo <wingo@pobox.com>2009-05-20 13:59:42 +0200
commitad9b8c451b82f74cf88c5a6207ed3ea72c86f93e (patch)
tree092ae4f3646be48bb2da8282a0a336cb3dd6ef3e /module
parentc11f46afe113f50e34af33ad3055b3da66e4b71f (diff)
downloadguile-ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e.tar.gz
fix @slot-ref / @slot-set! compilation
* module/language/tree-il/compile-glil.scm: Add primcall compilers for @slot-ref and @slot-set. * module/language/tree-il/optimize.scm (add-interesting-primitive!): New export. Creates an association between a variable in the current module and a primitive name. * module/oop/goops.scm: Rework compiler hooks to work with tree-il and not ghil.
Diffstat (limited to 'module')
-rw-r--r--module/language/tree-il/compile-glil.scm5
-rw-r--r--module/language/tree-il/optimize.scm15
-rw-r--r--module/oop/goops.scm27
3 files changed, 14 insertions, 33 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 17592d275..c1e4cd883 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -32,7 +32,6 @@
;;
;; call-with-values -> mv-bind
;; compile-time-environment
-;; GOOPS' @slot-ref, @slot-set
;; basic degenerate-case reduction
;; allocation:
@@ -81,7 +80,9 @@
((null? . 1) . null?)
((list? . 1) . list?)
(list . list)
- (vector . vector)))
+ (vector . vector)
+ ((@slot-ref . 2) . slot-ref)
+ ((@slot-set! . 3) . slot-set)))
(define (make-label) (gensym ":L"))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 57755ea5e..c8c23c636 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -23,7 +23,7 @@
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (language tree-il inline)
- #:export (optimize!))
+ #:export (optimize! add-interesting-primitive!))
(define (env-module e)
(if e (car e) (current-module)))
@@ -65,12 +65,13 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
-(define *interesting-primitive-vars*
- (let ((h (make-hash-table)))
- (for-each (lambda (x)
- (hashq-set! h (module-variable the-root-module x) x))
- *interesting-primitive-names*)
- h))
+(define (add-interesting-primitive! name)
+ (hashq-set! *interesting-primitive-vars*
+ (module-variable (current-module) name) name))
+
+(define *interesting-primitive-vars* (make-hash-table))
+
+(for-each add-interesting-primitive! *interesting-primitive-names*)
(define (resolve-primitives! x mod)
(post-order!
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f84af33fc..d7220d470 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1061,31 +1061,10 @@
;; the idea is to compile the index into the procedure, for fastest
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-;; separate expression so that we affect the expansion of the subsequent
-;; expression
(eval-when (compile)
- (use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
- ((language ghil) :select (make-ghil-inline make-ghil-call))
- (system base pmatch)))
-
-(eval-when (compile)
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (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))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+ (use-modules ((language tree-il optimize) :select (add-interesting-primitive!)))
+ (add-interesting-primitive! '@slot-ref)
+ (add-interesting-primitive! '@slot-set!))
(eval-when (eval load compile)
(define num-standard-pre-cache 20))