Changeset 12983

Timestamp:

10/25/10 22:17:28 (12 years ago)

Author:

astalla

Message:

[invokedynamic]

• instructions simulate their effect on the stack and locals (adapted from ASM, with limitations)
• p2 uses with-code-to-method instead of *static-code* to generate <init> and <clinit> (bugged)
• in general, functions that add constants to the pool have been changed to return the constant's struct rather than its index. However I haven't thorougly changed them all, only more or less the ones I needed.
• and other changes to keep all the above stuff together.

Compilation is still broken: the superclass is set too late.

Location:

branches/invokedynamic/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (17 diffs)
• jvm-class-file.lisp (modified) (23 diffs)
• jvm-instructions.lisp (modified) (10 diffs)
• jvm.lisp (modified) (3 diffs)

branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -797 +797 @@
   (emit-constructor-lambda-list object))
 
-(defun make-constructor (super lambda-name args)
+(defun make-constructor (class)
   (let* ((*compiler-debug* nil)
          ;; We don't normally need to see debugging output for constructors.
-         (method (make-method :constructor :void nil
-                              :flags '(:public)))
-         (code (method-add-code method))
-         req-params-register
+   (super (class-file-superclass class))
+   (lambda-name (abcl-class-file-lambda-name class))
+   (args (abcl-class-file-lambda-list class))
+   req-params-register
          opt-params-register
          key-params-register
          rest-p
          keys-p
-         more-keys-p
-         (*code* ())
-         (*current-code-attribute* code))
-    (setf (code-max-locals code) 1)
-    (unless (eq super +lisp-primitive+)
-      (multiple-value-bind
-            (req opt key key-p rest
-                 allow-other-keys-p)
-          (parse-lambda-list args)
-        (setf rest-p rest
-              more-keys-p allow-other-keys-p
-              keys-p key-p)
-        (macrolet
-            ((parameters-to-array ((param params register) &body body)
-               (let ((count-sym (gensym)))
-                 `(progn
-                    (emit-push-constant-int (length ,params))
-                    (emit-anewarray +lisp-closure-parameter+)
-                    (astore (setf ,register (code-max-locals code)))
-                    (incf (code-max-locals code))
-                    (do* ((,count-sym 0 (1+ ,count-sym))
-                          (,params ,params (cdr ,params))
-                          (,param (car ,params) (car ,params)))
-                        ((endp ,params))
-                      (declare (ignorable ,param))
-                      (aload ,register)
-                      (emit-push-constant-int ,count-sym)
-                      (emit-new +lisp-closure-parameter+)
-                      (emit 'dup)
-                      ,@body
-                      (emit 'aastore))))))
-          ;; process required args
-          (parameters-to-array (ignore req req-params-register)
-             (emit-push-t) ;; we don't need the actual symbol
-             (emit-invokespecial-init +lisp-closure-parameter+
-                                      (list +lisp-symbol+)))
-
-          (parameters-to-array (param opt opt-params-register)
-             (emit-push-t) ;; we don't need the actual variable-symbol
-             (emit-read-from-string (second param)) ;; initform
-             (if (null (third param))               ;; supplied-p
-                 (emit-push-nil)
-                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
-             (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
-             (emit-invokespecial-init +lisp-closure-parameter+
-                                      (list +lisp-symbol+ +lisp-object+
-                                            +lisp-object+ :int)))
-
-          (parameters-to-array (param key key-params-register)
-             (let ((keyword (fourth param)))
-               (if (keywordp keyword)
-                   (progn
-                     (emit 'ldc (pool-string (symbol-name keyword)))
-                     (emit-invokestatic +lisp+ "internKeyword"
-                                        (list +java-string+) +lisp-symbol+))
-                   ;; symbol is not really a keyword; yes, that's allowed!
-                   (progn
-                     (emit 'ldc (pool-string (symbol-name keyword)))
-                     (emit 'ldc (pool-string
-                                 (package-name (symbol-package keyword))))
-                     (emit-invokestatic +lisp+ "internInPackage"
-                                        (list +java-string+ +java-string+)
-                                        +lisp-symbol+))))
-             (emit-push-t) ;; we don't need the actual variable-symbol
-             (emit-read-from-string (second (car key)))
-             (if (null (third param))
-                 (emit-push-nil)
-                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
-             (emit-invokespecial-init +lisp-closure-parameter+
-                                      (list +lisp-symbol+ +lisp-symbol+
-                                            +lisp-object+ +lisp-object+))))))
-    (aload 0) ;; this
-    (cond ((eq super +lisp-primitive+)
-           (emit-constructor-lambda-name lambda-name)
-           (emit-constructor-lambda-list args)
-           (emit-invokespecial-init super (lisp-object-arg-types 2)))
-          ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
-           (aload req-params-register)
-           (aload opt-params-register)
-           (aload key-params-register)
-           (if keys-p
-               (emit-push-t)
-               (emit-push-nil-symbol))
-           (if rest-p
-               (emit-push-t)
-               (emit-push-nil-symbol))
-           (if more-keys-p
-               (emit-push-t)
-               (emit-push-nil-symbol))
-           (emit-invokespecial-init super
-                                    (list +lisp-closure-parameter-array+
-                                          +lisp-closure-parameter-array+
-                                          +lisp-closure-parameter-array+
-                                          +lisp-symbol+
-                                          +lisp-symbol+ +lisp-symbol+)))
-          (t
-           (aver nil)))
-    (setf *code* (append *static-code* *code*))
-    (emit 'return)
-    (setf (code-code code) *code*)
-    method))
-
-
-(defun make-static-initializer ()
-  (let* ((*compiler-debug* nil)
-         ;; We don't normally need to see debugging output for <clinit>.
-         (method (make-method :static-initializer
-            :void nil :flags '(:public :static)))
-         (code (method-add-code method))
-         (*code* ())
-         (*current-code-attribute* code))
-    (setf (code-max-locals code) 1)
-    (emit 'ldc (pool-class +lisp-function+))
-    (emit 'ldc (pool-string "linkLispFunction"))
-    (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod"
-           (list +java-class+ +java-string+) :void)
-    ;(setf *code* (append *static-code* *code*))
-    (emit 'return)
-    (setf (code-code code) *code*)
-    method))
+         more-keys-p)
+    (with-code-to-method (class (abcl-class-file-constructor class))
+      (setf (code-max-locals *current-code-attribute*) 1)
+      (unless (eq super +lisp-primitive+)
+  (multiple-value-bind
+        (req opt key key-p rest
+       allow-other-keys-p)
+      (parse-lambda-list args)
+    (setf rest-p rest
+    more-keys-p allow-other-keys-p
+    keys-p key-p)
+    (macrolet
+        ((parameters-to-array ((param params register) &body body)
+     (let ((count-sym (gensym)))
+       `(progn
+          (emit-push-constant-int (length ,params))
+          (emit-anewarray +lisp-closure-parameter+)
+          (astore (setf ,register (code-max-locals *current-code-attribute*)))
+          (incf (code-max-locals *current-code-attribute*))
+          (do* ((,count-sym 0 (1+ ,count-sym))
+          (,params ,params (cdr ,params))
+          (,param (car ,params) (car ,params)))
+         ((endp ,params))
+      (declare (ignorable ,param))
+      (aload ,register)
+      (emit-push-constant-int ,count-sym)
+      (emit-new +lisp-closure-parameter+)
+      (emit 'dup)
+      ,@body
+      (emit 'aastore))))))
+      ;; process required args
+      (parameters-to-array (ignore req req-params-register)
+               (emit-push-t) ;; we don't need the actual symbol
+         (emit-invokespecial-init +lisp-closure-parameter+
+          (list +lisp-symbol+)))
+
+      (parameters-to-array (param opt opt-params-register)
+               (emit-push-t) ;; we don't need the actual variable-symbol
+         (emit-read-from-string (second param)) ;; initform
+         (if (null (third param))               ;; supplied-p
+       (emit-push-nil)
+       (emit-push-t)) ;; we don't need the actual supplied-p symbol
+         (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
+         (emit-invokespecial-init +lisp-closure-parameter+
+          (list +lisp-symbol+ +lisp-object+
+                +lisp-object+ :int)))
+      
+      (parameters-to-array (param key key-params-register)
+               (let ((keyword (fourth param)))
+     (if (keywordp keyword)
+         (progn
+           (emit 'ldc (pool-string (symbol-name keyword)))
+           (emit-invokestatic +lisp+ "internKeyword"
+            (list +java-string+) +lisp-symbol+))
+         ;; symbol is not really a keyword; yes, that's allowed!
+         (progn
+           (emit 'ldc (pool-string (symbol-name keyword)))
+           (emit 'ldc (pool-string
+           (package-name (symbol-package keyword))))
+           (emit-invokestatic +lisp+ "internInPackage"
+            (list +java-string+ +java-string+)
+            +lisp-symbol+))))
+         (emit-push-t) ;; we don't need the actual variable-symbol
+         (emit-read-from-string (second (car key)))
+         (if (null (third param))
+       (emit-push-nil)
+       (emit-push-t)) ;; we don't need the actual supplied-p symbol
+         (emit-invokespecial-init +lisp-closure-parameter+
+          (list +lisp-symbol+ +lisp-symbol+
+                +lisp-object+ +lisp-object+))))))
+      (aload 0) ;; this
+      (cond ((eq super +lisp-primitive+)
+       (emit-constructor-lambda-name lambda-name)
+       (emit-constructor-lambda-list args)
+       (emit-invokespecial-init super (lisp-object-arg-types 2)))
+      ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
+       (aload req-params-register)
+       (aload opt-params-register)
+       (aload key-params-register)
+       (if keys-p
+     (emit-push-t)
+     (emit-push-nil-symbol))
+       (if rest-p
+     (emit-push-t)
+     (emit-push-nil-symbol))
+       (if more-keys-p
+     (emit-push-t)
+     (emit-push-nil-symbol))
+       (emit-invokespecial-init super
+              (list +lisp-closure-parameter-array+
+              +lisp-closure-parameter-array+
+              +lisp-closure-parameter-array+
+              +lisp-symbol+
+              +lisp-symbol+ +lisp-symbol+)))
+      (t
+       (sys::%format t "MAKE-CONSTRUCTOR doesn't know how to handle superclass ~S~%" super)
+       (aver nil))))))
+
+(defun make-static-initializer (class)
+  (let ((*compiler-debug* nil))
+    ;; We don't normally need to see debugging output for <clinit>.
+    (with-code-to-method (class (abcl-class-file-static-initializer class))
+      (setf (code-max-locals *current-code-attribute*) 1)
+      (emit 'ldc (pool-class +lisp-function+))
+      (emit 'ldc (pool-string "linkLispFunction"))
+      (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod"
+       (list +java-class+ +java-string+) :void)
+      (emit 'return))))
 
 (defvar *source-line-number* nil)
-
 
 (defun finish-class (class stream)
@@ -937 +924 @@
 The compiler calls this function to indicate it doesn't want to
 extend the class any further."
-  (class-add-method class (make-constructor (class-file-superclass class)
-                                            (abcl-class-file-lambda-name class)
-                                            (abcl-class-file-lambda-list class)))
-  (class-add-method class (make-static-initializer))
+  (with-code-to-method (class (abcl-class-file-constructor class))
+    (emit 'return))
+  (make-static-initializer class)
   (finalize-class-file class)
   (write-class-file class stream))
@@ -1107 +1093 @@
 on the equality indicator in the `serialization-table'.
 
-Code to restore the serialized object is inserted into `*code' or
-`*static-code*' if `*declare-inline*' is non-nil.
+Code to restore the serialized object is inserted into the current method or
+the constructor if `*declare-inline*' is non-nil.
 "
   ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which
@@ -1138 +1124 @@
       (cond
         ((not *file-compilation*)
-         (let ((*code* *static-code*))
+   (with-code-to-method
+       (*class-file* (abcl-class-file-constructor *class-file*))
            (remember field-name object)
            (emit 'ldc (pool-string field-name))
@@ -1145 +1132 @@
            (when (not (eq field-type +lisp-object+))
              (emit-checkcast field-type))
-           (emit-putstatic *this-class* field-name field-type)
-           (setf *static-code* *code*)))
+           (emit-putstatic *this-class* field-name field-type)))
         (*declare-inline*
          (funcall dispatch-fn object)
          (emit-putstatic *this-class* field-name field-type))
         (t
-         (let ((*code* *static-code*))
+   (with-code-to-method
+       (*class-file* (abcl-class-file-constructor *class-file*))
            (funcall dispatch-fn object)
-           (emit-putstatic *this-class* field-name field-type)
-           (setf *static-code* *code*))))
+           (emit-putstatic *this-class* field-name field-type))))
 
       (emit-getstatic *this-class* field-name field-type)
@@ -1184 +1170 @@
                        (declare-object symbol))
               class *this-class*))
-     (let (saved-code)
-       (let ((*code* (if *declare-inline* *code* *static-code*)))
-         (if (eq class *this-class*)
-             (progn ;; generated by the DECLARE-OBJECT*'s above
-               (emit-getstatic class name +lisp-object+)
-               (emit-checkcast +lisp-symbol+))
-             (emit-getstatic class name +lisp-symbol+))
-         (emit-invokevirtual +lisp-symbol+
-                             (if setf
-                                 "getSymbolSetfFunctionOrDie"
-                                 "getSymbolFunctionOrDie")
-                             nil +lisp-object+)
-         ;; make sure we're not cacheing a proxied function
-         ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
-         (emit-invokevirtual +lisp-object+
-                             "resolve" nil +lisp-object+)
-         (emit-putstatic *this-class* f +lisp-object+)
-         (if *declare-inline*
-             (setf saved-code *code*)
-             (setf *static-code* *code*))
-         (setf (gethash symbol ht) f))
-       (when *declare-inline*
-         (setf *code* saved-code))
-       f))))
+     (with-code-to-method (*class-file*
+         (if *declare-inline* *method*
+             (abcl-class-file-constructor *class-file*)))
+       (if (eq class *this-class*)
+     (progn ;; generated by the DECLARE-OBJECT*'s above
+       (emit-getstatic class name +lisp-object+)
+       (emit-checkcast +lisp-symbol+))
+     (emit-getstatic class name +lisp-symbol+))
+       (emit-invokevirtual +lisp-symbol+
+         (if setf
+             "getSymbolSetfFunctionOrDie"
+             "getSymbolFunctionOrDie")
+         nil +lisp-object+)
+       ;; make sure we're not cacheing a proxied function
+       ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
+       (emit-invokevirtual +lisp-object+
+         "resolve" nil +lisp-object+)
+       (emit-putstatic *this-class* f +lisp-object+))
+     (setf (gethash symbol ht) f)
+     f)))
 
 (defknown declare-setf-function (name) string)
@@ -1219 +1201 @@
    local-function *declared-functions* ht g
    (setf g (symbol-name (gensym "LFUN")))
-   (let* ((class-name (abcl-class-file-class-name
-                       (local-function-class-file local-function)))
-          (*code* *static-code*))
+   (let ((class-name (abcl-class-file-class-name
+          (local-function-class-file local-function))))
+     (with-code-to-method
+   (*class-file* (abcl-class-file-constructor *class-file*))
      ;; fixme *declare-inline*
-     (declare-field g +lisp-object+)
-     (emit-new class-name)
-     (emit 'dup)
-     (emit-invokespecial-init class-name '())
-     (emit-putstatic *this-class* g +lisp-object+)
-     (setf *static-code* *code*)
-     (setf (gethash local-function ht) g))))
+       (declare-field g +lisp-object+)
+       (emit-new class-name)
+       (emit 'dup)
+       (emit-invokespecial-init class-name '())
+       (emit-putstatic *this-class* g +lisp-object+)
+       (setf (gethash local-function ht) g)))))
 
 
@@ -1242 +1224 @@
   ;;  EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and*
   ;;  emits the right loading code (not just de-serialization anymore)
-  (let (saved-code
-        (g (symbol-name (gensym "OBJSTR"))))
-    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
-           (*code* (if *declare-inline* *code* *static-code*)))
-      ;; strings may contain evaluated bits which may depend on
-      ;; previous statements
-      (declare-field g +lisp-object+)
-      (emit 'ldc (pool-string s))
-      (emit-invokestatic +lisp+ "readObjectFromString"
-                         (list +java-string+) +lisp-object+)
-      (emit-putstatic *this-class* g +lisp-object+)
-      (if *declare-inline*
-          (setf saved-code *code*)
-          (setf *static-code* *code*)))
-    (when *declare-inline*
-      (setf *code* saved-code))
-    g))
+  (let ((g (symbol-name (gensym "OBJSTR")))
+  (s (with-output-to-string (stream) (dump-form obj stream))))
+     (with-code-to-method
+   (*class-file*
+    (if *declare-inline* *method*
+        (abcl-class-file-constructor *class-file*)))
+       ;; strings may contain evaluated bits which may depend on
+       ;; previous statements
+       (declare-field g +lisp-object+)
+       (emit 'ldc (pool-string s))
+       (emit-invokestatic +lisp+ "readObjectFromString"
+        (list +java-string+) +lisp-object+)
+       (emit-putstatic *this-class* g +lisp-object+))
+     g))
 
 (defun declare-load-time-value (obj)
   (let ((g (symbol-name (gensym "LTV")))
-        saved-code)
-    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
-           (*code* (if *declare-inline* *code* *static-code*)))
-      ;; The readObjectFromString call may require evaluation of
-      ;; lisp code in the string (think #.() syntax), of which the outcome
-      ;; may depend on something which was declared inline
-      (declare-field g +lisp-object+)
-      (emit 'ldc (pool-string s))
-      (emit-invokestatic +lisp+ "readObjectFromString"
-                         (list +java-string+) +lisp-object+)
-      (emit-invokestatic +lisp+ "loadTimeValue"
-                         (lisp-object-arg-types 1) +lisp-object+)
-      (emit-putstatic *this-class* g +lisp-object+)
-      (if *declare-inline*
-          (setf saved-code *code*)
-          (setf *static-code* *code*)))
-    (when *declare-inline*
-      (setf *code* saved-code))
+  (s (with-output-to-string (stream) (dump-form obj stream))))
+     (with-code-to-method
+   (*class-file*
+    (if *declare-inline* *method*
+        (abcl-class-file-constructor *class-file*)))
+       ;; The readObjectFromString call may require evaluation of
+       ;; lisp code in the string (think #.() syntax), of which the outcome
+       ;; may depend on something which was declared inline
+       (declare-field g +lisp-object+)
+       (emit 'ldc (pool-string s))
+       (emit-invokestatic +lisp+ "readObjectFromString"
+        (list +java-string+) +lisp-object+)
+       (emit-invokestatic +lisp+ "loadTimeValue"
+        (lisp-object-arg-types 1) +lisp-object+)
+       (emit-putstatic *this-class* g +lisp-object+))
     g))
 
@@ -1291 +1267 @@
     ;; fixme *declare-inline*?
     (remember g obj)
-    (let* ((*code* *static-code*))
+    (with-code-to-method
+  (*class-file* (abcl-class-file-constructor *class-file*))
       (declare-field g +lisp-object+)
       (emit 'ldc (pool-string g))
       (emit-invokestatic +lisp+ "recall"
                          (list +java-string+) +lisp-object+)
-      (emit-putstatic *this-class* g +lisp-object+)
-      (setf *static-code* *code*)
-      g)))
+      (emit-putstatic *this-class* g +lisp-object+))
+    g))
 
 (defknown compile-constant (t t t) t)
@@ -3824 +3800 @@
                                    :if-exists :supersede)))
       (with-class-file class-file
+  (make-constructor class-file)
         (let ((*current-compiland* compiland))
           (with-saved-compiler-policy
@@ -6876 +6853 @@
                                :flags '(:final :public)))
          (code (method-add-code method))
+   (*code-locals* (code-computed-locals code)) ;;TODO in this and other cases, use with-code-to-method
+   (*code-stack* (code-computed-stack code))
          (*current-code-attribute* code)
          (*code* ())
@@ -6884 +6863 @@
          (*thread* nil)
          (*initialize-thread-var* nil)
-         (label-START (gensym)))
+         (label-START (gensym))
+   prologue)
 
     (class-add-method class-file method)
@@ -6896 +6876 @@
     (dolist (var (compiland-free-specials compiland))
       (push var *visible-variables*))
+
+    ;;Prologue
+    (let ((arity (compiland-arity compiland)))
+      (when arity
+  (generate-arg-count-check arity)))
+    
+    (when *hairy-arglist-p*
+      (aload 0) ; this
+      (aver (not (null (compiland-argument-register compiland))))
+      (aload (compiland-argument-register compiland)) ; arg vector
+      (cond ((or (memq '&OPTIONAL args) (memq '&KEY args))
+       (ensure-thread-var-initialized)
+       (maybe-initialize-thread-var)
+       (emit-push-current-thread)
+       (emit-invokevirtual *this-class* "processArgs"
+         (list +lisp-object-array+ +lisp-thread+)
+         +lisp-object-array+))
+      (t
+       (emit-invokevirtual *this-class* "fastProcessArgs"
+         (list +lisp-object-array+)
+         +lisp-object-array+)))
+      (astore (compiland-argument-register compiland)))
+    
+    (unless (and *hairy-arglist-p*
+     (or (memq '&OPTIONAL args) (memq '&KEY args)))
+      (maybe-initialize-thread-var))
+    
+    (setf prologue *code*
+    *code* ())
+    ;;;;
 
     (when *using-arg-array*
@@ -7040 +7050 @@
 
     ;; Go back and fill in prologue.
-    (let ((code *code*))
+    #+nil (let ((code *code*))
       (setf *code* ())
       (let ((arity (compiland-arity compiland)))
@@ -7067 +7077 @@
         (maybe-initialize-thread-var))
       (setf *code* (nconc code *code*)))
+    
+    (setf *code* (nconc prologue *code*))
 
     (setf (abcl-class-file-superclass class-file)
@@ -7077 +7089 @@
     (setf (code-max-locals code) *registers-allocated*)
     (setf (code-code code) *code*))
-
-
   t)
 
@@ -7123 +7133 @@
 
     (with-class-file (compiland-class-file compiland)
+      (make-constructor *class-file*)
       (with-saved-compiler-policy
         (p2-compiland compiland)

branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

@@ -292 +292 @@
 (defstruct (constant-member-ref (:constructor
                                  %make-constant-member-ref
-                                     (tag index class-index name/type-index))
+                                     (tag index class name/type))
                                 (:include constant))
   "Structure holding information on a member reference type item
 (a field, method or interface method reference) in the constant pool."
-  class-index
-  name/type-index)
+  class
+  name/type)
 
 (declaim (inline make-constant-field-ref make-constant-method-ref
                  make-constant-interface-method-ref))
-(defun make-constant-field-ref (index class-index name/type-index)
+(defun make-constant-field-ref (index class name/type)
   "Creates a `constant-member-ref' instance containing a field reference."
-  (%make-constant-member-ref 9 index class-index name/type-index))
-
-(defun make-constant-method-ref (index class-index name/type-index)
+  (%make-constant-member-ref 9 index class name/type))
+
+(defun make-constant-method-ref (index class name/type)
   "Creates a `constant-member-ref' instance containing a method reference."
-  (%make-constant-member-ref 10 index class-index name/type-index))
-
-(defun make-constant-interface-method-ref (index class-index name/type-index)
+  (%make-constant-member-ref 10 index class name/type))
+
+(defun make-constant-interface-method-ref (index class name/type)
   "Creates a `constant-member-ref' instance containing an
 interface-method reference."
-  (%make-constant-member-ref 11 index class-index name/type-index))
+  (%make-constant-member-ref 11 index class name/type))
 
 (defstruct (constant-string (:constructor
@@ -355 +355 @@
 (defstruct (constant-name/type (:constructor
                                 make-constant-name/type (index
-                                                         name-index
-                                                         descriptor-index))
+                                                         name
+                                                         descriptor))
                                (:include constant
                                          (tag 12)))
   "Structure holding information on a 'name-and-type' type item in the
 constant pool; this type of element is used by 'member-ref' type items."
-  name-index
-  descriptor-index)
+  name
+  descriptor)
 
 (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
@@ -396 +396 @@
   (let ((entry (gethash (acons name type class) (pool-entries pool))))
     (unless entry
-      (let ((c (constant-index (pool-add-class pool class)))
-            (n/t (constant-index (pool-add-name/type pool name type))))
+      (let ((c (pool-add-class pool class))
+            (n/t (pool-add-name/type pool name type)))
         (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
             (gethash (acons name type class) (pool-entries pool)) entry))
@@ -411 +411 @@
   (let ((entry (gethash (acons name type class) (pool-entries pool))))
     (unless entry
-      (let ((c (constant-index (pool-add-class pool class)))
-            (n/t (constant-index (pool-add-name/type pool name type))))
+      (let ((c (pool-add-class pool class))
+            (n/t (pool-add-name/type pool name type)))
         (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
               (gethash (acons name type class) (pool-entries pool)) entry))
@@ -425 +425 @@
   (let ((entry (gethash (acons name type class) (pool-entries pool))))
     (unless entry
-      (let ((c (constant-index (pool-add-class pool class)))
-            (n/t (constant-index (pool-add-name/type pool name type))))
+      (let ((c (pool-add-class pool class))
+            (n/t (pool-add-name/type pool name type)))
         (setf entry
             (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
@@ -492 +492 @@
                            (internal-field-ref type))))
     (unless entry
-      (let ((n (constant-index (pool-add-utf8 pool name)))
-            (i-t (constant-index (pool-add-utf8 pool internal-type))))
+      (let ((n (pool-add-utf8 pool name))
+            (i-t (pool-add-utf8 pool internal-type)))
         (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
               (gethash (cons name type) (pool-entries pool)) entry))
@@ -734 +734 @@
                      stream))
           ((9 10 11)           ; fieldref methodref InterfaceMethodref
-           (write-u2 (constant-member-ref-class-index entry) stream)
-           (write-u2 (constant-member-ref-name/type-index entry) stream))
+           (write-u2 (constant-index (constant-member-ref-class entry)) stream)
+           (write-u2 (constant-index (constant-member-ref-name/type entry)) stream))
           (12                           ; nameAndType
-           (write-u2 (constant-name/type-name-index entry) stream)
-           (write-u2 (constant-name/type-descriptor-index entry) stream))
+           (write-u2 (constant-index (constant-name/type-name entry)) stream)
+           (write-u2 (constant-index (constant-name/type-descriptor entry)) stream))
           (7                            ; class
            (write-u2 (constant-class-name-index entry) stream))
@@ -758 +758 @@
       ((9 10 11) (sys::%format t "ref: ~a,~a~%"
                                (constant-member-ref-class-index entry)
-                               (constant-member-ref-name/type-index entry)))
+                               (constant-member-ref-name/type entry)))
       (12 (sys::%format t "n/t: ~a,~a~%"
-                        (constant-name/type-name-index entry)
-                        (constant-name/type-descriptor-index entry)))
+                        (constant-name/type-name entry)
+                        (constant-name/type-descriptor entry)))
       (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
       (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
@@ -848 +848 @@
   name
   descriptor
-  attributes
-  initial-locals)
+  attributes)
 
 
@@ -883 +882 @@
   (method-add-attribute
    method
-   (make-code-attribute (+ (length (cdr (method-descriptor method)))
-                           (if (member :static (method-access-flags method))
-                               0 1))))) ;; 1 == implicit 'this'
+   (make-code-attribute (compute-initial-method-locals method))))
 
 (defun method-ensure-code (method)
@@ -904 +901 @@
   "Prepares `method' for serialization."
   (let ((pool (class-file-constants class)))
-    (setf (method-initial-locals method)
-    (compute-initial-method-locals class method)
-    (method-access-flags method)
+    (setf (method-access-flags method)
           (map-flags (method-access-flags method))
           (method-descriptor method)
@@ -980 +975 @@
   labels ;; an alist
 
-  ;; these two are used for handling nested WITH-CODE-TO-METHOD blocks
+  ;; these are used for handling nested WITH-CODE-TO-METHOD blocks
   (current-local 0)
-  stack-map-frames)
+  computed-locals
+  computed-stack)
 
 
@@ -1066 +1062 @@
   (write-attributes (code-attributes code) stream))
 
-(defun make-code-attribute (arg-count)
+(defun make-code-attribute (locals)
   "Creates an empty 'Code' attribute for a method which takes
 `arg-count` parameters, including the implicit `this` parameter."
-  (%make-code-attribute :max-locals arg-count))
+  (%make-code-attribute :max-locals (length locals)
+      :computed-locals locals))
 
 (defun code-add-attribute (code attribute)
@@ -1098 +1095 @@
   (let* ((length 0)
    labels ;; alist
-   stack-map-table
-   (*basic-block* (when compute-stack-map-table-p
+   stack-map-table)
+#||  (*basic-block* (when compute-stack-map-table-p
         (make-basic-block
          :offset 0
@@ -1105 +1102 @@
          (method-initial-locals method))))
    (root-block *basic-block*)
-   *basic-blocks*)
+   *basic-blocks*)||#
+    compute-stack-map-table-p :todo
     (declare (type (unsigned-byte 16) length))
     ;; Pass 1: calculate label offsets and overall length.
@@ -1112 +1110 @@
       (let* ((instruction (aref code i))
              (opcode (instruction-opcode instruction)))
+  (setf (instruction-offset instruction) length)
         (if (= opcode 202) ; LABEL
             (let ((label (car (instruction-args instruction))))
               (set label length)
               (setf labels
-                    (acons label length labels))
-        (incf length (opcode-size opcode))))))
+                    (acons label length labels)))
+      (incf length (opcode-size opcode)))))
     ;; Pass 2: replace labels with calculated offsets.
     (let ((index 0))
@@ -1130 +1129 @@
                               index)))
               (setf (instruction-args instruction) (s2 offset))))
-    (when compute-stack-map-table-p
-      (funcall (opcode-effect-function opcode)
-         instruction index))
           (unless (= (instruction-opcode instruction) 202) ; LABEL
             (incf index (opcode-size (instruction-opcode instruction)))))))
@@ -1215 +1211 @@
 
 (defvar *current-code-attribute* nil)
+(defvar *method* nil)
 
 (defun save-code-specials (code)
@@ -1234 +1231 @@
          (save-code-specials *current-code-attribute*))
        (let* ((,m ,method)
+        (*method* ,m)
               (,c (method-ensure-code ,method))
               (*pool* (class-file-constants ,class-file))
               (*code* (code-code ,c))
+              (*code-locals* (code-computed-locals ,c))
+        (*code-stack* (code-computed-stack ,c))
               (*registers-allocated* (code-max-locals ,c))
               (*register* (code-current-local ,c))
@@ -1243 +1243 @@
          (setf (code-code ,c) *code*
                (code-current-local ,c) *register*
-               (code-max-locals ,c) *registers-allocated*))
+               (code-max-locals ,c) *registers-allocated*
+         (code-computed-locals ,c) *code-locals*
+         (code-computed-stack ,c) *code-stack*))
        (when *current-code-attribute*
          (restore-code-specials *current-code-attribute*)))))
@@ -1426 +1428 @@
   (write-u2 (uninitialized-variable-info-offset vti) stream))
 
