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