[armedbear-cvs] r12984 - branches/invokedynamic/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Sat Oct 30 00:16:00 UTC 2010
Author: astalla
Date: Fri Oct 29 20:15:58 2010
New Revision: 12984
Log:
[invokedynamic] Instruction effects are simulated at code resolving time, not emit time.
Stack map frames not yet emitted: compilation fails early.
More consistency in how constant indexes are handled.
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
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 Fri Oct 29 20:15:58 2010
@@ -204,10 +204,12 @@
(declaim (ftype (function * t) emit-invokestatic))
(defun emit-invokestatic (class-name method-name arg-types return-type)
(let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
- (index (constant-index (pool-add-method-ref
- *pool* class-name
- method-name (cons return-type arg-types))))
- (instruction (apply #'%emit 'invokestatic (u2 index))))
+ (method (pool-add-method-ref
+ *pool* class-name
+ method-name (cons return-type arg-types)))
+ (instruction (%emit 'invokestatic method)))
+ (when (string= method-name "recall")
+ (sys::%format t "RECALL!!! ~S ~S~%" (cons return-type arg-types) method))
(setf (instruction-stack instruction) stack-effect)))
@@ -226,10 +228,10 @@
(defknown emit-invokevirtual (t t t t) t)
(defun emit-invokevirtual (class-name method-name arg-types return-type)
(let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
- (index (constant-index (pool-add-method-ref
- *pool* class-name
- method-name (cons return-type arg-types))))
- (instruction (apply #'%emit 'invokevirtual (u2 index))))
+ (method (pool-add-method-ref
+ *pool* class-name
+ method-name (cons return-type arg-types)))
+ (instruction (%emit 'invokevirtual method)))
(declare (type (signed-byte 8) stack-effect))
(let ((explain *explain*))
(when (and explain (memq :java-calls explain))
@@ -244,10 +246,10 @@
(defknown emit-invokespecial-init (string list) t)
(defun emit-invokespecial-init (class-name arg-types)
(let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
- (index (constant-index (pool-add-method-ref
- *pool* class-name
- "<init>" (cons nil arg-types))))
- (instruction (apply #'%emit 'invokespecial (u2 index))))
+ (method (pool-add-method-ref
+ *pool* class-name
+ "<init>" (cons nil arg-types)))
+ (instruction (%emit 'invokespecial method)))
(declare (type (signed-byte 8) stack-effect))
(setf (instruction-stack instruction) (1- stack-effect))))
@@ -287,41 +289,45 @@
(defknown emit-getstatic (t t t) t)
(defun emit-getstatic (class-name field-name type)
(let ((ref (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'getstatic (u2 (constant-index ref)))))
+ (%emit 'getstatic ref)))
(defknown emit-putstatic (t t t) t)
(defun emit-putstatic (class-name field-name type)
(let ((ref (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'putstatic (u2 (constant-index ref)))))
+ (%emit 'putstatic ref)))
(declaim (inline emit-getfield emit-putfield))
(defknown emit-getfield (t t t) t)
(defun emit-getfield (class-name field-name type)
(let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'getfield (u2 (constant-index ref)))))
+ (%emit 'getfield ref)))
(defknown emit-putfield (t t t) t)
(defun emit-putfield (class-name field-name type)
(let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'putfield (u2 (constant-index ref)))))
+ (%emit 'putfield ref)))
(defknown emit-new (t) t)
(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
(defun emit-new (class-name)
- (apply #'%emit 'new (u2 (constant-index (pool-class class-name)))))
+ (let ((class (pool-class class-name)))
+ (%emit 'new class)))
(defknown emit-anewarray (t) t)
(defun emit-anewarray (class-name)
- (apply #'%emit 'anewarray (u2 (constant-index (pool-class class-name)))))
+ (let ((class (pool-class class-name)))
+ (%emit 'anewarray class)))
(defknown emit-checkcast (t) t)
(defun emit-checkcast (class-name)
- (apply #'%emit 'checkcast (u2 (constant-index (pool-class class-name)))))
+ (let ((class (pool-class class-name)))
+ (%emit 'checkcast class)))
(defknown emit-instanceof (t) t)
(defun emit-instanceof (class-name)
- (apply #'%emit 'instanceof (u2 (constant-index (pool-class class-name)))))
+ (let ((class (pool-class class-name)))
+ (%emit 'instanceof class)))
(defvar type-representations '((:int fixnum)
@@ -3799,7 +3805,6 @@
: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)
@@ -4559,113 +4564,6 @@
(fix-boxing representation nil)
(emit-move-from-stack target representation))))
-(defun p2-make-array (form target representation)
- ;; In safe code, we want to make sure the requested length does not exceed
- ;; ARRAY-DIMENSION-LIMIT.
- (cond ((and (< *safety* 3)
- (= (length form) 2)
- (fixnum-type-p (derive-compiler-type (second form)))
- (null representation))
- (let ((arg (second form)))
- (emit-new +lisp-simple-vector+)
- (emit 'dup)
- (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
- (emit-invokespecial-init +lisp-simple-vector+ '(:int))
- (emit-move-from-stack target representation)))
- (t
- (compile-function-call form target representation))))
-
-;; make-sequence result-type size &key initial-element => sequence
-(define-inlined-function p2-make-sequence (form target representation)
- ;; In safe code, we want to make sure the requested length does not exceed
- ;; ARRAY-DIMENSION-LIMIT.
- ((and (< *safety* 3)
- (= (length form) 3)
- (null representation)))
- (let* ((args (cdr form))
- (arg1 (first args))
- (arg2 (second args)))
- (when (and (consp arg1)
- (= (length arg1) 2)
- (eq (first arg1) 'QUOTE))
- (let* ((result-type (second arg1))
- (class
- (case result-type
- ((STRING SIMPLE-STRING)
- (setf class +lisp-simple-string+))
- ((VECTOR SIMPLE-VECTOR)
- (setf class +lisp-simple-vector+)))))
- (when class
- (emit-new class)
- (emit 'dup)
- (compile-forms-and-maybe-emit-clear-values arg2 'stack :int)
- (emit-invokespecial-init class '(:int))
- (emit-move-from-stack target representation)
- (return-from p2-make-sequence)))))
- (compile-function-call form target representation))
-
-(defun p2-make-string (form target representation)
- ;; In safe code, we want to make sure the requested length does not exceed
- ;; ARRAY-DIMENSION-LIMIT.
- (cond ((and (< *safety* 3)
- (= (length form) 2)
- (null representation))
- (let ((arg (second form)))
- (emit-new +lisp-simple-string+)
- (emit 'dup)
- (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
- (emit-invokespecial-init +lisp-simple-string+ '(:int))
- (emit-move-from-stack target representation)))
- (t
- (compile-function-call form target representation))))
-
-(defun p2-%make-structure (form target representation)
- (cond ((and (check-arg-count form 2)
- (eq (derive-type (%cadr form)) 'SYMBOL))
- (emit-new +lisp-structure-object+)
- (emit 'dup)
- (compile-form (%cadr form) 'stack nil)
- (emit-checkcast +lisp-symbol+)
- (compile-form (%caddr form) 'stack nil)
- (maybe-emit-clear-values (%cadr form) (%caddr form))
- (emit-invokevirtual +lisp-object+ "copyToArray"
- nil +lisp-object-array+)
- (emit-invokespecial-init +lisp-structure-object+
- (list +lisp-symbol+ +lisp-object-array+))
- (emit-move-from-stack target representation))
- (t
- (compile-function-call form target representation))))
-
-(defun p2-make-structure (form target representation)
- (let* ((args (cdr form))
- (slot-forms (cdr args))
- (slot-count (length slot-forms)))
- (cond ((and (<= 1 slot-count 6)
- (eq (derive-type (%car args)) 'SYMBOL))
- (emit-new +lisp-structure-object+)
- (emit 'dup)
- (compile-form (%car args) 'stack nil)
- (emit-checkcast +lisp-symbol+)
- (dolist (slot-form slot-forms)
- (compile-form slot-form 'stack nil))
- (apply 'maybe-emit-clear-values args)
- (emit-invokespecial-init +lisp-structure-object+
- (append (list +lisp-symbol+)
- (make-list slot-count :initial-element +lisp-object+)))
- (emit-move-from-stack target representation))
- (t
- (compile-function-call form target representation)))))
-
-(defun p2-make-hash-table (form target representation)
- (cond ((= (length form) 1) ; no args
- (emit-new +lisp-eql-hash-table+)
- (emit 'dup)
- (emit-invokespecial-init +lisp-eql-hash-table+ nil)
- (fix-boxing representation nil)
- (emit-move-from-stack target representation))
- (t
- (compile-function-call form target representation))))
-
(defknown p2-stream-element-type (t t t) t)
(define-inlined-function p2-stream-element-type (form target representation)
((check-arg-count form 1))
@@ -6852,8 +6750,6 @@
(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
@@ -6862,10 +6758,18 @@
(*thread* nil)
(*initialize-thread-var* nil)
- (label-START (gensym))
- prologue)
+ (label-START (gensym)))
(class-add-method class-file method)
+
+ (setf (abcl-class-file-superclass class-file)
+ (if (or *hairy-arglist-p*
+ (and *child-p* *closure-variables*))
+ +lisp-compiled-closure+
+ +lisp-primitive+))
+
+ (make-constructor class-file)
+
(when (fixnump *source-line-number*)
(let ((table (make-line-numbers-attribute)))
(method-add-attribute method table)
@@ -6876,36 +6780,6 @@
(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)))
@@ -7049,7 +6923,7 @@
(check-for-unused-variables (compiland-arg-vars compiland))
;; Go back and fill in prologue.
- #+nil (let ((code *code*))
+ (let ((code *code*))
(setf *code* ())
(let ((arity (compiland-arity compiland)))
(when arity
@@ -7076,14 +6950,6 @@
(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*
- (and *child-p* *closure-variables*))
- +lisp-compiled-closure+
- +lisp-primitive+))
(setf (abcl-class-file-lambda-list class-file) args)
(setf (code-max-locals code) *registers-allocated*)
@@ -7132,7 +6998,6 @@
;; 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))
@@ -7374,7 +7239,6 @@
nth
progn))
(install-p2-handler '%ldb 'p2-%ldb)
- (install-p2-handler '%make-structure 'p2-%make-structure)
(install-p2-handler '* 'p2-times)
(install-p2-handler '+ 'p2-plus)
(install-p2-handler '- 'p2-minus)
@@ -7429,11 +7293,6 @@
(install-p2-handler 'logior 'p2-logior)
(install-p2-handler 'lognot 'p2-lognot)
(install-p2-handler 'logxor 'p2-logxor)
- (install-p2-handler 'make-array 'p2-make-array)
- (install-p2-handler 'make-hash-table 'p2-make-hash-table)
- (install-p2-handler 'make-sequence 'p2-make-sequence)
- (install-p2-handler 'make-string 'p2-make-string)
- (install-p2-handler 'make-structure 'p2-make-structure)
(install-p2-handler 'max 'p2-min/max)
(install-p2-handler 'memq 'p2-memq)
(install-p2-handler 'memql 'p2-memql)
@@ -7494,6 +7353,6 @@
(let ((sys:*enable-autocompile* nil))
(values (compile nil function)))))
-(setf sys:*enable-autocompile* t)
+(setf sys:*enable-autocompile* nil)
(provide "COMPILER-PASS2")
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 Fri Oct 29 20:15:58 2010
@@ -229,6 +229,7 @@
(princ arg-string s))
(princ #\) s)
(princ ret-string s))
+ ;(sys::%format t "descriptor ~S ~S -> ~S~%" return-type argument-types str)
str)
;; (format nil "(~{~A~})~A"
;; (internal-field-ref return-type))
@@ -355,12 +356,14 @@
(defstruct (constant-name/type (:constructor
make-constant-name/type (index
name
+ type
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
+ type
descriptor)
(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
@@ -493,7 +496,8 @@
(unless entry
(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)
+ (setf entry (make-constant-name/type
+ (incf (pool-index pool)) n type i-t)
(gethash (cons name type) (pool-entries pool)) entry))
(push entry (pool-entries-list pool)))
entry))
@@ -756,7 +760,7 @@
((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry)))
((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-class entry)
(constant-member-ref-name/type entry)))
(12 (sys::%format t "n/t: ~a,~a~%"
(constant-name/type-name entry)
@@ -976,8 +980,7 @@
;; these are used for handling nested WITH-CODE-TO-METHOD blocks
(current-local 0)
- computed-locals
- computed-stack)
+ computed-locals)
@@ -1010,7 +1013,7 @@
(analyze-locals code)))
(multiple-value-bind
(c labels stack-map-table)
- (resolve-code c class parent compute-stack-map-table-p)
+ (resolve-code code c class parent compute-stack-map-table-p)
(setf (code-code code) c
(code-labels code) labels)
(when compute-stack-map-table-p
@@ -1089,12 +1092,15 @@
:catch-type type)
(code-exception-handlers code)))
-(defun resolve-code (code class method compute-stack-map-table-p)
+(defun resolve-code (code-attr code class method compute-stack-map-table-p)
"Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table."
(declare (ignore class))
(let* ((length 0)
labels ;; alist
- stack-map-table)
+ stack-map-table
+ (computing-stack-map-table compute-stack-map-table-p)
+ (*code-locals* (code-computed-locals code-attr))
+ *code-stack*)
#|| (*basic-block* (when compute-stack-map-table-p
(make-basic-block
:offset 0
@@ -1102,14 +1108,31 @@
(method-initial-locals method))))
(root-block *basic-block*)
*basic-blocks*)||#
- compute-stack-map-table-p :todo
(declare (type (unsigned-byte 16) length))
- ;; Pass 1: calculate label offsets and overall length.
+ ;; Pass 1: calculate label offsets and overall length and, if
+ ;; compute-stack-map-table-p is true, also simulate the effect of the
+ ;; instructions on the stack and locals.
(dotimes (i (length code))
(declare (type (unsigned-byte 16) i))
(let* ((instruction (aref code i))
(opcode (instruction-opcode instruction)))
(setf (instruction-offset instruction) length)
+ ;;(sys::format t "simulating instruction ~S ~S stack ~S locals ~S ~%"
+ ;;opcode (mapcar #'type-of (instruction-args instruction))
+ ;;(length *code-stack*) (length *code-locals*))
+ (if computing-stack-map-table
+ (progn
+ (when (= opcode 202) ;;label: simulate a jump
+ (record-jump-to-label (car (instruction-args instruction))))
+ (simulate-instruction-effect instruction)
+ ;;Simulation must be stopped if we encounter a goto, it will be
+ ;;resumed by the next label that is the target of a jump
+ (setf computing-stack-map-table (not (unconditional-jump-p opcode))))
+ (when (and (= opcode 202) ; LABEL
+ (get (first (instruction-args instruction))
+ 'jump-target-p))
+ (simulate-instruction-effect instruction)
+ (setf computing-stack-map-table t)))
(if (= opcode 202) ; LABEL
(let ((label (car (instruction-args instruction))))
(set label length)
@@ -1127,6 +1150,8 @@
(offset (- (the (unsigned-byte 16)
(symbol-value (the symbol label)))
index)))
+ (unless (get label 'jump-target-p)
+ (sys::%format "error - label not target of a jump ~S~%" label))
(setf (instruction-args instruction) (s2 offset))))
(unless (= (instruction-opcode instruction) 202) ; LABEL
(incf index (opcode-size (instruction-opcode instruction)))))))
@@ -1141,14 +1166,29 @@
(setf (svref bytes index) (instruction-opcode instruction))
(incf index)
(dolist (arg (instruction-args instruction))
- (setf (svref bytes index)
- (if (constant-p arg) (constant-index arg) arg))
- (incf index)))))
+ (if (constant-p arg)
+ (let ((idx (constant-index arg))
+ (opcode (instruction-opcode instruction)))
+ ;;(sys::%format t "constant ~A ~A index-size ~A index ~A~%" (type-of arg) idx (constant-index-size arg) index)
+ (if (or (<= 178 opcode 187)
+ (= opcode 189)
+ (= opcode 192)
+ (= opcode 193))
+ (let ((idx (u2 idx)))
+ (setf (svref bytes index) (car idx)
+ (svref bytes (1+ index)) (cadr idx))
+ (incf index 2))
+ (progn
+ (setf (svref bytes index) idx)
+ (incf index))))
+ (progn
+ (setf (svref bytes index) arg)
+ (incf index)))))))
+ (sys::%format t "~%~%~%BYTES ~S~%~%~%" bytes)
(values bytes labels stack-map-table))))
-(defun ends-basic-block-p (opcode)
- (or (branch-p opcode)
- (>= 172 opcode 177))) ;;return variants
+(defun unconditional-jump-p (opcode)
+ (= opcode 167))
(defstruct exception
"Exception handler information.
@@ -1234,17 +1274,13 @@
(,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-computed-locals ,c) *code-locals*
- (code-computed-stack ,c) *code-stack*))
+ (code-max-locals ,c) *registers-allocated*))
(when *current-code-attribute*
(restore-code-specials *current-code-attribute*)))))
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 Fri Oct 29 20:15:58 2010
@@ -61,6 +61,16 @@
(declare (ignorable instruction))
, at body))))
+(defun record-jump-to-label (label)
+ "Records a jump to a label appearing further down in the code."
+ ;;TODO: check that multiple jumps are compatible
+ (setf (get label 'jump-target-p)
+ t
+ (get label '*code-locals*)
+ *code-locals*
+ (get label '*code-stack*)
+ *code-stack*))
+
;; name number size stack-effect (nil if unknown)
(define-opcode nop 0 1 0)
(define-opcode aconst_null 1 1 1 (smf-push :null))
@@ -125,7 +135,6 @@
(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))))
@@ -260,7 +269,6 @@
(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))
@@ -282,12 +290,24 @@
(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 ifeq 153 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
+(define-opcode ifne 154 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
+(define-opcode iflt 155 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
+(define-opcode ifge 156 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
+(define-opcode ifgt 157 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
+(define-opcode ifle 158 3 -1
+ (smf-pop)
+ (record-jump-to-label (first (instruction-args instruction))))
(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))
@@ -296,7 +316,8 @@
(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 goto 167 3 0
+ (record-jump-to-label (first (instruction-args instruction))))
;;(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 (smf-pop))
@@ -308,30 +329,50 @@
(define-opcode areturn 176 1 -1 (smf-pop))
(define-opcode return 177 1 0)
(define-opcode getstatic 178 3 1
- (sys::%format t "GETSTATIC ~A~%" (third (instruction-args instruction)))
- ;;TODO!!!
- (smf-push (third (instruction-args instruction))))
+ (let ((field-type
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ (smf-push field-type)))
(define-opcode putstatic 179 3 -1
- (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction)))
- (smf-popt (third (instruction-args instruction))))
+ (let ((field-type
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ (smf-popt field-type)))
(define-opcode getfield 180 3 0
(smf-pop)
- (smf-push (third (instruction-args instruction))))
+ (let ((field-type
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ (smf-push field-type)))
(define-opcode putfield 181 3 -2
- (smf-popt (third (instruction-args instruction)))
+ (let ((field-type
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ (smf-popt field-type))
(smf-pop))
(define-opcode invokevirtual 182 3 nil
- (smf-popt (third (instruction-args instruction)))
- (smf-pop)
- (smf-push (third (instruction-args instruction))))
+ (let ((method-return-and-arg-types
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ ;;(sys::%format t "invokevirtual ~S~%" method-return-and-arg-types)
+ (map nil #'smf-popt (cdr method-return-and-arg-types))
+ (smf-pop)
+ (smf-push (car method-return-and-arg-types))))
(define-opcode invokespecial 183 3 nil
- (smf-popt (third (instruction-args instruction)))
- (smf-pop)
- (smf-push (third (instruction-args instruction))))
+ (let ((method-return-and-arg-types
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ ;;(sys::%format t "invokespecial ~S~%" method-return-and-arg-types)
+ (map nil #'smf-popt (cdr method-return-and-arg-types))
+ (smf-pop)
+ (smf-push (car method-return-and-arg-types))))
(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))))
+ (let ((method-return-and-arg-types
+ (constant-name/type-type
+ (constant-member-ref-name/type (first (instruction-args instruction))))))
+ ;;(sys::%format t "invokestatic ~S~%" method-return-and-arg-types)
+ (map nil #'smf-popt (cdr method-return-and-arg-types))
+ (smf-push (car method-return-and-arg-types))))
(define-opcode invokeinterface 185 5 nil
(smf-popt (third (instruction-args instruction)))
(smf-pop)
@@ -365,7 +406,15 @@
(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
+(define-opcode label 202 0 0 ;; virtual: does not exist in the JVM
+ (if (get (first (instruction-args instruction)) 'jump-target-p)
+ ;;This label is the target of a jump emitted earlier
+ (setf *code-locals*
+ (get (first (instruction-args instruction)) '*code-locals*)
+ *code-stack*
+ (get (first (instruction-args instruction)) '*code-stack*))
+ ;;Else simulate a jump to self to store locals and stack
+ (record-jump-to-label (first (instruction-args instruction)))))
;; (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
@@ -410,6 +459,8 @@
pos *code-locals*)))
(defun smf-set (pos type)
+ (when (null type)
+ (sys::%format t "smf-set null! pos ~A ~S~%" pos 42 #+nil(subseq (sys::backtrace-as-list) 2 10)))
(if (< pos (length *code-locals*))
(setf (nth pos *code-locals*) type)
(progn
@@ -423,12 +474,12 @@
(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*))
+ (pop *code-stack*)
+ (when (or (eq type :long) (eq type :double)) ;TODO
+ (pop *code-stack*)))
(defun smf-popn (n)
(dotimes (i n)
@@ -465,8 +516,6 @@
(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)
@@ -522,18 +571,18 @@
(eq (car instr) 'QUOTE)
(symbolp (cadr instr)))
(setf instr (opcode-number (cadr instr))))
- (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)))
-
+ (if (fixnump instr)
+ `(%%emit ,instr , at args)
+ `(%emit ,instr , at args)))
+
+(defun simulate-instruction-effect (instruction)
+ (setf (instruction-input-locals instruction) *code-locals*)
+ (setf (instruction-input-stack instruction) *code-stack*)
+ (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
@@ -619,9 +668,8 @@
(list
(inst 'aload (car (instruction-args instruction)))
(inst 'aconst_null)
- (inst 'putfield (u2 (constant-index
- (pool-field +lisp-thread+ "_values"
- +lisp-object-array+))))))
+ (inst 'putfield (pool-field +lisp-thread+ "_values"
+ +lisp-object-array+))))
(vector-push-extend instruction vector)))
(t
(vector-push-extend instruction vector)))))))
More information about the armedbear-cvs
mailing list