Changeset 12984


Ignore:
Timestamp:
10/30/10 00:15:58 (12 years ago)
Author:
astalla
Message:

[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.

Location:
branches/invokedynamic/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed

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

    r12983 r12984  
    205205(defun emit-invokestatic (class-name method-name arg-types return-type)
    206206  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
    207          (index (constant-index (pool-add-method-ref
    208          *pool* class-name
    209          method-name (cons return-type arg-types))))
    210          (instruction (apply #'%emit 'invokestatic (u2 index))))
     207         (method (pool-add-method-ref
     208      *pool* class-name
     209      method-name (cons return-type arg-types)))
     210         (instruction (%emit 'invokestatic method)))
     211    (when (string= method-name "recall")
     212      (sys::%format t "RECALL!!! ~S ~S~%" (cons return-type arg-types) method))
    211213    (setf (instruction-stack instruction) stack-effect)))
    212214
    … …  
    227229(defun emit-invokevirtual (class-name method-name arg-types return-type)
    228230  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
    229          (index (constant-index (pool-add-method-ref
    230         *pool* class-name
    231          method-name (cons return-type arg-types))))
    232          (instruction (apply #'%emit 'invokevirtual (u2 index))))
     231         (method (pool-add-method-ref
     232      *pool* class-name
     233      method-name (cons return-type arg-types)))
     234         (instruction (%emit 'invokevirtual method)))
    233235    (declare (type (signed-byte 8) stack-effect))
    234236    (let ((explain *explain*))
    … …  
    245247(defun emit-invokespecial-init (class-name arg-types)
    246248  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
    247          (index (constant-index (pool-add-method-ref
    248         *pool* class-name
    249          "<init>" (cons nil arg-types))))
    250          (instruction (apply #'%emit 'invokespecial (u2 index))))
     249         (method (pool-add-method-ref
     250      *pool* class-name
     251      "<init>" (cons nil arg-types)))
     252         (instruction (%emit 'invokespecial method)))
    251253    (declare (type (signed-byte 8) stack-effect))
    252254    (setf (instruction-stack instruction) (1- stack-effect))))
    … …  
    288290(defun emit-getstatic (class-name field-name type)
    289291  (let ((ref (pool-add-field-ref *pool* class-name field-name type)))
    290     (apply #'%emit 'getstatic (u2 (constant-index ref)))))
     292    (%emit 'getstatic ref)))
    291293
    292294(defknown emit-putstatic (t t t) t)
    293295(defun emit-putstatic (class-name field-name type)
    294296  (let ((ref (pool-add-field-ref *pool* class-name field-name type)))
    295     (apply #'%emit 'putstatic (u2 (constant-index ref)))))
     297    (%emit 'putstatic ref)))
    296298
    297299(declaim (inline emit-getfield emit-putfield))
    … …  
    299301(defun emit-getfield (class-name field-name type)
    300302  (let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
    301     (apply #'%emit 'getfield (u2 (constant-index ref)))))
     303    (%emit 'getfield ref)))
    302304
    303305(defknown emit-putfield (t t t) t)
    304306(defun emit-putfield (class-name field-name type)
    305307  (let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
    306     (apply #'%emit 'putfield (u2 (constant-index ref)))))
     308    (%emit 'putfield ref)))
    307309
    308310
    … …  
    310312(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
    311313(defun emit-new (class-name)
    312   (apply #'%emit 'new (u2 (constant-index (pool-class class-name)))))
     314  (let ((class (pool-class class-name)))
     315    (%emit 'new class)))
    313316
    314317(defknown emit-anewarray (t) t)
    315318(defun emit-anewarray (class-name)
    316   (apply #'%emit 'anewarray (u2 (constant-index (pool-class class-name)))))
     319  (let ((class (pool-class class-name)))
     320    (%emit 'anewarray class)))
    317321
    318322(defknown emit-checkcast (t) t)
    319323(defun emit-checkcast (class-name)
    320   (apply #'%emit 'checkcast (u2 (constant-index (pool-class class-name)))))
     324  (let ((class (pool-class class-name)))
     325    (%emit 'checkcast class)))
    321326
    322327(defknown emit-instanceof (t) t)
    323328(defun emit-instanceof (class-name)
    324   (apply #'%emit 'instanceof (u2 (constant-index (pool-class class-name)))))
     329  (let ((class (pool-class class-name)))
     330    (%emit 'instanceof class)))
    325331
    326332
    … …  
    38003806                                   :if-exists :supersede)))
    38013807      (with-class-file class-file
    3802   (make-constructor class-file)
    38033808        (let ((*current-compiland* compiland))
    38043809          (with-saved-compiler-policy
    … …  
    45594564      (fix-boxing representation nil)
    45604565      (emit-move-from-stack target representation))))
    4561 
    4562 (defun p2-make-array (form target representation)
    4563   ;; In safe code, we want to make sure the requested length does not exceed
    4564   ;; ARRAY-DIMENSION-LIMIT.
    4565   (cond ((and (< *safety* 3)
    4566               (= (length form) 2)
    4567               (fixnum-type-p (derive-compiler-type (second form)))
    4568               (null representation))
    4569          (let ((arg (second form)))
    4570            (emit-new +lisp-simple-vector+)
    4571            (emit 'dup)
    4572      (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    4573            (emit-invokespecial-init +lisp-simple-vector+ '(:int))
    4574            (emit-move-from-stack target representation)))
    4575         (t
    4576          (compile-function-call form target representation))))
    4577 
    4578 ;; make-sequence result-type size &key initial-element => sequence
    4579 (define-inlined-function p2-make-sequence (form target representation)
    4580   ;; In safe code, we want to make sure the requested length does not exceed
    4581   ;; ARRAY-DIMENSION-LIMIT.
    4582   ((and (< *safety* 3)
    4583                (= (length form) 3)
    4584                (null representation)))
    4585   (let* ((args (cdr form))
    4586          (arg1 (first args))
    4587          (arg2 (second args)))
    4588     (when (and (consp arg1)
    4589                (= (length arg1) 2)
    4590                (eq (first arg1) 'QUOTE))
    4591       (let* ((result-type (second arg1))
    4592              (class
    4593               (case result-type
    4594                 ((STRING SIMPLE-STRING)
    4595                  (setf class +lisp-simple-string+))
    4596                 ((VECTOR SIMPLE-VECTOR)
    4597                  (setf class +lisp-simple-vector+)))))
    4598         (when class
    4599           (emit-new class)
    4600           (emit 'dup)
    4601     (compile-forms-and-maybe-emit-clear-values arg2 'stack :int)
    4602           (emit-invokespecial-init class '(:int))
    4603           (emit-move-from-stack target representation)
    4604           (return-from p2-make-sequence)))))
    4605   (compile-function-call form target representation))
    4606 
    4607 (defun p2-make-string (form target representation)
    4608   ;; In safe code, we want to make sure the requested length does not exceed
    4609   ;; ARRAY-DIMENSION-LIMIT.
    4610   (cond ((and (< *safety* 3)
    4611               (= (length form) 2)
    4612               (null representation))
    4613          (let ((arg (second form)))
    4614            (emit-new +lisp-simple-string+)
    4615            (emit 'dup)
    4616      (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    4617            (emit-invokespecial-init +lisp-simple-string+ '(:int))
    4618            (emit-move-from-stack target representation)))
    4619         (t
    4620          (compile-function-call form target representation))))
    4621 
    4622 (defun p2-%make-structure (form target representation)
    4623   (cond ((and (check-arg-count form 2)
    4624               (eq (derive-type (%cadr form)) 'SYMBOL))
    4625          (emit-new +lisp-structure-object+)
    4626          (emit 'dup)
    4627          (compile-form (%cadr form) 'stack nil)
    4628          (emit-checkcast +lisp-symbol+)
    4629          (compile-form (%caddr form) 'stack nil)
    4630          (maybe-emit-clear-values (%cadr form) (%caddr form))
    4631          (emit-invokevirtual +lisp-object+ "copyToArray"
    4632                              nil +lisp-object-array+)
    4633          (emit-invokespecial-init +lisp-structure-object+
    4634                                   (list +lisp-symbol+ +lisp-object-array+))
    4635          (emit-move-from-stack target representation))
    4636         (t
    4637          (compile-function-call form target representation))))
    4638 
    4639 (defun p2-make-structure (form target representation)
    4640   (let* ((args (cdr form))
    4641          (slot-forms (cdr args))
    4642          (slot-count (length slot-forms)))
    4643     (cond ((and (<= 1 slot-count 6)
    4644                 (eq (derive-type (%car args)) 'SYMBOL))
    4645            (emit-new +lisp-structure-object+)
    4646            (emit 'dup)
    4647            (compile-form (%car args) 'stack nil)
    4648            (emit-checkcast +lisp-symbol+)
    4649            (dolist (slot-form slot-forms)
    4650              (compile-form slot-form 'stack nil))
    4651            (apply 'maybe-emit-clear-values args)
    4652            (emit-invokespecial-init +lisp-structure-object+
    4653                                     (append (list +lisp-symbol+)
    4654                                             (make-list slot-count :initial-element +lisp-object+)))
    4655            (emit-move-from-stack target representation))
    4656           (t
    4657            (compile-function-call form target representation)))))
    4658 
    4659 (defun p2-make-hash-table (form target representation)
    4660   (cond ((= (length form) 1) ; no args
    4661          (emit-new +lisp-eql-hash-table+)
    4662          (emit 'dup)
    4663          (emit-invokespecial-init +lisp-eql-hash-table+ nil)
    4664          (fix-boxing representation nil)
    4665          (emit-move-from-stack target representation))
    4666         (t
    4667          (compile-function-call form target representation))))
    46684566
    46694567(defknown p2-stream-element-type (t t t) t)
    … …  
    68536751                               :flags '(:final :public)))
    68546752         (code (method-add-code method))
    6855    (*code-locals* (code-computed-locals code)) ;;TODO in this and other cases, use with-code-to-method
    6856    (*code-stack* (code-computed-stack code))
    68576753         (*current-code-attribute* code)
    68586754         (*code* ())
    … …  
    68636759         (*thread* nil)
    68646760         (*initialize-thread-var* nil)
    6865          (label-START (gensym))
    6866    prologue)
     6761         (label-START (gensym)))
    68676762
    68686763    (class-add-method class-file method)
     6764
     6765    (setf (abcl-class-file-superclass class-file)
     6766          (if (or *hairy-arglist-p*
     6767      (and *child-p* *closure-variables*))
     6768        +lisp-compiled-closure+
     6769      +lisp-primitive+))
     6770
     6771    (make-constructor class-file)
     6772
    68696773    (when (fixnump *source-line-number*)
    68706774      (let ((table (make-line-numbers-attribute)))
    … …  
    68766780    (dolist (var (compiland-free-specials compiland))
    68776781      (push var *visible-variables*))
    6878 
    6879     ;;Prologue
    6880     (let ((arity (compiland-arity compiland)))
    6881       (when arity
    6882   (generate-arg-count-check arity)))
    6883    
    6884     (when *hairy-arglist-p*
    6885       (aload 0) ; this
    6886       (aver (not (null (compiland-argument-register compiland))))
    6887       (aload (compiland-argument-register compiland)) ; arg vector
    6888       (cond ((or (memq '&OPTIONAL args) (memq '&KEY args))
    6889        (ensure-thread-var-initialized)
    6890        (maybe-initialize-thread-var)
    6891        (emit-push-current-thread)
    6892        (emit-invokevirtual *this-class* "processArgs"
    6893          (list +lisp-object-array+ +lisp-thread+)
    6894          +lisp-object-array+))
    6895       (t
    6896        (emit-invokevirtual *this-class* "fastProcessArgs"
    6897          (list +lisp-object-array+)
    6898          +lisp-object-array+)))
    6899       (astore (compiland-argument-register compiland)))
    6900    
    6901     (unless (and *hairy-arglist-p*
    6902      (or (memq '&OPTIONAL args) (memq '&KEY args)))
    6903       (maybe-initialize-thread-var))
    6904    
    6905     (setf prologue *code*
    6906     *code* ())
    6907     ;;;;
    69086782
    69096783    (when *using-arg-array*
    … …  
    70506924
    70516925    ;; Go back and fill in prologue.
    7052     #+nil (let ((code *code*))
     6926    (let ((code *code*))
    70536927      (setf *code* ())
    70546928      (let ((arity (compiland-arity compiland)))
    … …  
    70776951        (maybe-initialize-thread-var))
    70786952      (setf *code* (nconc code *code*)))
    7079    
    7080     (setf *code* (nconc prologue *code*))
    7081 
    7082     (setf (abcl-class-file-superclass class-file)
    7083           (if (or *hairy-arglist-p*
    7084       (and *child-p* *closure-variables*))
    7085         +lisp-compiled-closure+
    7086       +lisp-primitive+))
    70876953
    70886954    (setf (abcl-class-file-lambda-list class-file) args)
    … …  
    71336999
    71347000    (with-class-file (compiland-class-file compiland)
    7135       (make-constructor *class-file*)
    71367001      (with-saved-compiler-policy
    71377002        (p2-compiland compiland)
    … …  
    73757240                               progn))
    73767241  (install-p2-handler '%ldb                'p2-%ldb)
    7377   (install-p2-handler '%make-structure     'p2-%make-structure)
    73787242  (install-p2-handler '*                   'p2-times)
    73797243  (install-p2-handler '+                   'p2-plus)
    … …  
    74307294  (install-p2-handler 'lognot              'p2-lognot)
    74317295  (install-p2-handler 'logxor              'p2-logxor)
    7432   (install-p2-handler 'make-array          'p2-make-array)
    7433   (install-p2-handler 'make-hash-table     'p2-make-hash-table)
    7434   (install-p2-handler 'make-sequence       'p2-make-sequence)
    7435   (install-p2-handler 'make-string         'p2-make-string)
    7436   (install-p2-handler 'make-structure      'p2-make-structure)
    74377296  (install-p2-handler 'max                 'p2-min/max)
    74387297  (install-p2-handler 'memq                'p2-memq)
    … …  
    74957354      (values (compile nil function)))))
    74967355
    7497 (setf sys:*enable-autocompile* t)
     7356(setf sys:*enable-autocompile* nil)
    74987357
    74997358(provide "COMPILER-PASS2")

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

    r12983 r12984  
    230230      (princ #\) s)
    231231      (princ ret-string s))
     232    ;(sys::%format t "descriptor ~S ~S -> ~S~%" return-type argument-types str)
    232233    str)
    233234;;  (format nil "(~{~A~})~A"
    … …  
    356357                                make-constant-name/type (index
    357358                                                         name
     359               type
    358360                                                         descriptor))
    359361                               (:include constant
    … …  
    362364constant pool; this type of element is used by 'member-ref' type items."
    363365  name
     366  type
    364367  descriptor)
    365368
    … …  
    494497      (let ((n (pool-add-utf8 pool name))
    495498            (i-t (pool-add-utf8 pool internal-type)))
    496         (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
     499        (setf entry (make-constant-name/type
     500         (incf (pool-index pool)) n type i-t)
    497501              (gethash (cons name type) (pool-entries pool)) entry))
    498502      (push entry (pool-entries-list pool)))
    … …  
    757761      ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry)))
    758762      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
    759                                (constant-member-ref-class-index entry)
     763                               (constant-member-ref-class entry)
    760764                               (constant-member-ref-name/type entry)))
    761765      (12 (sys::%format t "n/t: ~a,~a~%"
    … …  
    977981  ;; these are used for handling nested WITH-CODE-TO-METHOD blocks
    978982  (current-local 0)
    979   computed-locals
    980   computed-stack)
     983  computed-locals)
    981984
    982985
    … …  
    10111014    (multiple-value-bind
    10121015          (c labels stack-map-table)
    1013         (resolve-code c class parent compute-stack-map-table-p)
     1016        (resolve-code code c class parent compute-stack-map-table-p)
    10141017      (setf (code-code code) c
    10151018            (code-labels code) labels)
    … …  
    10901093        (code-exception-handlers code)))
    10911094
    1092 (defun resolve-code (code class method compute-stack-map-table-p)
     1095(defun resolve-code (code-attr code class method compute-stack-map-table-p)
    10931096  "Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table."
    10941097  (declare (ignore class))
    10951098  (let* ((length 0)
    10961099   labels ;; alist
    1097    stack-map-table)
     1100   stack-map-table
     1101   (computing-stack-map-table compute-stack-map-table-p)
     1102   (*code-locals* (code-computed-locals code-attr))
     1103   *code-stack*)
    10981104#||  (*basic-block* (when compute-stack-map-table-p
    10991105        (make-basic-block
    … …  
    11031109   (root-block *basic-block*)
    11041110   *basic-blocks*)||#
    1105     compute-stack-map-table-p :todo
    11061111    (declare (type (unsigned-byte 16) length))
    1107     ;; Pass 1: calculate label offsets and overall length.
     1112    ;; Pass 1: calculate label offsets and overall length and, if
     1113    ;; compute-stack-map-table-p is true, also simulate the effect of the
     1114    ;; instructions on the stack and locals.
    11081115    (dotimes (i (length code))
    11091116      (declare (type (unsigned-byte 16) i))
    … …  
    11111118             (opcode (instruction-opcode instruction)))
    11121119  (setf (instruction-offset instruction) length)
     1120  ;;(sys::format t "simulating instruction ~S ~S stack ~S locals ~S ~%"
     1121  ;;opcode (mapcar #'type-of (instruction-args instruction))
     1122  ;;(length *code-stack*) (length *code-locals*))
     1123  (if computing-stack-map-table
     1124      (progn
     1125        (when (= opcode 202) ;;label: simulate a jump
     1126    (record-jump-to-label (car (instruction-args instruction))))
     1127        (simulate-instruction-effect instruction)
     1128        ;;Simulation must be stopped if we encounter a goto, it will be
     1129        ;;resumed by the next label that is the target of a jump
     1130        (setf computing-stack-map-table (not (unconditional-jump-p opcode))))
     1131      (when (and (= opcode 202) ; LABEL
     1132           (get (first (instruction-args instruction))
     1133          'jump-target-p))
     1134        (simulate-instruction-effect instruction)
     1135        (setf computing-stack-map-table t)))
    11131136        (if (= opcode 202) ; LABEL
    11141137            (let ((label (car (instruction-args instruction))))
    … …  
    11281151                                (symbol-value (the symbol label)))
    11291152                              index)))
     1153        (unless (get label 'jump-target-p)
     1154    (sys::%format "error - label not target of a jump ~S~%" label))
    11301155              (setf (instruction-args instruction) (s2 offset))))
    11311156          (unless (= (instruction-opcode instruction) 202) ; LABEL
    … …  
    11421167            (incf index)
    11431168            (dolist (arg (instruction-args instruction))
    1144               (setf (svref bytes index)
    1145         (if (constant-p arg) (constant-index arg) arg))
    1146               (incf index)))))
     1169        (if (constant-p arg)
     1170      (let ((idx (constant-index arg))
     1171      (opcode (instruction-opcode instruction)))
     1172        ;;(sys::%format t "constant ~A ~A index-size ~A index ~A~%" (type-of arg) idx (constant-index-size arg) index)
     1173        (if (or (<= 178 opcode 187)
     1174          (= opcode 189)
     1175          (= opcode 192)
     1176          (= opcode 193))
     1177      (let ((idx (u2 idx)))
     1178        (setf (svref bytes index) (car idx)
     1179        (svref bytes (1+ index)) (cadr idx))
     1180        (incf index 2))
     1181      (progn
     1182        (setf (svref bytes index) idx)
     1183        (incf index))))
     1184      (progn
     1185        (setf (svref bytes index) arg)
     1186        (incf index)))))))
     1187      (sys::%format t "~%~%~%BYTES ~S~%~%~%" bytes)
    11471188      (values bytes labels stack-map-table))))
    11481189
    1149 (defun ends-basic-block-p (opcode)
    1150   (or (branch-p opcode)
    1151       (>= 172 opcode 177))) ;;return variants
     1190(defun unconditional-jump-p (opcode)
     1191  (= opcode 167))
    11521192
    11531193(defstruct exception
    … …  
    12351275              (*pool* (class-file-constants ,class-file))
    12361276              (*code* (code-code ,c))
    1237               (*code-locals* (code-computed-locals ,c))
    1238         (*code-stack* (code-computed-stack ,c))
    12391277              (*registers-allocated* (code-max-locals ,c))
    12401278              (*register* (code-current-local ,c))
    … …  
    12431281         (setf (code-code ,c) *code*
    12441282               (code-current-local ,c) *register*
    1245                (code-max-locals ,c) *registers-allocated*
    1246          (code-computed-locals ,c) *code-locals*
    1247          (code-computed-stack ,c) *code-stack*))
     1283               (code-max-locals ,c) *registers-allocated*))
    12481284       (when *current-code-attribute*
    12491285         (restore-code-specials *current-code-attribute*)))))

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

    r12983 r12984  
    6161         (declare (ignorable instruction))
    6262         ,@body))))
     63
     64(defun record-jump-to-label (label)
     65  "Records a jump to a label appearing further down in the code."
     66  ;;TODO: check that multiple jumps are compatible
     67  (setf (get label 'jump-target-p)
     68  t
     69  (get label '*code-locals*)
     70  *code-locals*
     71  (get label '*code-stack*)
     72  *code-stack*))
    6373
    6474;; name number size stack-effect (nil if unknown)
    … …  
    126136(defun iaf-store-effect (arg)
    127137  (let ((t1 (smf-pop)))
    128     (sys::%format t "iaf-store ~S~%" (list arg t1))
    129138    (smf-set arg t1)
    130139    (when (> arg 0)
    … …  
    261270(define-opcode lxor 131 1 -2 (smf-popn 4) (smf-push :long))
    262271(define-opcode iinc 132 3 0
    263   (sys::%format t "AAAAAAAAAAAA ~A~%" (instruction-args instruction))
    264272  (smf-set (car (instruction-args instruction)) :int))
    265273(define-opcode i2l 133 1 1 (smf-pop) (smf-push :long))
    … …  
    283291(define-opcode dcmpl 151 1 -3 (smf-popn 4) (smf-push :int))
    284292(define-opcode dcmpg 152 1 -3 (smf-popn 4) (smf-push :int))
    285 (define-opcode ifeq 153 3 -1 (smf-pop))
    286 (define-opcode ifne 154 3 -1 (smf-pop))
    287 (define-opcode iflt 155 3 -1 (smf-pop))
    288 (define-opcode ifge 156 3 -1 (smf-pop))
    289 (define-opcode ifgt 157 3 -1 (smf-pop))
    290 (define-opcode ifle 158 3 -1 (smf-pop))
     293(define-opcode ifeq 153 3 -1
     294  (smf-pop)
     295  (record-jump-to-label (first (instruction-args instruction))))
     296(define-opcode ifne 154 3 -1
     297  (smf-pop)
     298  (record-jump-to-label (first (instruction-args instruction))))
     299(define-opcode iflt 155 3 -1
     300  (smf-pop)
     301  (record-jump-to-label (first (instruction-args instruction))))
     302(define-opcode ifge 156 3 -1
     303  (smf-pop)
     304  (record-jump-to-label (first (instruction-args instruction))))
     305(define-opcode ifgt 157 3 -1
     306  (smf-pop)
     307  (record-jump-to-label (first (instruction-args instruction))))
     308(define-opcode ifle 158 3 -1
     309  (smf-pop)
     310  (record-jump-to-label (first (instruction-args instruction))))
    291311(define-opcode if_icmpeq 159 3 -2 (smf-popn 2))
    292312(define-opcode if_icmpne 160 3 -2 (smf-popn 2))
    … …  
    297317(define-opcode if_acmpeq 165 3 -2 (smf-popn 2))
    298318(define-opcode if_acmpne 166 3 -2 (smf-popn 2))
    299 (define-opcode goto 167 3 0)
     319(define-opcode goto 167 3 0
     320  (record-jump-to-label (first (instruction-args instruction))))
    300321;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
    301322;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
    … …  
    309330(define-opcode return 177 1 0)
    310331(define-opcode getstatic 178 3 1
    311   (sys::%format t "GETSTATIC ~A~%" (third (instruction-args instruction)))
    312   ;;TODO!!!
    313   (smf-push (third (instruction-args instruction))))
     332  (let ((field-type
     333   (constant-name/type-type
     334    (constant-member-ref-name/type (first (instruction-args instruction))))))
     335    (smf-push field-type)))
    314336(define-opcode putstatic 179 3 -1
    315   (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction)))
    316   (smf-popt (third (instruction-args instruction))))
     337  (let ((field-type
     338   (constant-name/type-type
     339    (constant-member-ref-name/type (first (instruction-args instruction))))))
     340    (smf-popt field-type)))
    317341(define-opcode getfield 180 3 0
    318342  (smf-pop)
    319   (smf-push (third (instruction-args instruction))))
     343  (let ((field-type
     344   (constant-name/type-type
     345    (constant-member-ref-name/type (first (instruction-args instruction))))))
     346    (smf-push field-type)))
    320347(define-opcode putfield 181 3 -2
    321   (smf-popt (third (instruction-args instruction)))
     348  (let ((field-type
     349   (constant-name/type-type
     350    (constant-member-ref-name/type (first (instruction-args instruction))))))
     351    (smf-popt field-type))
    322352  (smf-pop))
    323353(define-opcode invokevirtual 182 3 nil
    324   (smf-popt (third (instruction-args instruction)))
    325   (smf-pop)
    326   (smf-push (third (instruction-args instruction))))
     354  (let ((method-return-and-arg-types
     355   (constant-name/type-type
     356    (constant-member-ref-name/type (first (instruction-args instruction))))))
     357    ;;(sys::%format t "invokevirtual ~S~%" method-return-and-arg-types)
     358    (map nil #'smf-popt (cdr method-return-and-arg-types))
     359    (smf-pop)
     360    (smf-push (car method-return-and-arg-types))))
    327361(define-opcode invokespecial 183 3 nil
    328   (smf-popt (third (instruction-args instruction)))
    329   (smf-pop)
    330   (smf-push (third (instruction-args instruction))))
     362  (let ((method-return-and-arg-types
     363   (constant-name/type-type
     364    (constant-member-ref-name/type (first (instruction-args instruction))))))
     365    ;;(sys::%format t "invokespecial ~S~%" method-return-and-arg-types)
     366    (map nil #'smf-popt (cdr method-return-and-arg-types))
     367    (smf-pop)
     368    (smf-push (car method-return-and-arg-types))))
    331369(define-opcode invokestatic 184 3 nil
    332   (sys::%format t "invokestatic ~S~%" (instruction-args instruction))
    333   (smf-popt (third (instruction-args instruction)))
    334   (smf-push (third (instruction-args instruction))))
     370  (let ((method-return-and-arg-types
     371   (constant-name/type-type
     372    (constant-member-ref-name/type (first (instruction-args instruction))))))
     373    ;;(sys::%format t "invokestatic ~S~%" method-return-and-arg-types)
     374    (map nil #'smf-popt (cdr method-return-and-arg-types))
     375    (smf-push (car method-return-and-arg-types))))
    335376(define-opcode invokeinterface 185 5 nil
    336377  (smf-popt (third (instruction-args instruction)))
    … …  
    366407(define-opcode goto_w 200 5 nil)
    367408;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
    368 (define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
     409(define-opcode label 202 0 0 ;; virtual: does not exist in the JVM
     410  (if (get (first (instruction-args instruction)) 'jump-target-p)
     411    ;;This label is the target of a jump emitted earlier
     412    (setf *code-locals*
     413    (get (first (instruction-args instruction)) '*code-locals*)
     414    *code-stack*
     415    (get (first (instruction-args instruction)) '*code-stack*))
     416    ;;Else simulate a jump to self to store locals and stack
     417    (record-jump-to-label (first (instruction-args instruction)))))
    369418;; (define-opcode push-value 203 nil 1)
    370419;; (define-opcode store-value 204 nil -1)
    … …  
    411460
    412461(defun smf-set (pos type)
     462  (when (null type)
     463    (sys::%format t "smf-set null! pos ~A ~S~%" pos 42 #+nil(subseq (sys::backtrace-as-list) 2 10)))
    413464  (if (< pos (length *code-locals*))
    414465      (setf (nth pos *code-locals*) type)
    … …  
    424475
    425476(defun smf-pop ()
    426   ;(sys::%format t "smf-pop ~A~%" *code-stack*)
    427477  (pop *code-stack*))
    428478
    429479(defun smf-popt (type)
    430   (declare (ignore type)) ;TODO
    431   (pop *code-stack*))
     480  (pop *code-stack*)
     481  (when (or (eq type :long) (eq type :double)) ;TODO
     482    (pop *code-stack*)))
    432483
    433484(defun smf-popn (n)
    … …  
    466517    (when (memq :wide-prefix args)
    467518      (setf (inst-wide inst) t))
    468     (setf (instruction-input-locals inst) *code-locals*)
    469     (setf (instruction-input-stack inst) *code-stack*)
    470519    inst))
    471520
    … …  
    523572             (symbolp (cadr instr)))
    524573    (setf instr (opcode-number (cadr instr))))
    525   (let ((instruction (gensym)))
    526     `(let ((,instruction
    527       ,(if (fixnump instr)
    528      `(%%emit ,instr ,@args)
    529      `(%emit ,instr ,@args))))
    530        ;(sys::%format t "EMIT ~S ~S~%" ',instr ',args)
    531        (funcall (opcode-effect-function (instruction-opcode ,instruction))
    532     ,instruction)
    533        (setf (instruction-output-locals ,instruction) *code-locals*)
    534        (setf (instruction-output-stack ,instruction) *code-stack*)
    535        ,instruction)))
    536 
     574  (if (fixnump instr)
     575      `(%%emit ,instr ,@args)
     576      `(%emit ,instr ,@args)))
     577
     578(defun simulate-instruction-effect (instruction)
     579  (setf (instruction-input-locals instruction) *code-locals*)
     580  (setf (instruction-input-stack instruction) *code-stack*)
     581  (funcall (opcode-effect-function (instruction-opcode instruction))
     582     instruction)
     583  (setf (instruction-output-locals instruction) *code-locals*)
     584  (setf (instruction-output-stack instruction) *code-stack*)
     585  instruction)
    537586
    538587;;  Helper routines
    … …  
    620669                      (inst 'aload (car (instruction-args instruction)))
    621670                      (inst 'aconst_null)
    622                       (inst 'putfield (u2 (constant-index
    623              (pool-field +lisp-thread+ "_values"
    624                    +lisp-object-array+))))))
     671                      (inst 'putfield (pool-field +lisp-thread+ "_values"
     672              +lisp-object-array+))))
    625673             (vector-push-extend instruction vector)))
    626674          (t
Note: See TracChangeset for help on using the changeset viewer.