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

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed Feb  4 20:13:59 2009
New Revision: 11621

Log:
Implement P2-COMPILAND-UNBOX-VARIABLE in terms of new primitives.
Replace the last occurrance of (EMIT 'VAR-SET ...) with (EMIT-MOVE-TO-VARIABLE ...);
   removes the need to 'RESOLVE-VARIABLES': eliminate it and the VAR-SET artificial opcode.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/opcodes.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	Wed Feb  4 20:13:59 2009
@@ -1473,36 +1473,6 @@
 ;;         (print-code))
       max-stack)))
 
-(defun resolve-variables ()
-  (let ((code (nreverse *code*)))
-    (setf *code* nil)
-    (dolist (instruction code)
-      (case (instruction-opcode instruction)
-        (207 ; VAR-SET
-         (let ((variable (car (instruction-args instruction))))
-           (aver (variable-p variable))
-           (aver (not (variable-special-p variable)))
-           (cond ((variable-register variable)
-                  (dformat t "register = ~S~%" (variable-register variable))
-                  (astore (variable-register variable)))
-                 ((variable-closure-index variable)
-                  (dformat t "closure-index = ~S~%" (variable-closure-index variable))
-                  (aver (not (null (compiland-closure-register *current-compiland*))))
-                  (aload (compiland-closure-register *current-compiland*))
-                  (emit 'swap) ; array value
-                  (emit-push-constant-int (variable-closure-index variable))
-                  (emit 'swap) ; array index value
-                  (emit 'aastore))
-                 (t
-                  (dformat t "var-set fall-through case~%")
-                  (aver (not (null (compiland-argument-register *current-compiland*))))
-                  (aload (compiland-argument-register *current-compiland*)) ; Stack: value array
-                  (emit 'swap) ; array value
-                  (emit-push-constant-int (variable-index variable)) ; array value index
-                  (emit 'swap) ; array index value
-                  (emit 'aastore)))))
-        (t
-         (push instruction *code*))))))
 
 (defun finalize-code ()
   (setf *code* (nreverse (coerce *code* 'vector))))
@@ -5034,7 +5004,7 @@
       (emit-invokestatic +lisp-class+ "makeCompiledClosure"
 			 (list +lisp-object+ +lisp-object-array+)
 			 +lisp-object+)))
-  (emit 'var-set (local-function-variable local-function)))
+  (emit-move-to-variable (local-function-variable local-function)))
 
 (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
   `(let* ((,pathname (make-temp-file))
@@ -8348,24 +8318,12 @@
                (not (variable-special-p variable))
                (not (variable-used-non-locally-p variable))
                (zerop (compiland-children *current-compiland*)))
-      (let ((type (variable-declared-type variable)))
-        (cond ((fixnum-type-p type)
-               (aload register)
-               (emit-unbox-fixnum)
-               (emit 'istore register)
-               (setf (variable-representation variable) :int))
-              ((java-long-type-p type)
-               (let ((new-register (allocate-register-pair)))
-                 (aload register)
-                 (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")
-                 (emit 'lstore new-register)
-                 (setf (variable-register variable) new-register)
-                 (setf (variable-representation variable) :long)))
-              ((eq type 'CHARACTER)
-               (aload register)
-               (emit-unbox-character)
-               (emit 'istore register)
-               (setf (variable-representation variable) :char))))))
+      (emit-push-variable variable)
+      (derive-variable-representation variable nil) ;; nil == no block
+      (when (< 1 (representation-size (variable-representation variable)))
+        (allocate-variable-register variable))
+      (convert-representation nil (variable-representation variable))
+      (emit-move-to-variable variable)))
   t)
 
 (defknown p2-compiland (t) t)
@@ -8602,8 +8560,6 @@
 
     (emit 'areturn)
 
-    (resolve-variables)
-
     ;; Warn if any unused args. (Is this the right place?)
     (check-for-unused-variables (compiland-arg-vars compiland))
 

Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp	Wed Feb  4 20:13:59 2009
@@ -259,9 +259,8 @@
 ;; (define-opcode store-value 204 nil -1)
 (define-opcode clear-values 205 0 0)
 ;;(define-opcode var-ref 206 0 0)
-(define-opcode var-set 207 0 0)
 
-(defparameter *last-opcode* 207)
+(defparameter *last-opcode* 206)
 
 (declaim (ftype (function (t) t) opcode-name))
 (defun opcode-name (opcode-number)