-(defconst *opcode-effect-table*
-  (make-array 256 :initial-element #'(lambda (&rest args) (car args))))
-
-(defun opcode-effect-function (opcode)
-  (svref *opcode-effect-table* opcode))
-
-(defstruct basic-block label offset input-locals input-stack output-locals output-stack successors)
-
-(defun basic-block-add-successor (basic-block successor)
-  (push successor (basic-block-successors basic-block)))
-
-(defvar *basic-block*)
-(defvar *basic-blocks* nil "An alist that associates labels with corresponding basic blocks")
-
-(defun label-basic-block (label)
-  (or (cdr (assoc label *basic-blocks*))
-      (setf (assoc label *basic-blocks*)
-      (make-basic-block :label label
-            :offset (symbol-value label)))))
-
-(defmacro define-opcode-effect (opcode &body body)
-  `(setf (svref *opcode-effect-table*
-    (opcode-number ',opcode))
-   (if (and (symbolp (car body)) (null (cdr body)))
-       `(function ,(car body))
-       #'(lambda (instruction offset)
-     (declare (ignorable instruction offset))
-     ,@body))))
-
-(defun compute-initial-method-locals (class method)
+(defun compute-initial-method-locals (method)
   (let (locals)
     (unless (member :static (method-access-flags method))
@@ -1462 +1435 @@
     (push :uninitialized-this locals)
     ;;the method is an instance method.
-    (push (class-file-class class) locals)))
+    (push :this locals)))
     (dolist (x (cdr (method-descriptor method)))
       (push x locals))
