[armedbear-cvs] r11892 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May 17 10:38:44 2009
New Revision: 11892

Log:
Re-use fields of objects declared previously
within the same class file, instead of creating
separate fields for every reference.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun May 17 10:38:44 2009
@@ -2197,20 +2197,23 @@
 loading the object value into a field upon class-creation time.
 
 The field type of the object is specified by OBJ-REF."
-  (let ((key (symbol-name (gensym "OBJ"))))
-    (remember key obj)
-    (let* ((g1 (declare-string key))
-           (g2 (symbol-name (gensym "O2BJ"))))
-      (let* ((*code* *static-code*))
-      (declare-field g2 obj-ref)
-      (emit 'getstatic *this-class* g1 +lisp-simple-string+)
-      (emit-invokestatic +lisp-class+ "recall"
-                         (list +lisp-simple-string+) +lisp-object+)
-      (when (and obj-class (string/= obj-class +lisp-object-class+))
-        (emit 'checkcast obj-class))
-      (emit 'putstatic *this-class* g2 obj-ref)
-      (setf *static-code* *code*)
-      g2))))
+  (let ((field-name (gethash1 obj *declared-objects*)))
+    (if field-name
+        field-name
+      (let ((key (symbol-name (gensym "OBJ"))))
+        (remember key obj)
+        (let* ((g1 (declare-string key))
+               (g2 (symbol-name (gensym "O2BJ")))
+               (*code* *static-code*))
+          (declare-field g2 obj-ref)
+          (emit 'getstatic *this-class* g1 +lisp-simple-string+)
+          (emit-invokestatic +lisp-class+ "recall"
+                             (list +lisp-simple-string+) +lisp-object+)
+          (when (and obj-class (string/= obj-class +lisp-object-class+))
+            (emit 'checkcast obj-class))
+          (emit 'putstatic *this-class* g2 obj-ref)
+          (setf *static-code* *code*)
+          (setf (gethash obj *declared-objects*) g2))))))
 
 (defun declare-lambda (obj)
   (let* ((g (symbol-name (gensym "LAMBDA")))

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Sun May 17 10:38:44 2009
@@ -87,6 +87,7 @@
 (defvar *declared-integers* nil)
 (defvar *declared-floats* nil)
 (defvar *declared-doubles* nil)
+(defvar *declared-objects* nil)
 
 (defstruct (class-file (:constructor %make-class-file))
   pathname ; pathname of output file
@@ -105,7 +106,8 @@
   (strings (make-hash-table :test 'eq))
   (integers (make-hash-table :test 'eql))
   (floats (make-hash-table :test 'eql))
-  (doubles (make-hash-table :test 'eql)))
+  (doubles (make-hash-table :test 'eql))
+  (objects (make-hash-table :test 'eq)))
 
 (defun class-name-from-filespec (filespec)
   (let* ((name (pathname-name filespec)))
@@ -137,7 +139,8 @@
             (*declared-strings*   (class-file-strings ,var))
             (*declared-integers*  (class-file-integers ,var))
             (*declared-floats*    (class-file-floats ,var))
-            (*declared-doubles*   (class-file-doubles ,var)))
+            (*declared-doubles*   (class-file-doubles ,var))
+            (*declared-objects*   (class-file-objects ,var)))
        (progn , at body)
        (setf (class-file-pool ,var)         *pool*
              (class-file-pool-count ,var)   *pool-count*
@@ -149,7 +152,8 @@
              (class-file-strings ,var)      *declared-strings*
              (class-file-integers ,var)     *declared-integers*
              (class-file-floats ,var)       *declared-floats*
-             (class-file-doubles ,var)      *declared-doubles*))))
+             (class-file-doubles ,var)      *declared-doubles*
+             (class-file-objects ,var)      *declared-objects*))))
 
 (defstruct compiland
   name