[armedbear-cvs] r12983 - branches/invokedynamic/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Mon Oct 25 22:17:31 UTC 2010
Author: astalla
Date: Mon Oct 25 18:17:28 2010
New Revision: 12983
Log:
[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.
Modified:
branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Oct 25 18:17:28 2010
@@ -796,150 +796,136 @@
(defun emit-read-from-string (object)
(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)
- , at 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)
+ , at 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)
"Finalizes the `class' and writes the result to `stream'.
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))
@@ -1106,8 +1092,8 @@
the value of the object can be loaded. Objects may be coalesced based
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
;; - instead of returning the name of the field - returns the type
@@ -1137,23 +1123,23 @@
(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))
(emit-invokestatic +lisp+ "recall"
(list +java-string+) +lisp-object+)
(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)
(when cast
@@ -1183,30 +1169,26 @@
(declare-object-as-string symbol)
(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)
(defun declare-setf-function (name)
@@ -1218,17 +1200,17 @@
(declare-with-hashtable
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)))))
(defknown declare-object-as-string (t) string)
@@ -1241,44 +1223,38 @@
;; The solution is to rewrite externalize-object to
;; 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))
(declaim (ftype (function (t) string) declare-object))
@@ -1290,14 +1266,14 @@
(let ((g (symbol-name (gensym "OBJ"))))
;; 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)
(defun compile-constant (form target representation)
@@ -3823,6 +3799,7 @@
:element-type '(unsigned-byte 8)
:if-exists :supersede)))
(with-class-file class-file
+ (make-constructor class-file)
(let ((*current-compiland* compiland))
(with-saved-compiler-policy
(p2-compiland compiland)
@@ -6875,6 +6852,8 @@
(method (make-method "execute" +lisp-object+ arg-types
: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* ())
(*register* 1) ;; register 0: "this" pointer
@@ -6883,7 +6862,8 @@
(*thread* nil)
(*initialize-thread-var* nil)
- (label-START (gensym)))
+ (label-START (gensym))
+ prologue)
(class-add-method class-file method)
(when (fixnump *source-line-number*)
@@ -6896,6 +6876,36 @@
(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*
(setf (compiland-argument-register compiland) (allocate-register)))
@@ -7039,7 +7049,7 @@
(check-for-unused-variables (compiland-arg-vars compiland))
;; Go back and fill in prologue.
- (let ((code *code*))
+ #+nil (let ((code *code*))
(setf *code* ())
(let ((arity (compiland-arity compiland)))
(when arity
@@ -7066,6 +7076,8 @@
(or (memq '&OPTIONAL args) (memq '&KEY args)))
(maybe-initialize-thread-var))
(setf *code* (nconc code *code*)))
+
+ (setf *code* (nconc prologue *code*))
(setf (abcl-class-file-superclass class-file)
(if (or *hairy-arglist-p*
@@ -7076,8 +7088,6 @@
(setf (abcl-class-file-lambda-list class-file) args)
(setf (code-max-locals code) *registers-allocated*)
(setf (code-code code) *code*))
-
-
t)
(defun p2-with-inline-code (form target representation)
@@ -7122,6 +7132,7 @@
;; Pass 2.
(with-class-file (compiland-class-file compiland)
+ (make-constructor *class-file*)
(with-saved-compiler-policy
(p2-compiland compiland)
;; (finalize-class-file (compiland-class-file compiland))
Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original)
+++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Oct 25 18:17:28 2010
@@ -291,27 +291,27 @@
(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))
+ (%make-constant-member-ref 9 index class name/type))
-(defun make-constant-method-ref (index class-index name/type-index)
+(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))
+ (%make-constant-member-ref 10 index class name/type))
-(defun make-constant-interface-method-ref (index class-index name/type-index)
+(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
make-constant-string (index value-index))
@@ -354,14 +354,14 @@
(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))
(:include constant
@@ -395,8 +395,8 @@
`type' is a field-type (see `internal-field-type')"
(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))
(push entry (pool-entries-list pool)))
@@ -410,8 +410,8 @@
and return type. `class' is an instance of `class-name'."
(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))
(push entry (pool-entries-list pool)))
@@ -424,8 +424,8 @@
See `pool-add-method-ref' for remarks."
(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)
(gethash (acons name type class) (pool-entries pool)) entry))
@@ -491,8 +491,8 @@
(apply #'descriptor type)
(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))
(push entry (pool-entries-list pool)))
@@ -733,11 +733,11 @@
(write-u4 (logand (constant-double/long-value entry) #xFFFFffff)
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))
(8 ; string
@@ -757,10 +757,10 @@
((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
((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))))))
@@ -847,8 +847,7 @@
access-flags
name
descriptor
- attributes
- initial-locals)
+ attributes)
(defun map-method-name (name)
@@ -882,9 +881,7 @@
returning the created attribute."
(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)
"Ensures the existence of a 'Code' attribute for the method,
@@ -903,9 +900,7 @@
(defun finalize-method (method class)
"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)
(constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method))))
@@ -979,9 +974,10 @@
;; labels contains offsets into the code array after it's finalized
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)
@@ -1065,10 +1061,11 @@
(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)
"Adds `attribute' to `code', returning `attribute'."
@@ -1097,26 +1094,28 @@
(declare (ignore class))
(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
:input-locals
(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.
(dotimes (i (length code))
(declare (type (unsigned-byte 16) i))
(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))
(declare (type (unsigned-byte 16) index))
@@ -1129,9 +1128,6 @@
(symbol-value (the symbol label)))
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)))))))
;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
@@ -1214,6 +1210,7 @@
to which it has been attached has been superseded.")
(defvar *current-code-attribute* nil)
+(defvar *method* nil)
(defun save-code-specials (code)
(setf (code-code code) *code*
@@ -1233,16 +1230,21 @@
(when *current-code-attribute*
(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))
(*current-code-attribute* ,c))
, at body
(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*)))))
@@ -1425,318 +1427,20 @@
(write-u1 (verification-type-info-tag vti) stream)
(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))
- , at body))))
-
-(defun compute-initial-method-locals (class method)
+(defun compute-initial-method-locals (method)
(let (locals)
(unless (member :static (method-access-flags method))
(if (string= "<init>" (method-name method))
;;the method is a constructor.
(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))
(nreverse locals)))
(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)
#|
Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original)
+++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Mon Oct 25 18:17:28 2010
@@ -31,230 +31,338 @@
(in-package #:jvm)
-
;; OPCODES
(defconst *opcode-table* (make-array 256))
(defconst *opcodes* (make-hash-table :test 'equalp))
-(defstruct jvm-opcode name number size stack-effect)
+(defstruct jvm-opcode name number size stack-effect effect-function)
-(defun %define-opcode (name number size stack-effect)
+(defun %define-opcode (name number size stack-effect effect-function)
(declare (type fixnum number size))
(let* ((name (string name))
(opcode (make-jvm-opcode :name name
: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))
+ , at 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
(define-opcode label 202 0 0) ;; virtual: does not exist in the JVM
@@ -278,6 +386,7 @@
(jvm-opcode-number opcode)
(error "Unknown opcode ~S." opcode-name))))
+
(declaim (ftype (function (t) fixnum) opcode-size))
(defun opcode-size (opcode-number)
(declare (optimize speed (safety 0)))
@@ -289,8 +398,51 @@
(declare (optimize speed))
(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
@@ -299,7 +451,13 @@
args
stack
depth
- wide)
+ wide
+ input-locals
+ input-stack
+ output-locals
+ output-stack
+ ;;the calculated offset of the instruction
+ offset)
(defun make-instruction (opcode args)
(let ((inst (apply #'%make-instruction
@@ -307,6 +465,8 @@
(remove :wide-prefix args)))))
(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))
(defun print-instruction (instruction)
@@ -340,6 +500,8 @@
;; We need to have APIs to address this, but for now pass2 is
;; 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)
(defun %%emit (instr &rest args)
@@ -360,9 +522,17 @@
(eq (car instr) 'QUOTE)
(symbolp (cadr instr)))
(setf instr (opcode-number (cadr instr))))
- (if (fixnump instr)
- `(%%emit ,instr , at args)
- `(%emit ,instr , at args)))
+ (let ((instruction (gensym)))
+ `(let ((,instruction
+ ,(if (fixnump instr)
+ `(%%emit ,instr , at args)
+ `(%emit ,instr , at 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)))
;; Helper routines
@@ -395,8 +565,8 @@
(declaim (ftype (function (t) t) branch-p)
(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
Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp Mon Oct 25 18:17:28 2010
@@ -124,7 +124,8 @@
class-name
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
)
@@ -163,7 +164,18 @@
:class-name class-name
: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
(make-source-file-attribute
@@ -176,12 +188,10 @@
`(let* ((,var ,class-file)
(*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 , at 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*))))
(defstruct compiland
More information about the armedbear-cvs
mailing list