@@ -1468 +1441 @@
 
 (defun smf-type->variable-info (type)
-  (case type))
-
-(defun smf-get (pos)
-  (or (nth pos (basic-block-output-locals *basic-block*))
-      (error "Locals inconsistency: get ~A but locals are ~A"
-       pos (length (basic-block-output-locals *basic-block*)))))
-
-(defun smf-set (pos type)
-  (if (< pos (length (basic-block-output-locals *basic-block*)))
-      (setf (nth pos (basic-block-output-locals *basic-block*)) type)
-      (progn
-  (setf (basic-block-output-locals *basic-block*)
-        (append (basic-block-output-locals *basic-block*) (list nil)))
-  (smf-set pos type))))
-
-(defun smf-push (type)
-  (push type (basic-block-output-stack *basic-block*))
-  (when (or (eq type :long) (eq type :double))
-    (push :top (basic-block-output-stack *basic-block*))))
-
-(defun smf-pop ()
-  (pop (basic-block-output-stack *basic-block*)))
-
-(defun smf-popn (n)
-  (dotimes (i n)
-    (pop (basic-block-output-stack *basic-block*))))
-
-(defun smf-element-of (type)
-  (if (and (consp type) (eq (car type) :array-of))
-      (cdr type)
-      (cons :element-of type)))
-
-(defun smf-array-of (type)
-  (if (and (consp type) (eq (car type) :element-of))
-      (cdr type)
-      (cons :array-of type)))
-
-(define-opcode-effect aconst_null (smf-push :null))
-(define-opcode-effect iconst_m1 (smf-push :int))
-(define-opcode-effect iconst_0 (smf-push :int))
-(define-opcode-effect iconst_1 (smf-push :int))
-(define-opcode-effect iconst_2 (smf-push :int))
-(define-opcode-effect iconst_3 (smf-push :int))
-(define-opcode-effect iconst_4 (smf-push :int))
-(define-opcode-effect iconst_5 (smf-push :int))
-(define-opcode-effect lconst_0 (smf-push :long))
-(define-opcode-effect lconst_1 (smf-push :long))
-(define-opcode-effect fconst_0 (smf-push :float))
-(define-opcode-effect fconst_1 (smf-push :float))
-(define-opcode-effect fconst_2 (smf-push :float))
-(define-opcode-effect dconst_0 (smf-push :double))
-(define-opcode-effect dconst_1 (smf-push :double))
-(define-opcode-effect bipush (smf-push :int))
-(define-opcode-effect sipush (smf-push :int))
-(define-opcode-effect ldc (smf-push (car (instruction-args instruction))))
-(define-opcode-effect iload (smf-push :int))
-(define-opcode-effect lload (smf-push :long))
-(define-opcode-effect fload (smf-push :float))
-(define-opcode-effect dload (smf-push :double))
-(define-opcode-effect aload
-    (smf-push (smf-get (car (instruction-args instruction)))))
-(define-opcode-effect iload_0 (smf-push :int))
-(define-opcode-effect iload_1 (smf-push :int))
-(define-opcode-effect iload_2 (smf-push :int))
-(define-opcode-effect iload_3 (smf-push :int))
-(define-opcode-effect lload_0 (smf-push :long))
-(define-opcode-effect lload_1 (smf-push :long))
-(define-opcode-effect lload_2 (smf-push :long))
-(define-opcode-effect lload_3 (smf-push :long))
-(define-opcode-effect fload_0 (smf-push :float))
-(define-opcode-effect fload_1 (smf-push :float))
-(define-opcode-effect fload_2 (smf-push :float))
-(define-opcode-effect fload_3 (smf-push :float))
-(define-opcode-effect dload_0 (smf-push :double))
-(define-opcode-effect dload_1 (smf-push :double))
-(define-opcode-effect dload_2 (smf-push :double))
-(define-opcode-effect dload_3 (smf-push :double))
-#|(define-opcode-effect aload_0 42 1 1)
-(define-opcode-effect aload_1 43 1 1)
-(define-opcode-effect aload_2 44 1 1)
-(define-opcode-effect aload_3 45 1 1)|#
-(define-opcode-effect iaload (smf-popn 2) (smf-push :int))
-(define-opcode-effect laload (smf-popn 2) (smf-push :long))
-(define-opcode-effect faload (smf-popn 2) (smf-push :float))
-(define-opcode-effect daload (smf-popn 2) (smf-push :double))
-#+nil ;;until there's newarray
-(define-opcode-effect aaload
-         (progn
-     (smf-pop)
-     (smf-push (smf-element-of (smf-pop)))))
-(define-opcode-effect baload (smf-popn 2) (smf-push :int))
-(define-opcode-effect caload (smf-popn 2) (smf-push :int))
-(define-opcode-effect saload (smf-popn 2) (smf-push :int))
-
-(defun iaf-store-effect (instruction offset)
-  (declare (ignore offset))
-  (let ((t1 (smf-pop))
-    (arg (car (instruction-args instruction))))
-      (smf-set arg t1)
-      (when (> arg 0)
-  (let ((t2 (smf-get (1- arg))))
-    (when (or (eq t2 :long) (eq t2 :double))
-      (smf-set (1- arg) :top))))))
-
-(defun ld-store-effect (instruction offset)
-  (declare (ignore offset))
-  (smf-pop)
-  (let ((t1 (smf-pop))
-    (arg (car (instruction-args instruction))))
-      (smf-set arg t1)
-      (smf-set (1+ arg) :top)
-      (when (> arg 0)
-  (let ((t2 (smf-get (1- arg))))
-    (when (or (eq t2 :long) (eq t2 :double))
-      (smf-set (1- arg) :top))))))
-
-(define-opcode-effect istore iaf-store-effect)
-(define-opcode-effect lstore ld-store-effect)
-(define-opcode-effect fstore iaf-store-effect)
-(define-opcode-effect dstore ld-store-effect)
-(define-opcode-effect astore iaf-store-effect)
-#|(define-opcode istore_0 59 1 -1)
-(define-opcode istore_1 60 1 -1)
-(define-opcode istore_2 61 1 -1)
-(define-opcode istore_3 62 1 -1)
-(define-opcode lstore_0 63 1 -2)
-(define-opcode lstore_1 64 1 -2)
-(define-opcode lstore_2 65 1 -2)
-(define-opcode lstore_3 66 1 -2)
-(define-opcode fstore_0 67 1 nil)
-(define-opcode fstore_1 68 1 nil)
-(define-opcode fstore_2 69 1 nil)
-(define-opcode fstore_3 70 1 nil)
-(define-opcode dstore_0 71 1 nil)
-(define-opcode dstore_1 72 1 nil)
-(define-opcode dstore_2 73 1 nil)
-(define-opcode dstore_3 74 1 nil)
-(define-opcode astore_0 75 1 -1)|#
-;;TODO
-#|(define-opcode astore_1 76 1 -1)
-(define-opcode astore_2 77 1 -1)
-(define-opcode astore_3 78 1 -1)
-(define-opcode iastore 79 1 -3)
-(define-opcode lastore 80 1 -4)
-(define-opcode fastore 81 1 -3)
-(define-opcode dastore 82 1 -4)
-(define-opcode aastore 83 1 -3)
-(define-opcode bastore 84 1 nil)
-(define-opcode castore 85 1 nil)
-(define-opcode sastore 86 1 nil)
-(define-opcode pop 87 1 -1)
-(define-opcode pop2 88 1 -2)
-(define-opcode dup 89 1 1)
-(define-opcode dup_x1 90 1 1)
-(define-opcode dup_x2 91 1 1)
-(define-opcode dup2 92 1 2)
-(define-opcode dup2_x1 93 1 2)
-(define-opcode dup2_x2 94 1 2)
-(define-opcode swap 95 1 0)
-(define-opcode iadd 96 1 -1)
-(define-opcode ladd 97 1 -2)
-(define-opcode fadd 98 1 -1)
-(define-opcode dadd 99 1 -2)
-(define-opcode isub 100 1 -1)
-(define-opcode lsub 101 1 -2)
-(define-opcode fsub 102 1 -1)
-(define-opcode dsub 103 1 -2)
-(define-opcode imul 104 1 -1)
-(define-opcode lmul 105 1 -2)
-(define-opcode fmul 106 1 -1)
-(define-opcode dmul 107 1 -2)
-(define-opcode idiv 108 1 nil)
-(define-opcode ldiv 109 1 nil)
-(define-opcode fdiv 110 1 nil)
-(define-opcode ddiv 111 1 nil)
-(define-opcode irem 112 1 nil)
-(define-opcode lrem 113 1 nil)
-(define-opcode frem 114 1 nil)
-(define-opcode drem 115 1 nil)
-(define-opcode ineg 116 1 0)
-(define-opcode lneg 117 1 0)
-(define-opcode fneg 118 1 0)
-(define-opcode dneg 119 1 0)
-(define-opcode ishl 120 1 -1)
-(define-opcode lshl 121 1 -1)
-(define-opcode ishr 122 1 -1)
-(define-opcode lshr 123 1 -1)
-(define-opcode iushr 124 1 nil)
-(define-opcode lushr 125 1 nil)
-(define-opcode iand 126 1 -1)
-(define-opcode land 127 1 -2)
-(define-opcode ior 128 1 -1)
-(define-opcode lor 129 1 -2)
-(define-opcode ixor 130 1 -1)
-(define-opcode lxor 131 1 -2)
-(define-opcode iinc 132 3 0)
-(define-opcode i2l 133 1 1)
-(define-opcode i2f 134 1 0)
-(define-opcode i2d 135 1 1)
-(define-opcode l2i 136 1 -1)
-(define-opcode l2f 137 1 -1)
-(define-opcode l2d 138 1 0)
-(define-opcode f2i 139 1 nil)
-(define-opcode f2l 140 1 nil)
-(define-opcode f2d 141 1 1)
-(define-opcode d2i 142 1 nil)
-(define-opcode d2l 143 1 nil)
-(define-opcode d2f 144 1 -1)
-(define-opcode i2b 145 1 nil)
-(define-opcode i2c 146 1 nil)
-(define-opcode i2s 147 1 nil)
-(define-opcode lcmp 148 1 -3)
-(define-opcode fcmpl 149 1 -1)
-(define-opcode fcmpg 150 1 -1)
-(define-opcode dcmpl 151 1 -3)
-(define-opcode dcmpg 152 1 -3)
-(define-opcode ifeq 153 3 -1)
-(define-opcode ifne 154 3 -1)
-(define-opcode iflt 155 3 -1)
-(define-opcode ifge 156 3 -1)
-(define-opcode ifgt 157 3 -1)
-(define-opcode ifle 158 3 -1)
-(define-opcode if_icmpeq 159 3 -2)
-(define-opcode if_icmpne 160 3 -2)
-(define-opcode if_icmplt 161 3 -2)
-(define-opcode if_icmpge 162 3 -2)
-(define-opcode if_icmpgt 163 3 -2)
-(define-opcode if_icmple 164 3 -2)
-(define-opcode if_acmpeq 165 3 -2)
-(define-opcode if_acmpne 166 3 -2)
-(define-opcode goto 167 3 0)
-;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
-;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
-(define-opcode tableswitch 170 0 nil)
-(define-opcode lookupswitch 171 0 nil)
-(define-opcode ireturn 172 1 nil)
-(define-opcode lreturn 173 1 nil)
-(define-opcode freturn 174 1 nil)
-(define-opcode dreturn 175 1 nil)
-(define-opcode areturn 176 1 -1)
-(define-opcode return 177 1 0)
-(define-opcode getstatic 178 3 1)
-(define-opcode putstatic 179 3 -1)
-(define-opcode getfield 180 3 0)
-(define-opcode putfield 181 3 -2)
-(define-opcode invokevirtual 182 3 nil)
-(define-opcode invokespecial 183 3 nil)
-(define-opcode invokestatic 184 3 nil)
-(define-opcode invokeinterface 185 5 nil)
-(define-opcode unused 186 0 nil)
-(define-opcode new 187 3 1)
-(define-opcode newarray 188 2 nil)
-(define-opcode anewarray 189 3 0)
-(define-opcode arraylength 190 1 0)
-(define-opcode athrow 191 1 0)
-(define-opcode checkcast 192 3 0)
-(define-opcode instanceof 193 3 0)
-(define-opcode monitorenter 194 1 -1)
-(define-opcode monitorexit 195 1 -1)
-(define-opcode wide 196 0 nil)
-(define-opcode multianewarray 197 4 nil)
-(define-opcode ifnull 198 3 -1)
-(define-opcode ifnonnull 199 3 nil)
-(define-opcode goto_w 200 5 nil)
-;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
-(define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
-;; (define-opcode push-value 203 nil 1)
-;; (define-opcode store-value 204 nil -1)
-(define-opcode clear-values 205 0 0)  ;; virtual: does not exist in the JVM
-;;(define-opcode var-ref 206 0 0)|#
+  :todo)
 
 #|

branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

@@ -32 +32 @@
 (in-package #:jvm)
 
-
 ;;    OPCODES
 
@@ -39 +38 @@
 (defconst *opcodes* (make-hash-table :test 'equalp))
 
-(defstruct jvm-opcode name number size stack-effect)
-
-(defun %define-opcode (name number size stack-effect)
+(defstruct jvm-opcode name number size stack-effect effect-function)
+
+(defun %define-opcode (name number size stack-effect effect-function)
   (declare (type fixnum number size))
   (let* ((name (string name))
@@ -47 +46 @@
                                   :number number
                                   :size size
-                                  :stack-effect stack-effect)))
+                                  :stack-effect stack-effect
+          :effect-function effect-function)))
      (setf (svref *opcode-table* number) opcode)
      (setf (gethash name *opcodes*) opcode)
      (setf (gethash number *opcodes*) opcode)))
 
-(defmacro define-opcode (name number size stack-effect)
-  `(%define-opcode ',name ,number ,size ,stack-effect))
+(defmacro define-opcode (name number size stack-effect &body body)
+  `(%define-opcode ',name ,number ,size ,stack-effect
+       ,(if (and (symbolp (car body)) (null (cdr body)))
+      (if (null (car body))
+          #'identity
+          `(function ,(car body)))
+      `(lambda (instruction)
+         (declare (ignorable instruction))
+         ,@body))))
 
 ;; name number size stack-effect (nil if unknown)
 (define-opcode nop 0 1 0)
-(define-opcode aconst_null 1 1 1)
-(define-opcode iconst_m1 2 1 1)
-(define-opcode iconst_0 3 1 1)
-(define-opcode iconst_1 4 1 1)
-(define-opcode iconst_2 5 1 1)
-(define-opcode iconst_3 6 1 1)
-(define-opcode iconst_4 7 1 1)
-(define-opcode iconst_5 8 1 1)
-(define-opcode lconst_0 9 1 2)
-(define-opcode lconst_1 10 1 2)
-(define-opcode fconst_0 11 1 1)
-(define-opcode fconst_1 12 1 1)
-(define-opcode fconst_2 13 1 1)
-(define-opcode dconst_0 14 1 2)
-(define-opcode dconst_1 15 1 2)
-(define-opcode bipush 16 2 1)
-(define-opcode sipush 17 3 1)
-(define-opcode ldc 18 2 1)
-(define-opcode ldc_w 19 3 1)
-(define-opcode ldc2_w 20 3 2)
-(define-opcode iload 21 2 1)
-(define-opcode lload 22 2 2)
-(define-opcode fload 23 2 nil)
-(define-opcode dload 24 2 nil)
-(define-opcode aload 25 2 1)
-(define-opcode iload_0 26 1 1)
-(define-opcode iload_1 27 1 1)
-(define-opcode iload_2 28 1 1)
-(define-opcode iload_3 29 1 1)
-(define-opcode lload_0 30 1 2)
-(define-opcode lload_1 31 1 2)
-(define-opcode lload_2 32 1 2)
-(define-opcode lload_3 33 1 2)
-(define-opcode fload_0 34 1 nil)
-(define-opcode fload_1 35 1 nil)
-(define-opcode fload_2 36 1 nil)
-(define-opcode fload_3 37 1 nil)
-(define-opcode dload_0 38 1 nil)
-(define-opcode dload_1 39 1 nil)
-(define-opcode dload_2 40 1 nil)
-(define-opcode dload_3 41 1 nil)
-(define-opcode aload_0 42 1 1)
-(define-opcode aload_1 43 1 1)
-(define-opcode aload_2 44 1 1)
-(define-opcode aload_3 45 1 1)
-(define-opcode iaload 46 1 -1)
-(define-opcode laload 47 1 0)
-(define-opcode faload 48 1 -1)
-(define-opcode daload 49 1 0)
-(define-opcode aaload 50 1 -1)
-(define-opcode baload 51 1 nil)
-(define-opcode caload 52 1 nil)
-(define-opcode saload 53 1 nil)
-(define-opcode istore 54 2 -1)
-(define-opcode lstore 55 2 -2)
-(define-opcode fstore 56 2 nil)
-(define-opcode dstore 57 2 nil)
-(define-opcode astore 58 2 -1)
-(define-opcode istore_0 59 1 -1)
-(define-opcode istore_1 60 1 -1)
-(define-opcode istore_2 61 1 -1)
-(define-opcode istore_3 62 1 -1)
-(define-opcode lstore_0 63 1 -2)
-(define-opcode lstore_1 64 1 -2)
-(define-opcode lstore_2 65 1 -2)
-(define-opcode lstore_3 66 1 -2)
-(define-opcode fstore_0 67 1 nil)
-(define-opcode fstore_1 68 1 nil)
-(define-opcode fstore_2 69 1 nil)
-(define-opcode fstore_3 70 1 nil)
-(define-opcode dstore_0 71 1 nil)
-(define-opcode dstore_1 72 1 nil)
-(define-opcode dstore_2 73 1 nil)
-(define-opcode dstore_3 74 1 nil)
-(define-opcode astore_0 75 1 -1)
-(define-opcode astore_1 76 1 -1)
-(define-opcode astore_2 77 1 -1)
-(define-opcode astore_3 78 1 -1)
-(define-opcode iastore 79 1 -3)
-(define-opcode lastore 80 1 -4)
-(define-opcode fastore 81 1 -3)
-(define-opcode dastore 82 1 -4)
-(define-opcode aastore 83 1 -3)
-(define-opcode bastore 84 1 nil)
-(define-opcode castore 85 1 nil)
-(define-opcode sastore 86 1 nil)
-(define-opcode pop 87 1 -1)
-(define-opcode pop2 88 1 -2)
-(define-opcode dup 89 1 1)
-(define-opcode dup_x1 90 1 1)
-(define-opcode dup_x2 91 1 1)
-(define-opcode dup2 92 1 2)
-(define-opcode dup2_x1 93 1 2)
-(define-opcode dup2_x2 94 1 2)
-(define-opcode swap 95 1 0)
-(define-opcode iadd 96 1 -1)
-(define-opcode ladd 97 1 -2)
-(define-opcode fadd 98 1 -1)
-(define-opcode dadd 99 1 -2)
-(define-opcode isub 100 1 -1)
-(define-opcode lsub 101 1 -2)
-(define-opcode fsub 102 1 -1)
-(define-opcode dsub 103 1 -2)
-(define-opcode imul 104 1 -1)
-(define-opcode lmul 105 1 -2)
-(define-opcode fmul 106 1 -1)
-(define-opcode dmul 107 1 -2)
-(define-opcode idiv 108 1 nil)
-(define-opcode ldiv 109 1 nil)
-(define-opcode fdiv 110 1 nil)
-(define-opcode ddiv 111 1 nil)
-(define-opcode irem 112 1 nil)
-(define-opcode lrem 113 1 nil)
-(define-opcode frem 114 1 nil)
-(define-opcode drem 115 1 nil)
+(define-opcode aconst_null 1 1 1 (smf-push :null))
+(define-opcode iconst_m1 2 1 1 (smf-push :int))
+(define-opcode iconst_0 3 1 1 (smf-push :int))
+(define-opcode iconst_1 4 1 1 (smf-push :int))
+(define-opcode iconst_2 5 1 1 (smf-push :int))
+(define-opcode iconst_3 6 1 1 (smf-push :int))
+(define-opcode iconst_4 7 1 1 (smf-push :int))
+(define-opcode iconst_5 8 1 1 (smf-push :int))
+(define-opcode lconst_0 9 1 2 (smf-push :long))
+(define-opcode lconst_1 10 1 2 (smf-push :long))
+(define-opcode fconst_0 11 1 1 (smf-push :float))
+(define-opcode fconst_1 12 1 1 (smf-push :float))
+(define-opcode fconst_2 13 1 1 (smf-push :float))
+(define-opcode dconst_0 14 1 2 (smf-push :double))
+(define-opcode dconst_1 15 1 2 (smf-push :duble))
+(define-opcode bipush 16 2 1 (smf-push :int))
+(define-opcode sipush 17 3 1 (smf-push :int))
+(define-opcode ldc 18 2 1 (smf-push (car (instruction-args instruction))))
+(define-opcode ldc_w 19 3 1 (smf-push (car (instruction-args instruction))))
+(define-opcode ldc2_w 20 3 2
+  (smf-push (car (instruction-args instruction)))
+  (smf-push :top))
+(define-opcode iload 21 2 1 (smf-push :int))
+(define-opcode lload 22 2 2 (smf-push :long))
+(define-opcode fload 23 2 nil (smf-push :float))
+(define-opcode dload 24 2 nil (smf-push :double))
+(define-opcode aload 25 2 1
+  (smf-push (smf-get (car (instruction-args instruction)))))
+(define-opcode iload_0 26 1 1 (smf-push :int))
+(define-opcode iload_1 27 1 1 (smf-push :int))
+(define-opcode iload_2 28 1 1 (smf-push :int))
+(define-opcode iload_3 29 1 1 (smf-push :int))
+(define-opcode lload_0 30 1 2 (smf-push :long))
+(define-opcode lload_1 31 1 2 (smf-push :long))
+(define-opcode lload_2 32 1 2 (smf-push :long))
+(define-opcode lload_3 33 1 2 (smf-push :long))
+(define-opcode fload_0 34 1 nil (smf-push :float))
+(define-opcode fload_1 35 1 nil (smf-push :float))
+(define-opcode fload_2 36 1 nil (smf-push :float))
+(define-opcode fload_3 37 1 nil (smf-push :float))
+(define-opcode dload_0 38 1 nil (smf-push :double))
+(define-opcode dload_1 39 1 nil (smf-push :double))
+(define-opcode dload_2 40 1 nil (smf-push :double))
+(define-opcode dload_3 41 1 nil (smf-push :double))
+(define-opcode aload_0 42 1 1 (smf-push (smf-get 0)))
+(define-opcode aload_1 43 1 1 (smf-push (smf-get 1)))
+(define-opcode aload_2 44 1 1 (smf-push (smf-get 2)))
+(define-opcode aload_3 45 1 1 (smf-push (smf-get 3)))
+(define-opcode iaload 46 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode laload 47 1 0 (smf-popn 2) (smf-push :long))
+(define-opcode faload 48 1 -1 (smf-popn 2) (smf-push :float))
+(define-opcode daload 49 1 0 (smf-popn 2) (smf-push :double))
+(define-opcode aaload 50 1 -1
+  (progn
+    (smf-pop)
+    (smf-push (smf-element-of (smf-pop)))))
+(define-opcode baload 51 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode caload 52 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode saload 53 1 nil (smf-popn 2) (smf-push :int))
+
+(defun iaf-store-effect (arg)
+  (let ((t1 (smf-pop)))
+    (sys::%format t "iaf-store ~S~%" (list arg t1))
+    (smf-set arg t1)
+    (when (> arg 0)
+      (let ((t2 (smf-get (1- arg))))
+  (when (or (eq t2 :long) (eq t2 :double))
+    (smf-set (1- arg) :top))))))
+
+(defun ld-store-effect (arg)
+  (smf-pop)
+  (let ((t1 (smf-pop)))
+    (smf-set arg t1)
+    (smf-set (1+ arg) :top)
+    (when (> arg 0)
+      (let ((t2 (smf-get (1- arg))))
+  (when (or (eq t2 :long) (eq t2 :double))
+    (smf-set (1- arg) :top))))))
+
+(define-opcode istore 54 2 -1
+  (iaf-store-effect (car (instruction-args instruction))))
+(define-opcode lstore 55 2 -2
+  (ld-store-effect (car (instruction-args instruction))))
+(define-opcode fstore 56 2 nil
+  (iaf-store-effect (car (instruction-args instruction))))
+(define-opcode dstore 57 2 nil
+  (ld-store-effect (car (instruction-args instruction))))
+(define-opcode astore 58 2 -1
+  (iaf-store-effect (car (instruction-args instruction))))
+(define-opcode istore_0 59 1 -1 (iaf-store-effect 0))
+(define-opcode istore_1 60 1 -1 (iaf-store-effect 1))
+(define-opcode istore_2 61 1 -1 (iaf-store-effect 2))
+(define-opcode istore_3 62 1 -1 (iaf-store-effect 3))
+(define-opcode lstore_0 63 1 -2 (ld-store-effect 0))
+(define-opcode lstore_1 64 1 -2 (ld-store-effect 1))
+(define-opcode lstore_2 65 1 -2 (ld-store-effect 2))
+(define-opcode lstore_3 66 1 -2 (ld-store-effect 3))
+(define-opcode fstore_0 67 1 nil (iaf-store-effect 0))
+(define-opcode fstore_1 68 1 nil (iaf-store-effect 1))
+(define-opcode fstore_2 69 1 nil (iaf-store-effect 2))
+(define-opcode fstore_3 70 1 nil (iaf-store-effect 3))
+(define-opcode dstore_0 71 1 nil (dl-store-effect 0))
+(define-opcode dstore_1 72 1 nil (dl-store-effect 1))
+(define-opcode dstore_2 73 1 nil (dl-store-effect 2))
+(define-opcode dstore_3 74 1 nil (dl-store-effect 3))
+(define-opcode astore_0 75 1 -1 (iaf-store-effect 0))
+(define-opcode astore_1 76 1 -1 (iaf-store-effect 1))
+(define-opcode astore_2 77 1 -1 (iaf-store-effect 2))
+(define-opcode astore_3 78 1 -1 (iaf-store-effect 3))
+(define-opcode iastore 79 1 -3 (smf-popn 3))
+(define-opcode lastore 80 1 -4 (smf-popn 4))
+(define-opcode fastore 81 1 -3 (smf-popn 3))
+(define-opcode dastore 82 1 -4 (smf-popn 4))
+(define-opcode aastore 83 1 -3 (smf-popn 3))
+(define-opcode bastore 84 1 nil (smf-popn 3))
+(define-opcode castore 85 1 nil (smf-popn 3))
+(define-opcode sastore 86 1 nil (smf-popn 3))
+(define-opcode pop 87 1 -1 (smf-pop))
+(define-opcode pop2 88 1 -2 (smf-popn 2))
+(define-opcode dup 89 1 1
+  (let ((t1 (smf-pop)))
+    (smf-push t1)
+    (smf-push t1)))
+(define-opcode dup_x1 90 1 1
+  (let ((t1 (smf-pop)) (t2 (smf-pop)))
+    (smf-push t1)
+    (smf-push t2)
+    (smf-push t1)))
+(define-opcode dup_x2 91 1 1
+  (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop)))
+    (smf-push t1)
+    (smf-push t3)
+    (smf-push t2)
+    (smf-push t1)))
+(define-opcode dup2 92 1 2
+  (let ((t1 (smf-pop)) (t2 (smf-pop)))
+    (smf-push t2)
+    (smf-push t1)
+    (smf-push t2)
+    (smf-push t1)))
+(define-opcode dup2_x1 93 1 2
+  (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop)))
+    (smf-push t2)
+    (smf-push t1)
+    (smf-push t3)
+    (smf-push t2)
+    (smf-push t1)))
+(define-opcode dup2_x2 94 1 2
+  (let ((t1 (smf-pop)) (t2 (smf-pop))
+  (t3 (smf-pop)) (t4 (smf-pop)))
+    (smf-push t2)
+    (smf-push t1)
+    (smf-push t4)
+    (smf-push t3)
+    (smf-push t2)
+    (smf-push t1)))
+(define-opcode swap 95 1 0
+  (let ((t1 (smf-pop)) (t2 (smf-pop)))
+    (smf-push t1)
+    (smf-push t2)))
+(define-opcode iadd 96 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode ladd 97 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode fadd 98 1 -1 (smf-popn 2) (smf-push :float))
+(define-opcode dadd 99 1 -2 (smf-popn 4) (smf-push :double))
+(define-opcode isub 100 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lsub 101 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode fsub 102 1 -1 (smf-popn 2) (smf-push :float))
+(define-opcode dsub 103 1 -2 (smf-popn 4) (smf-push :double))
+(define-opcode imul 104 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lmul 105 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode fmul 106 1 -1 (smf-popn 2) (smf-push :float))
+(define-opcode dmul 107 1 -2 (smf-popn 4) (smf-push :double))
+(define-opcode idiv 108 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode ldiv 109 1 nil (smf-popn 4) (smf-push :long))
+(define-opcode fdiv 110 1 nil (smf-popn 2) (smf-push :float))
+(define-opcode ddiv 111 1 nil (smf-popn 4) (smf-push :double))
+(define-opcode irem 112 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode lrem 113 1 nil (smf-popn 4) (smf-push :long))
+(define-opcode frem 114 1 nil (smf-popn 2) (smf-push :float))
+(define-opcode drem 115 1 nil (smf-popn 4) (smf-push :double))
 (define-opcode ineg 116 1 0)
 (define-opcode lneg 117 1 0)
 (define-opcode fneg 118 1 0)
 (define-opcode dneg 119 1 0)
