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

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Tue Aug 23 13:35:32 2011
New Revision: 13535

Log:
Moving huge object serialization from <init>() to <clinit>()
broke the code generation for that special case -- there's no longer
a 'this' variable to be loaded. Replace with <this class>.class.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Tue Aug 23 13:31:01 2011	(r13534)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Tue Aug 23 13:35:32 2011	(r13535)
@@ -1057,7 +1057,7 @@
 (defun make-static-initializer (class)
   (let ((*compiler-debug* nil)
         (method (make-jvm-method :static-initializer
-				 :void nil :flags '(:public :static))))
+                                 :void nil :flags '(:public :static))))
     ;; We don't normally need to see debugging output for <clinit>.
     (with-code-to-method (class method)
       method)))
@@ -1205,8 +1205,8 @@
        (emit-invokestatic +lisp+ "readObjectFromString"
                           (list +java-string+) +lisp-object+))
       (t
-       (aload 0) ;; this
-       (emit-invokevirtual +java-object+ "getClass" '() +java-class+)
+        ;; get a 'class literal' for this class
+       (emit 'ldc_w (pool-class *this-class*))
        (let ((pathname
               (compiland-external-constant-resource-name *current-compiland*)))
          (with-open-file (f pathname

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp	Tue Aug 23 13:31:01 2011	(r13534)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp	Tue Aug 23 13:35:32 2011	(r13535)
@@ -226,7 +226,7 @@
          (values (subtypep compiler-type typespec)))))
 
 (declaim (type hash-table *function-result-types*))
-(defconst *function-result-types* (make-hash-table :test 'equal))
+(defvar *function-result-types* (make-hash-table :test 'equal))
 
 (declaim (ftype (function (t) t) function-result-type))
 (defun function-result-type (name)

Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Tue Aug 23 13:31:01 2011	(r13534)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Tue Aug 23 13:35:32 2011	(r13535)
@@ -698,8 +698,11 @@
 
   ;; header
   (write-u4 #xCAFEBABE stream)
-  (write-u2 3 stream)
-  (write-u2 45 stream)
+  (write-u2 0 stream)
+  (write-u2 49 stream)  ;; our <clinit> methods use class literals
+  ;; which require a high enough class file format
+  ;; we used to have 45, but the LDC instruction doesn't support
+  ;; class literals in that version... (49 == Java 1.5)
 
    ;; constants pool
   (write-constants (class-file-constants class) stream)
@@ -714,7 +717,7 @@
 
   ;; interfaces
   (if (class-file-interfaces class)
-      (progn 
+      (progn
         (write-u2 (length (class-file-interfaces class)) stream)
         (dolist (interface-ref (class-file-interfaces class))
           (write-u2 interface-ref stream)))

Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Tue Aug 23 13:31:01 2011	(r13534)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Tue Aug 23 13:35:32 2011	(r13535)
@@ -660,6 +660,13 @@
         (inst 19 (u2 (car args))) ; LDC_W
         (inst 18 args))))
 
+;; ldc_w
+(define-resolver 19 (instruction)
+  (let* ((args (instruction-args instruction)))
+    (unless (= (length args) 1)
+      (error "Wrong number of args for LDC_W."))
+    (inst 19 (u2 (car args)))))
+
 ;; ldc2_w
 (define-resolver 20 (instruction)
   (let* ((args (instruction-args instruction)))