Changeset 12859 for branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Timestamp:

08/04/10 20:25:03 (13 years ago)

Author:

ehuelsmann

Message:

Introduce EMIT-GETFIELD and EMIT-PUTFIELD to further improve the
resolver vs emitter layers.

File:

• branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (26 diffs)

branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -510 +510 @@
     (apply #'%emit 'putstatic (u2 index))))
 
+(declaim (inline emit-getfield emit-putfield))
+(defknown emit-getfield (t t t) t)
+(defun emit-getfield (class-name field-name type)
+  (let* ((index (if (null *current-code-attribute*)
+                    (pool-field class-name field-name type)
+                    (pool-add-field-ref *pool* class-name field-name type))))
+    (apply #'%emit 'getfield (u2 index))))
+
+(defknown emit-putfield (t t t) t)
+(defun emit-putfield (class-name field-name type)
+  (let* ((index (if (null *current-code-attribute*)
+                    (pool-field class-name field-name type)
+                    (pool-add-field-ref *pool* class-name field-name type))))
+    (apply #'%emit 'putfield (u2 index))))
+
+
+
 (defvar type-representations '((:int fixnum)
                                (:long (integer #.most-negative-java-long
@@ -553 +570 @@
         (t
          (emit 'checkcast +lisp-character+)
-         (emit 'getfield +lisp-character+ "value" :char))))
+         (emit-getfield +lisp-character+ "value" :char))))
 
 ;;                     source type /
@@ -842 +859 @@
         (t
          (emit 'checkcast +lisp-fixnum+)
-         (emit 'getfield +lisp-fixnum+ "value" :int))))
+         (emit-getfield +lisp-fixnum+ "value" :int))))
 
 (defknown emit-unbox-long () t)
@@ -857 +874 @@
         (t
          (emit 'checkcast +lisp-single-float+)
-         (emit 'getfield +lisp-single-float+ "value" :float))))
+         (emit-getfield +lisp-single-float+ "value" :float))))
 
 (defknown emit-unbox-double () t)
@@ -867 +884 @@
         (t
          (emit 'checkcast +lisp-double-float+)
-         (emit 'getfield +lisp-double-float+ "value" :double))))
+         (emit-getfield +lisp-double-float+ "value" :double))))
 
 (defknown fix-boxing (t t) t)
@@ -878 +895 @@
                      (< *safety* 3))
                 (emit 'checkcast +lisp-fixnum+)
-                (emit 'getfield +lisp-fixnum+ "value" :int))
+                (emit-getfield +lisp-fixnum+ "value" :int))
                (t
                 (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
@@ -1162 +1179 @@
 ;; getfield, putfield class-name field-name type-name
 (define-resolver (180 181) (instruction)
-  (let* ((args (instruction-args instruction))
-         (index (pool-field (first args)
-                            (second args) (third args))))
-    (inst (instruction-opcode instruction) (u2 index))))
+  ;; we used to create the pool-field here; that moved to the emit-* layer
+  instruction)
 
 ;; new, anewarray, checkcast, instanceof class-name
@@ -1191 +1206 @@
 
 (defun resolve-instructions (code)
-  (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
-    (dotimes (index (length code) vector)
+  (let* ((len (length code))
+         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
+    (dotimes (index len vector)
       (declare (type (unsigned-byte 16) index))
       (let ((instruction (svref code index)))
@@ -1201 +1217 @@
                    (inst 'aload *thread*)
                    (inst 'aconst_null)
-                   (inst 'putfield (list +lisp-thread+ "_values"
-                                         +lisp-object-array+)))))
+                   (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
+                                                   +lisp-object-array+))))))
              (dolist (instruction instructions)
                (vector-push-extend (resolve-instruction instruction) vector))))
@@ -3740 +3756 @@
     ;; Save multiple values returned by first subform.
     (emit-push-current-thread)
-    (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+    (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
     (astore values-register)
     (dolist (subform subforms)
@@ -3747 +3763 @@
     (emit-push-current-thread)
     (aload values-register)
-    (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+)
+    (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
     ;; Result.
     (aload result-register)
@@ -3946 +3962 @@
              ;; Store values from values form in values register.
              (emit-push-current-thread)
-             (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+             (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
              (emit-move-from-stack values-register)
              ;; Did we get just one value?
@@ -4121 +4137 @@
            (emit 'aaload)
            (emit-swap representation nil)
-           (emit 'putfield +lisp-closure-binding+ "value" +lisp-object+))
+           (emit-putfield +lisp-closure-binding+ "value" +lisp-object+))
           ((variable-environment variable)
            (assert (not *file-compilation*))
@@ -4153 +4169 @@
          (emit-push-constant-int (variable-closure-index variable))
          (emit 'aaload)
-         (emit 'getfield +lisp-closure-binding+ "value" +lisp-object+))
+         (emit-getfield +lisp-closure-binding+ "value" +lisp-object+))
         ((variable-environment variable)
          (assert (not *file-compilation*))
@@ -4412 +4428 @@
         (astore go-register)
         ;; Get the tag.
-        (emit 'getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1.
+        (emit-getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1.
         (emit-push-variable (tagbody-id-variable block))
         (emit 'if_acmpne RETHROW) ;; Not this TAGBODY
         (aload go-register)
-        (emit 'getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
+        (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
         (astore tag-register)
         ;; Don't actually generate comparisons for tags
@@ -4587 +4603 @@
         ;; The Return object is on the runtime stack. Stack depth is 1.
         (emit 'dup) ; Stack depth is 2.
-        (emit 'getfield +lisp-return+ "tag" +lisp-object+) ; Still 2.
+        (emit-getfield +lisp-return+ "tag" +lisp-object+) ; Still 2.
         (emit-push-variable (block-id-variable block))
         ;; If it's not the block we're looking for...
@@ -4597 +4613 @@
         (emit 'athrow)
         (label THIS-BLOCK)
-        (emit 'getfield +lisp-return+ "result" +lisp-object+)
+        (emit-getfield +lisp-return+ "result" +lisp-object+)
         (emit-move-from-stack target) ; Stack depth is 0.
         ;; Finally...
@@ -7124 +7140 @@
                       (variable-block variable))))
            (aload (variable-binding-register variable))
-           (emit 'getfield +lisp-special-binding+ "value"
+           (emit-getfield +lisp-special-binding+ "value"
                  +lisp-object+))
           (t
@@ -7204 +7220 @@
              (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
              (emit 'dup_x1) ;; copy past th
-             (emit 'putfield +lisp-special-binding+ "value"
+             (emit-putfield +lisp-special-binding+ "value"
                    +lisp-object+))
             ((and (consp value-form)
@@ -7312 +7328 @@
      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit 'checkcast +lisp-symbol+)
-           (emit 'getfield  +lisp-symbol+ "name" +lisp-simple-string+)
+           (emit-getfield  +lisp-symbol+ "name" +lisp-simple-string+)
            (emit-move-from-stack target representation))
           (t
@@ -7571 +7587 @@
       ;; The Throw object is on the runtime stack. Stack depth is 1.
       (emit 'dup) ; Stack depth is 2.
-      (emit 'getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2.
+      (emit-getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2.
       (aload tag-register) ; Stack depth is 3.
       ;; If it's not the tag we're looking for, we branch to the start of the
@@ -7648 +7664 @@
         (unless (single-valued-p protected-form)
           (emit-push-current-thread)
-          (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+          (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
           (astore values-register))
         (label END-PROTECTED-RANGE))
@@ -7661 +7677 @@
       (astore exception-register)
       (emit-push-current-thread)
-      (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+      (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
       (astore values-register)
       (let ((*register* *register*))
@@ -7669 +7685 @@
       (emit-push-current-thread)
       (aload values-register)
-      (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+)
+      (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
       (aload exception-register)
       (emit 'athrow) ; Re-throw exception.
@@ -7677 +7693 @@
         (emit-push-current-thread)
         (aload values-register)
-        (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+))
+        (emit-putfield +lisp-thread+ "_values" +lisp-object-array+))
       ;; Result.
       (aload result-register)
@@ -7968 +7984 @@
         (progn
           (aload 0)
-          (emit 'getfield +lisp-compiled-closure+ "ctx"
+          (emit-getfield +lisp-compiled-closure+ "ctx"
                 +closure-binding-array+)
           (when local-closure-vars