-(define-opcode ishl 120 1 -1)
-(define-opcode lshl 121 1 -1)
-(define-opcode ishr 122 1 -1)
-(define-opcode lshr 123 1 -1)
-(define-opcode iushr 124 1 nil)
-(define-opcode lushr 125 1 nil)
-(define-opcode iand 126 1 -1)
-(define-opcode land 127 1 -2)
-(define-opcode ior 128 1 -1)
-(define-opcode lor 129 1 -2)
-(define-opcode ixor 130 1 -1)
-(define-opcode lxor 131 1 -2)
-(define-opcode iinc 132 3 0)
-(define-opcode i2l 133 1 1)
-(define-opcode i2f 134 1 0)
-(define-opcode i2d 135 1 1)
-(define-opcode l2i 136 1 -1)
-(define-opcode l2f 137 1 -1)
-(define-opcode l2d 138 1 0)
-(define-opcode f2i 139 1 nil)
-(define-opcode f2l 140 1 nil)
-(define-opcode f2d 141 1 1)
-(define-opcode d2i 142 1 nil)
-(define-opcode d2l 143 1 nil)
-(define-opcode d2f 144 1 -1)
+(define-opcode ishl 120 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lshl 121 1 -1 (smf-popn 3) (smf-push :long))
+(define-opcode ishr 122 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lshr 123 1 -1 (smf-popn 3) (smf-push :long))
+(define-opcode iushr 124 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode lushr 125 1 nil (smf-popn 3) (smf-push :long))
+(define-opcode iand 126 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode land 127 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode ior 128 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lor 129 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode ixor 130 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode lxor 131 1 -2 (smf-popn 4) (smf-push :long))
+(define-opcode iinc 132 3 0
+  (sys::%format t "AAAAAAAAAAAA ~A~%" (instruction-args instruction))
+  (smf-set (car (instruction-args instruction)) :int))
+(define-opcode i2l 133 1 1 (smf-pop) (smf-push :long))
+(define-opcode i2f 134 1 0 (smf-pop) (smf-push :float))
+(define-opcode i2d 135 1 1 (smf-pop) (smf-push :double))
+(define-opcode l2i 136 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode l2f 137 1 -1 (smf-popn 2) (smf-push :float))
+(define-opcode l2d 138 1 0 (smf-popn 2) (smf-push :double))
+(define-opcode f2i 139 1 nil (smf-pop) (smf-push :int))
+(define-opcode f2l 140 1 nil (smf-pop) (smf-push :long))
+(define-opcode f2d 141 1 1 (smf-pop) (smf-push :double))
+(define-opcode d2i 142 1 nil (smf-popn 2) (smf-push :int))
+(define-opcode d2l 143 1 nil (smf-popn 2) (smf-push :long))
+(define-opcode d2f 144 1 -1 (smf-popn 2) (smf-push :float))
 (define-opcode i2b 145 1 nil)
 (define-opcode i2c 146 1 nil)
 (define-opcode i2s 147 1 nil)
