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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Oct 10 13:55:32 2009
New Revision: 12188

Log:
Fix cl-bench BENCH-STRINGS/ADJUSTABLE:
  We can't unbox variables which are in the argument array,
  because all variables need to have the same type.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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	Sat Oct 10 13:55:32 2009
@@ -4149,10 +4149,15 @@
     (return-from derive-variable-representation))
   (when type-supplied-p
     (setf (variable-declared-type variable) type))
+  (when (or (variable-closure-index variable)
+            (variable-index variable))
+    ;; variables in one of the arrays cannot be represented
+    ;; other than by the boxed representation LispObject
+    (return-from derive-variable-representation))
   (let ((type (variable-declared-type variable)))
     (when (and (eq (variable-declared-type variable) :none)
                (eql (variable-writes variable) 0))
-      (setf type (variable-derived-type variable)))
+      (variable-derived-type variable))
     (cond ((neq type :none)
            (setf (variable-representation variable)
                  (type-representation type))
@@ -4196,78 +4201,27 @@
 
 (defun emit-move-to-variable (variable)
   (let ((representation (variable-representation variable)))
-    (flet ((emit-array-store (representation)
-             (emit (ecase representation
-                     ((:int :boolean :char)
-                              'iastore)
-                     (:long   'lastore)
-                     (:float  'fastore)
-                     (:double 'dastore)
-                     ((nil)   'aastore)))))
-      (cond ((variable-register variable)
-             (emit (ecase (variable-representation variable)
-                     ((:int :boolean :char)
-                              'istore)
-                     (:long   'lstore)
-                     (:float  'fstore)
-                     (:double 'dstore)
-                     ((nil)   'astore))
-                   (variable-register variable)))
-            ((variable-index variable)
-             (aload (compiland-argument-register *current-compiland*))
-             (emit-swap representation nil)
-             (emit-push-constant-int (variable-index variable))
-             (emit-swap representation :int)
-             (emit-array-store (variable-representation variable)))
-            ((variable-closure-index variable)
-             (aload (compiland-closure-register *current-compiland*))
-             (emit-push-constant-int (variable-closure-index variable))
-             (emit 'aaload)
-             (emit-swap representation nil)
-             (emit 'putfield +closure-binding-class+ "value" +lisp-object+))
-            ((variable-environment variable)
-             (assert (not *file-compilation*))
-             (emit 'getstatic *this-class*
-                   (declare-object (variable-environment variable)
-                                   +lisp-environment+
-                                   +lisp-environment-class+)
-                   +lisp-environment+)
-             (emit 'swap)
-             (emit-push-variable-name variable)
-             (emit 'swap)
-             (emit-invokevirtual +lisp-environment-class+ "rebind"
-                                 (list +lisp-symbol+ +lisp-object+)
-                                 nil))
-            (t
-             (assert nil))))))
-
-(defun emit-push-variable (variable)
-  (flet ((emit-array-load (representation)
-           (emit (ecase representation
-                       ((:int :boolean :char)
-                                'iaload)
-                       (:long   'laload)
-                       (:float  'faload)
-                       (:double 'daload)
-                       ((nil)   'aaload)))))
     (cond ((variable-register variable)
            (emit (ecase (variable-representation variable)
-                       ((:int :boolean :char)
-                                'iload)
-                       (:long   'lload)
-                       (:float  'fload)
-                       (:double 'dload)
-                       ((nil)   'aload))
+                   ((:int :boolean :char)
+                    'istore)
+                   (:long   'lstore)
+                   (:float  'fstore)
+                   (:double 'dstore)
+                   ((nil)   'astore))
                  (variable-register variable)))
           ((variable-index variable)
            (aload (compiland-argument-register *current-compiland*))
+           (emit-swap representation nil)
            (emit-push-constant-int (variable-index variable))
-           (emit-array-load (variable-representation variable)))
+           (emit-swap representation :int)
+           (emit 'aastore))
           ((variable-closure-index variable)
            (aload (compiland-closure-register *current-compiland*))
            (emit-push-constant-int (variable-closure-index variable))
            (emit 'aaload)
-           (emit 'getfield +closure-binding-class+ "value" +lisp-object+))
+           (emit-swap representation nil)
+           (emit 'putfield +closure-binding-class+ "value" +lisp-object+))
           ((variable-environment variable)
            (assert (not *file-compilation*))
            (emit 'getstatic *this-class*
@@ -4275,13 +4229,48 @@
                                  +lisp-environment+
                                  +lisp-environment-class+)
                  +lisp-environment+)
+           (emit 'swap)
            (emit-push-variable-name variable)
-           (emit-invokevirtual +lisp-environment-class+ "lookup"
-                               (list +lisp-object+)
-                               +lisp-object+))
+           (emit 'swap)
+           (emit-invokevirtual +lisp-environment-class+ "rebind"
+                               (list +lisp-symbol+ +lisp-object+)
+                               nil))
           (t
            (assert nil)))))
 
+(defun emit-push-variable (variable)
+  (cond ((variable-register variable)
+         (emit (ecase (variable-representation variable)
+                 ((:int :boolean :char)
+                  'iload)
+                 (:long   'lload)
+                 (:float  'fload)
+                 (:double 'dload)
+                 ((nil)   'aload))
+               (variable-register variable)))
+        ((variable-index variable)
+         (aload (compiland-argument-register *current-compiland*))
+         (emit-push-constant-int (variable-index variable))
+         (emit 'aaload))
+        ((variable-closure-index variable)
+         (aload (compiland-closure-register *current-compiland*))
+         (emit-push-constant-int (variable-closure-index variable))
+         (emit 'aaload)
+         (emit 'getfield +closure-binding-class+ "value" +lisp-object+))
+        ((variable-environment variable)
+         (assert (not *file-compilation*))
+         (emit 'getstatic *this-class*
+               (declare-object (variable-environment variable)
+                               +lisp-environment+
+                               +lisp-environment-class+)
+               +lisp-environment+)
+         (emit-push-variable-name variable)
+         (emit-invokevirtual +lisp-environment-class+ "lookup"
+                             (list +lisp-object+)
+                             +lisp-object+))
+        (t
+         (assert nil))))
+
 
 (defknown p2-let-bindings (t) t)
 (defun p2-let-bindings (block)