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.

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 17592d2..c1e4cd8 100644 (file)
--- 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 57755ea..c8c23c6 100644 (file)
--- 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 f84af33..d7220d4 100644 (file)
--- 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))