-(define-opcode lcmp 148 1 -3)
-(define-opcode fcmpl 149 1 -1)
-(define-opcode fcmpg 150 1 -1)
-(define-opcode dcmpl 151 1 -3)
-(define-opcode dcmpg 152 1 -3)
-(define-opcode ifeq 153 3 -1)
-(define-opcode ifne 154 3 -1)
-(define-opcode iflt 155 3 -1)
-(define-opcode ifge 156 3 -1)
-(define-opcode ifgt 157 3 -1)
-(define-opcode ifle 158 3 -1)
-(define-opcode if_icmpeq 159 3 -2)
-(define-opcode if_icmpne 160 3 -2)
-(define-opcode if_icmplt 161 3 -2)
-(define-opcode if_icmpge 162 3 -2)
-(define-opcode if_icmpgt 163 3 -2)
-(define-opcode if_icmple 164 3 -2)
-(define-opcode if_acmpeq 165 3 -2)
-(define-opcode if_acmpne 166 3 -2)
+(define-opcode lcmp 148 1 -3 (smf-popn 4) (smf-push :int))
+(define-opcode fcmpl 149 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode fcmpg 150 1 -1 (smf-popn 2) (smf-push :int))
+(define-opcode dcmpl 151 1 -3 (smf-popn 4) (smf-push :int))
+(define-opcode dcmpg 152 1 -3 (smf-popn 4) (smf-push :int))
+(define-opcode ifeq 153 3 -1 (smf-pop))
+(define-opcode ifne 154 3 -1 (smf-pop))
+(define-opcode iflt 155 3 -1 (smf-pop))
+(define-opcode ifge 156 3 -1 (smf-pop))
+(define-opcode ifgt 157 3 -1 (smf-pop))
+(define-opcode ifle 158 3 -1 (smf-pop))
+(define-opcode if_icmpeq 159 3 -2 (smf-popn 2))
+(define-opcode if_icmpne 160 3 -2 (smf-popn 2))
+(define-opcode if_icmplt 161 3 -2 (smf-popn 2))
+(define-opcode if_icmpge 162 3 -2 (smf-popn 2))
+(define-opcode if_icmpgt 163 3 -2 (smf-popn 2))
+(define-opcode if_icmple 164 3 -2 (smf-popn 2))
+(define-opcode if_acmpeq 165 3 -2 (smf-popn 2))
+(define-opcode if_acmpne 166 3 -2 (smf-popn 2))
 (define-opcode goto 167 3 0)
 ;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
 ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
-(define-opcode tableswitch 170 0 nil)
-(define-opcode lookupswitch 171 0 nil)
-(define-opcode ireturn 172 1 nil)
-(define-opcode lreturn 173 1 nil)
-(define-opcode freturn 174 1 nil)
-(define-opcode dreturn 175 1 nil)
-(define-opcode areturn 176 1 -1)
+(define-opcode tableswitch 170 0 nil (smf-pop))
+(define-opcode lookupswitch 171 0 nil (smf-pop))
+(define-opcode ireturn 172 1 nil (smf-pop))
+(define-opcode lreturn 173 1 nil (smf-popn 2))
+(define-opcode freturn 174 1 nil (smf-pop))
+(define-opcode dreturn 175 1 nil (smf-popn 2))
+(define-opcode areturn 176 1 -1 (smf-pop))
 (define-opcode return 177 1 0)
-(define-opcode getstatic 178 3 1)
-(define-opcode putstatic 179 3 -1)
-(define-opcode getfield 180 3 0)
-(define-opcode putfield 181 3 -2)
-(define-opcode invokevirtual 182 3 nil)
-(define-opcode invokespecial 183 3 nil)
-(define-opcode invokestatic 184 3 nil)
-(define-opcode invokeinterface 185 5 nil)
-(define-opcode unused 186 0 nil)
-(define-opcode new 187 3 1)
-(define-opcode newarray 188 2 nil)
-(define-opcode anewarray 189 3 0)
-(define-opcode arraylength 190 1 0)
-(define-opcode athrow 191 1 0)
-(define-opcode checkcast 192 3 0)
-(define-opcode instanceof 193 3 0)
-(define-opcode monitorenter 194 1 -1)
-(define-opcode monitorexit 195 1 -1)
+(define-opcode getstatic 178 3 1
+  (sys::%format t "GETSTATIC ~A~%" (third (instruction-args instruction)))
+  ;;TODO!!!
+  (smf-push (third (instruction-args instruction))))
+(define-opcode putstatic 179 3 -1
+  (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction)))
+  (smf-popt (third (instruction-args instruction))))
+(define-opcode getfield 180 3 0
+  (smf-pop)
+  (smf-push (third (instruction-args instruction))))
+(define-opcode putfield 181 3 -2
+  (smf-popt (third (instruction-args instruction)))
+  (smf-pop))
+(define-opcode invokevirtual 182 3 nil
+  (smf-popt (third (instruction-args instruction)))
+  (smf-pop)
+  (smf-push (third (instruction-args instruction))))
+(define-opcode invokespecial 183 3 nil
+  (smf-popt (third (instruction-args instruction)))
+  (smf-pop)
+  (smf-push (third (instruction-args instruction))))
+(define-opcode invokestatic 184 3 nil
+  (sys::%format t "invokestatic ~S~%" (instruction-args instruction))
+  (smf-popt (third (instruction-args instruction)))
+  (smf-push (third (instruction-args instruction))))
+(define-opcode invokeinterface 185 5 nil
+  (smf-popt (third (instruction-args instruction)))
+  (smf-pop)
+  (smf-push (third (instruction-args instruction))))
+(define-opcode invokedynamic 186 0 nil
+  (smf-popt (second (instruction-args instruction)))
+  (smf-push (second (instruction-args instruction))))
+(define-opcode new 187 3 1
+  (smf-push (first (instruction-args instruction))))
+(define-opcode newarray 188 2 nil
+  (smf-pop)
+  (smf-push `(:array-of ,(first (instruction-args instruction)))))
+(define-opcode anewarray 189 3 0
+  (smf-pop)
+  (smf-push `(:array-of ,(first (instruction-args instruction)))))
+(define-opcode arraylength 190 1 0
+  (smf-pop)
+  (smf-push :int))
+(define-opcode athrow 191 1 0 (smf-pop))
+(define-opcode checkcast 192 3 0
+  (smf-pop)
+  (smf-push (first (instruction-args instruction))))
+(define-opcode instanceof 193 3 0
+  (smf-pop)
+  (smf-push :int))
+(define-opcode monitorenter 194 1 -1 (smf-pop))
+(define-opcode monitorexit 195 1 -1 (smf-pop))
 (define-opcode wide 196 0 nil)
 (define-opcode multianewarray 197 4 nil)
-(define-opcode ifnull 198 3 -1)
-(define-opcode ifnonnull 199 3 nil)
+(define-opcode ifnull 198 3 -1 (smf-pop))
+(define-opcode ifnonnull 199 3 nil (smf-pop))
 (define-opcode goto_w 200 5 nil)
 ;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
@@ -279 +387 @@
         (error "Unknown opcode ~S." opcode-name))))
 
+
 (declaim (ftype (function (t) fixnum) opcode-size))
 (defun opcode-size (opcode-number)
@@ -290 +399 @@
   (jvm-opcode-stack-effect (svref *opcode-table* opcode-number)))
 
-
-
+(declaim (ftype (function (t) t) opcode-effect-function))
+(defun opcode-effect-function (opcode-number)
+  (declare (optimize speed))
+  (jvm-opcode-effect-function (svref *opcode-table* opcode-number)))
+
+;;Stack map table functions
+(defun smf-get (pos)
+  (or (nth pos *code-locals*)
+      (sys::%format t "Locals inconsistency: get ~A but locals are ~A~%" ;;TODO error
+        pos *code-locals*)))
+
+(defun smf-set (pos type)
+  (if (< pos (length *code-locals*))
+      (setf (nth pos *code-locals*) type)
+      (progn
+  (setf *code-locals*
+        (append *code-locals* (list nil)))
+  (smf-set pos type))))
+
+(defun smf-push (type)
+  (push type *code-stack*)
+  (when (or (eq type :long) (eq type :double))
+    (push :top *code-stack)))
+
+(defun smf-pop ()
+  ;(sys::%format t "smf-pop ~A~%" *code-stack*)
+  (pop *code-stack*))
+
+(defun smf-popt (type)
+  (declare (ignore type)) ;TODO
+  (pop *code-stack*))
+
+(defun smf-popn (n)
+  (dotimes (i n)
+    (pop *code-stack*)))
+
+(defun smf-element-of (type)
+  (if (and (consp type) (eq (car type) :array-of))
+      (cdr type)
+      (cons :element-of type)))
+
+(defun smf-array-of (type)
+  (if (and (consp type) (eq (car type) :element-of))
+      (cdr type)
+      (cons :array-of type)))
 
 ;;   INSTRUCTION
@@ -300 +452 @@
   stack
   depth
-  wide)
+  wide
+  input-locals
+  input-stack
+  output-locals
+  output-stack
+  ;;the calculated offset of the instruction
+  offset)
 
 (defun make-instruction (opcode args)
@@ -308 +466 @@
     (when (memq :wide-prefix args)
       (setf (inst-wide inst) t))
+    (setf (instruction-input-locals inst) *code-locals*)
+    (setf (instruction-input-stack inst) *code-stack*)
     inst))
 
@@ -341 +501 @@
 ;; our only user and we'll hard-code the use of *code*.
 (defvar *code* nil)
+(defvar *code-locals* nil)
+(defvar *code-stack* nil)
 
 (defknown %%emit * t)
@@ -361 +523 @@
              (symbolp (cadr instr)))
     (setf instr (opcode-number (cadr instr))))
-  (if (fixnump instr)
-      `(%%emit ,instr ,@args)
-      `(%emit ,instr ,@args)))
+  (let ((instruction (gensym)))
+    `(let ((,instruction
+      ,(if (fixnump instr)
+     `(%%emit ,instr ,@args)
+     `(%emit ,instr ,@args))))
+       ;(sys::%format t "EMIT ~S ~S~%" ',instr ',args)
+       (funcall (opcode-effect-function (instruction-opcode ,instruction))
+    ,instruction)
+       (setf (instruction-output-locals ,instruction) *code-locals*)
+       (setf (instruction-output-stack ,instruction) *code-stack*)
+       ,instruction)))
 
 
@@ -396 +566 @@
          (inline branch-p))
 (defun branch-p (opcode)
-;;  (declare (optimize speed))
-;;  (declare (type '(integer 0 255) opcode))
+  (declare (optimize speed))
+  (declare (type '(integer 0 255) opcode))
   (or (<= 153 opcode 167)
       (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w

branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -125 +125 @@
   lambda-name
   lambda-list ; as advertised
-  static-code
+  static-initializer
+  constructor
   objects ;; an alist of externalized objects and their field names
   (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
@@ -164 +165 @@
                                             :lambda-name lambda-name
                                             :lambda-list lambda-list
-                                            :access-flags '(:public :final))))
+                                            :access-flags '(:public :final)))
+   (static-initializer (make-method :static-initializer
+            :void nil :flags '(:public :static)))
+   (constructor (make-method :constructor :void nil
+           :flags '(:public))))
+
+    (setf (abcl-class-file-static-initializer class-file) static-initializer)
+    (class-add-method class-file static-initializer)
+
+    (setf (abcl-class-file-constructor class-file) constructor)
+    (class-add-method class-file constructor)
+
     (when *file-compilation*
       (let ((source-attribute
@@ -177 +189 @@
             (*class-file*           ,var)
             (*pool*                 (abcl-class-file-constants ,var))
-            (*static-code*          (abcl-class-file-static-code ,var))
             (*externalized-objects* (abcl-class-file-objects ,var))
             (*declared-functions*   (abcl-class-file-functions ,var)))
        (progn ,@body)
-       (setf (abcl-class-file-static-code ,var)  *static-code*
-             (abcl-class-file-objects ,var)      *externalized-objects*
+       (setf (abcl-class-file-objects ,var)      *externalized-objects*
              (abcl-class-file-functions ,var)    *declared-functions*))))