Changeset 12983


Ignore:
Timestamp:
10/25/10 22:17:28 (11 years ago)
Author:
astalla
Message:

[invokedynamic]

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

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

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

Legend:

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

    r12953 r12983  
    797797  (emit-constructor-lambda-list object))
    798798
    799 (defun make-constructor (super lambda-name args)
     799(defun make-constructor (class)
    800800  (let* ((*compiler-debug* nil)
    801801         ;; We don't normally need to see debugging output for constructors.
    802          (method (make-method :constructor :void nil
    803                               :flags '(:public)))
    804          (code (method-add-code method))
    805         req-params-register
     802   (super (class-file-superclass class))
     803   (lambda-name (abcl-class-file-lambda-name class))
     804   (args (abcl-class-file-lambda-list class))
     805  req-params-register
    806806         opt-params-register
    807807         key-params-register
    808808         rest-p
    809809         keys-p
    810          more-keys-p
    811          (*code* ())
    812          (*current-code-attribute* code))
    813     (setf (code-max-locals code) 1)
    814     (unless (eq super +lisp-primitive+)
    815       (multiple-value-bind
    816             (req opt key key-p rest
    817                  allow-other-keys-p)
    818           (parse-lambda-list args)
    819         (setf rest-p rest
    820               more-keys-p allow-other-keys-p
    821               keys-p key-p)
    822         (macrolet
    823             ((parameters-to-array ((param params register) &body body)
    824                (let ((count-sym (gensym)))
    825                  `(progn
    826                     (emit-push-constant-int (length ,params))
    827                     (emit-anewarray +lisp-closure-parameter+)
    828                     (astore (setf ,register (code-max-locals code)))
    829                     (incf (code-max-locals code))
    830                     (do* ((,count-sym 0 (1+ ,count-sym))
    831                           (,params ,params (cdr ,params))
    832                           (,param (car ,params) (car ,params)))
    833                         ((endp ,params))
    834                       (declare (ignorable ,param))
    835                       (aload ,register)
    836                       (emit-push-constant-int ,count-sym)
    837                       (emit-new +lisp-closure-parameter+)
    838                       (emit 'dup)
    839                       ,@body
    840                       (emit 'aastore))))))
    841           ;; process required args
    842           (parameters-to-array (ignore req req-params-register)
    843              (emit-push-t) ;; we don't need the actual symbol
    844              (emit-invokespecial-init +lisp-closure-parameter+
    845                                       (list +lisp-symbol+)))
    846 
    847           (parameters-to-array (param opt opt-params-register)
    848              (emit-push-t) ;; we don't need the actual variable-symbol
    849              (emit-read-from-string (second param)) ;; initform
    850              (if (null (third param))               ;; supplied-p
    851                  (emit-push-nil)
    852                  (emit-push-t)) ;; we don't need the actual supplied-p symbol
    853              (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
    854              (emit-invokespecial-init +lisp-closure-parameter+
    855                                       (list +lisp-symbol+ +lisp-object+
    856                                             +lisp-object+ :int)))
    857 
    858           (parameters-to-array (param key key-params-register)
    859              (let ((keyword (fourth param)))
    860                (if (keywordp keyword)
    861                    (progn
    862                      (emit 'ldc (pool-string (symbol-name keyword)))
    863                      (emit-invokestatic +lisp+ "internKeyword"
    864                                         (list +java-string+) +lisp-symbol+))
    865                    ;; symbol is not really a keyword; yes, that's allowed!
    866                    (progn
    867                      (emit 'ldc (pool-string (symbol-name keyword)))
    868                      (emit 'ldc (pool-string
    869                                  (package-name (symbol-package keyword))))
    870                      (emit-invokestatic +lisp+ "internInPackage"
    871                                         (list +java-string+ +java-string+)
    872                                         +lisp-symbol+))))
    873              (emit-push-t) ;; we don't need the actual variable-symbol
    874              (emit-read-from-string (second (car key)))
    875              (if (null (third param))
    876                  (emit-push-nil)
    877                  (emit-push-t)) ;; we don't need the actual supplied-p symbol
    878              (emit-invokespecial-init +lisp-closure-parameter+
    879                                       (list +lisp-symbol+ +lisp-symbol+
    880                                             +lisp-object+ +lisp-object+))))))
    881     (aload 0) ;; this
    882     (cond ((eq super +lisp-primitive+)
    883            (emit-constructor-lambda-name lambda-name)
    884            (emit-constructor-lambda-list args)
    885            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    886           ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
    887            (aload req-params-register)
    888            (aload opt-params-register)
    889            (aload key-params-register)
    890            (if keys-p
    891                (emit-push-t)
    892                (emit-push-nil-symbol))
    893            (if rest-p
    894                (emit-push-t)
    895                (emit-push-nil-symbol))
    896            (if more-keys-p
    897                (emit-push-t)
    898                (emit-push-nil-symbol))
    899            (emit-invokespecial-init super
    900                                     (list +lisp-closure-parameter-array+
    901                                           +lisp-closure-parameter-array+
    902                                           +lisp-closure-parameter-array+
    903                                           +lisp-symbol+
    904                                           +lisp-symbol+ +lisp-symbol+)))
    905           (t
    906            (aver nil)))
    907     (setf *code* (append *static-code* *code*))
    908     (emit 'return)
    909     (setf (code-code code) *code*)
    910     method))
    911 
    912 
    913 (defun make-static-initializer ()
    914   (let* ((*compiler-debug* nil)
    915          ;; We don't normally need to see debugging output for <clinit>.
    916          (method (make-method :static-initializer
    917             :void nil :flags '(:public :static)))
    918          (code (method-add-code method))
    919          (*code* ())
    920          (*current-code-attribute* code))
    921     (setf (code-max-locals code) 1)
    922     (emit 'ldc (pool-class +lisp-function+))
    923     (emit 'ldc (pool-string "linkLispFunction"))
    924     (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod"
    925            (list +java-class+ +java-string+) :void)
    926     ;(setf *code* (append *static-code* *code*))
    927     (emit 'return)
    928     (setf (code-code code) *code*)
    929     method))
     810         more-keys-p)
     811    (with-code-to-method (class (abcl-class-file-constructor class))
     812      (setf (code-max-locals *current-code-attribute*) 1)
     813      (unless (eq super +lisp-primitive+)
     814  (multiple-value-bind
     815        (req opt key key-p rest
     816       allow-other-keys-p)
     817      (parse-lambda-list args)
     818    (setf rest-p rest
     819    more-keys-p allow-other-keys-p
     820    keys-p key-p)
     821    (macrolet
     822        ((parameters-to-array ((param params register) &body body)
     823     (let ((count-sym (gensym)))
     824       `(progn
     825          (emit-push-constant-int (length ,params))
     826          (emit-anewarray +lisp-closure-parameter+)
     827          (astore (setf ,register (code-max-locals *current-code-attribute*)))
     828          (incf (code-max-locals *current-code-attribute*))
     829          (do* ((,count-sym 0 (1+ ,count-sym))
     830          (,params ,params (cdr ,params))
     831          (,param (car ,params) (car ,params)))
     832         ((endp ,params))
     833      (declare (ignorable ,param))
     834      (aload ,register)
     835      (emit-push-constant-int ,count-sym)
     836      (emit-new +lisp-closure-parameter+)
     837      (emit 'dup)
     838      ,@body
     839      (emit 'aastore))))))
     840      ;; process required args
     841      (parameters-to-array (ignore req req-params-register)
     842               (emit-push-t) ;; we don't need the actual symbol
     843         (emit-invokespecial-init +lisp-closure-parameter+
     844          (list +lisp-symbol+)))
     845
     846      (parameters-to-array (param opt opt-params-register)
     847               (emit-push-t) ;; we don't need the actual variable-symbol
     848         (emit-read-from-string (second param)) ;; initform
     849         (if (null (third param))               ;; supplied-p
     850       (emit-push-nil)
     851       (emit-push-t)) ;; we don't need the actual supplied-p symbol
     852         (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
     853         (emit-invokespecial-init +lisp-closure-parameter+
     854          (list +lisp-symbol+ +lisp-object+
     855                +lisp-object+ :int)))
     856     
     857      (parameters-to-array (param key key-params-register)
     858               (let ((keyword (fourth param)))
     859     (if (keywordp keyword)
     860         (progn
     861           (emit 'ldc (pool-string (symbol-name keyword)))
     862           (emit-invokestatic +lisp+ "internKeyword"
     863            (list +java-string+) +lisp-symbol+))
     864         ;; symbol is not really a keyword; yes, that's allowed!
     865         (progn
     866           (emit 'ldc (pool-string (symbol-name keyword)))
     867           (emit 'ldc (pool-string
     868           (package-name (symbol-package keyword))))
     869           (emit-invokestatic +lisp+ "internInPackage"
     870            (list +java-string+ +java-string+)
     871            +lisp-symbol+))))
     872         (emit-push-t) ;; we don't need the actual variable-symbol
     873         (emit-read-from-string (second (car key)))
     874         (if (null (third param))
     875       (emit-push-nil)
     876       (emit-push-t)) ;; we don't need the actual supplied-p symbol
     877         (emit-invokespecial-init +lisp-closure-parameter+
     878          (list +lisp-symbol+ +lisp-symbol+
     879                +lisp-object+ +lisp-object+))))))
     880      (aload 0) ;; this
     881      (cond ((eq super +lisp-primitive+)
     882       (emit-constructor-lambda-name lambda-name)
     883       (emit-constructor-lambda-list args)
     884       (emit-invokespecial-init super (lisp-object-arg-types 2)))
     885      ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
     886       (aload req-params-register)
     887       (aload opt-params-register)
     888       (aload key-params-register)
     889       (if keys-p
     890     (emit-push-t)
     891     (emit-push-nil-symbol))
     892       (if rest-p
     893     (emit-push-t)
     894     (emit-push-nil-symbol))
     895       (if more-keys-p
     896     (emit-push-t)
     897     (emit-push-nil-symbol))
     898       (emit-invokespecial-init super
     899              (list +lisp-closure-parameter-array+
     900              +lisp-closure-parameter-array+
     901              +lisp-closure-parameter-array+
     902              +lisp-symbol+
     903              +lisp-symbol+ +lisp-symbol+)))
     904      (t
     905       (sys::%format t "MAKE-CONSTRUCTOR doesn't know how to handle superclass ~S~%" super)
     906       (aver nil))))))
     907
     908(defun make-static-initializer (class)
     909  (let ((*compiler-debug* nil))
     910    ;; We don't normally need to see debugging output for <clinit>.
     911    (with-code-to-method (class (abcl-class-file-static-initializer class))
     912      (setf (code-max-locals *current-code-attribute*) 1)
     913      (emit 'ldc (pool-class +lisp-function+))
     914      (emit 'ldc (pool-string "linkLispFunction"))
     915      (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod"
     916       (list +java-class+ +java-string+) :void)
     917      (emit 'return))))
    930918
    931919(defvar *source-line-number* nil)
    932 
    933920
    934921(defun finish-class (class stream)
     
    937924The compiler calls this function to indicate it doesn't want to
    938925extend the class any further."
    939   (class-add-method class (make-constructor (class-file-superclass class)
    940                                             (abcl-class-file-lambda-name class)
    941                                             (abcl-class-file-lambda-list class)))
    942   (class-add-method class (make-static-initializer))
     926  (with-code-to-method (class (abcl-class-file-constructor class))
     927    (emit 'return))
     928  (make-static-initializer class)
    943929  (finalize-class-file class)
    944930  (write-class-file class stream))
     
    11071093on the equality indicator in the `serialization-table'.
    11081094
    1109 Code to restore the serialized object is inserted into `*code' or
    1110 `*static-code*' if `*declare-inline*' is non-nil.
     1095Code to restore the serialized object is inserted into the current method or
     1096the constructor if `*declare-inline*' is non-nil.
    11111097"
    11121098  ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which
     
    11381124      (cond
    11391125        ((not *file-compilation*)
    1140          (let ((*code* *static-code*))
     1126   (with-code-to-method
     1127       (*class-file* (abcl-class-file-constructor *class-file*))
    11411128           (remember field-name object)
    11421129           (emit 'ldc (pool-string field-name))
     
    11451132           (when (not (eq field-type +lisp-object+))
    11461133             (emit-checkcast field-type))
    1147            (emit-putstatic *this-class* field-name field-type)
    1148            (setf *static-code* *code*)))
     1134           (emit-putstatic *this-class* field-name field-type)))
    11491135        (*declare-inline*
    11501136         (funcall dispatch-fn object)
    11511137         (emit-putstatic *this-class* field-name field-type))
    11521138        (t
    1153          (let ((*code* *static-code*))
     1139   (with-code-to-method
     1140       (*class-file* (abcl-class-file-constructor *class-file*))
    11541141           (funcall dispatch-fn object)
    1155            (emit-putstatic *this-class* field-name field-type)
    1156            (setf *static-code* *code*))))
     1142           (emit-putstatic *this-class* field-name field-type))))
    11571143
    11581144      (emit-getstatic *this-class* field-name field-type)
     
    11841170                       (declare-object symbol))
    11851171              class *this-class*))
    1186      (let (saved-code)
    1187        (let ((*code* (if *declare-inline* *code* *static-code*)))
    1188          (if (eq class *this-class*)
    1189              (progn ;; generated by the DECLARE-OBJECT*'s above
    1190                (emit-getstatic class name +lisp-object+)
    1191                (emit-checkcast +lisp-symbol+))
    1192              (emit-getstatic class name +lisp-symbol+))
    1193          (emit-invokevirtual +lisp-symbol+
    1194                              (if setf
    1195                                  "getSymbolSetfFunctionOrDie"
    1196                                  "getSymbolFunctionOrDie")
    1197                              nil +lisp-object+)
    1198          ;; make sure we're not cacheing a proxied function
    1199          ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
    1200          (emit-invokevirtual +lisp-object+
    1201                              "resolve" nil +lisp-object+)
    1202          (emit-putstatic *this-class* f +lisp-object+)
    1203          (if *declare-inline*
    1204              (setf saved-code *code*)
    1205              (setf *static-code* *code*))
    1206          (setf (gethash symbol ht) f))
    1207        (when *declare-inline*
    1208          (setf *code* saved-code))
    1209        f))))
     1172     (with-code-to-method (*class-file*
     1173         (if *declare-inline* *method*
     1174             (abcl-class-file-constructor *class-file*)))
     1175       (if (eq class *this-class*)
     1176     (progn ;; generated by the DECLARE-OBJECT*'s above
     1177       (emit-getstatic class name +lisp-object+)
     1178       (emit-checkcast +lisp-symbol+))
     1179     (emit-getstatic class name +lisp-symbol+))
     1180       (emit-invokevirtual +lisp-symbol+
     1181         (if setf
     1182             "getSymbolSetfFunctionOrDie"
     1183             "getSymbolFunctionOrDie")
     1184         nil +lisp-object+)
     1185       ;; make sure we're not cacheing a proxied function
     1186       ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
     1187       (emit-invokevirtual +lisp-object+
     1188         "resolve" nil +lisp-object+)
     1189       (emit-putstatic *this-class* f +lisp-object+))
     1190     (setf (gethash symbol ht) f)
     1191     f)))
    12101192
    12111193(defknown declare-setf-function (name) string)
     
    12191201   local-function *declared-functions* ht g
    12201202   (setf g (symbol-name (gensym "LFUN")))
    1221    (let* ((class-name (abcl-class-file-class-name
    1222                        (local-function-class-file local-function)))
    1223           (*code* *static-code*))
     1203   (let ((class-name (abcl-class-file-class-name
     1204          (local-function-class-file local-function))))
     1205     (with-code-to-method
     1206   (*class-file* (abcl-class-file-constructor *class-file*))
    12241207     ;; fixme *declare-inline*
    1225      (declare-field g +lisp-object+)
    1226      (emit-new class-name)
    1227      (emit 'dup)
    1228      (emit-invokespecial-init class-name '())
    1229      (emit-putstatic *this-class* g +lisp-object+)
    1230      (setf *static-code* *code*)
    1231      (setf (gethash local-function ht) g))))
     1208       (declare-field g +lisp-object+)
     1209       (emit-new class-name)
     1210       (emit 'dup)
     1211       (emit-invokespecial-init class-name '())
     1212       (emit-putstatic *this-class* g +lisp-object+)
     1213       (setf (gethash local-function ht) g)))))
    12321214
    12331215
     
    12421224  ;;  EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and*
    12431225  ;;  emits the right loading code (not just de-serialization anymore)
    1244   (let (saved-code
    1245         (g (symbol-name (gensym "OBJSTR"))))
    1246     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
    1247            (*code* (if *declare-inline* *code* *static-code*)))
    1248       ;; strings may contain evaluated bits which may depend on
    1249       ;; previous statements
    1250       (declare-field g +lisp-object+)
    1251       (emit 'ldc (pool-string s))
    1252       (emit-invokestatic +lisp+ "readObjectFromString"
    1253                          (list +java-string+) +lisp-object+)
    1254       (emit-putstatic *this-class* g +lisp-object+)
    1255       (if *declare-inline*
    1256           (setf saved-code *code*)
    1257           (setf *static-code* *code*)))
    1258     (when *declare-inline*
    1259       (setf *code* saved-code))
    1260     g))
     1226  (let ((g (symbol-name (gensym "OBJSTR")))
     1227  (s (with-output-to-string (stream) (dump-form obj stream))))
     1228     (with-code-to-method
     1229   (*class-file*
     1230    (if *declare-inline* *method*
     1231        (abcl-class-file-constructor *class-file*)))
     1232       ;; strings may contain evaluated bits which may depend on
     1233       ;; previous statements
     1234       (declare-field g +lisp-object+)
     1235       (emit 'ldc (pool-string s))
     1236       (emit-invokestatic +lisp+ "readObjectFromString"
     1237        (list +java-string+) +lisp-object+)
     1238       (emit-putstatic *this-class* g +lisp-object+))
     1239     g))
    12611240
    12621241(defun declare-load-time-value (obj)
    12631242  (let ((g (symbol-name (gensym "LTV")))
    1264         saved-code)
    1265     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
    1266            (*code* (if *declare-inline* *code* *static-code*)))
    1267       ;; The readObjectFromString call may require evaluation of
    1268       ;; lisp code in the string (think #.() syntax), of which the outcome
    1269       ;; may depend on something which was declared inline
    1270       (declare-field g +lisp-object+)
    1271       (emit 'ldc (pool-string s))
    1272       (emit-invokestatic +lisp+ "readObjectFromString"
    1273                          (list +java-string+) +lisp-object+)
    1274       (emit-invokestatic +lisp+ "loadTimeValue"
    1275                          (lisp-object-arg-types 1) +lisp-object+)
    1276       (emit-putstatic *this-class* g +lisp-object+)
    1277       (if *declare-inline*
    1278           (setf saved-code *code*)
    1279           (setf *static-code* *code*)))
    1280     (when *declare-inline*
    1281       (setf *code* saved-code))
     1243  (s (with-output-to-string (stream) (dump-form obj stream))))
     1244     (with-code-to-method
     1245   (*class-file*
     1246    (if *declare-inline* *method*
     1247        (abcl-class-file-constructor *class-file*)))
     1248       ;; The readObjectFromString call may require evaluation of
     1249       ;; lisp code in the string (think #.() syntax), of which the outcome
     1250       ;; may depend on something which was declared inline
     1251       (declare-field g +lisp-object+)
     1252       (emit 'ldc (pool-string s))
     1253       (emit-invokestatic +lisp+ "readObjectFromString"
     1254        (list +java-string+) +lisp-object+)
     1255       (emit-invokestatic +lisp+ "loadTimeValue"
     1256        (lisp-object-arg-types 1) +lisp-object+)
     1257       (emit-putstatic *this-class* g +lisp-object+))
    12821258    g))
    12831259
     
    12911267    ;; fixme *declare-inline*?
    12921268    (remember g obj)
    1293     (let* ((*code* *static-code*))
     1269    (with-code-to-method
     1270  (*class-file* (abcl-class-file-constructor *class-file*))
    12941271      (declare-field g +lisp-object+)
    12951272      (emit 'ldc (pool-string g))
    12961273      (emit-invokestatic +lisp+ "recall"
    12971274                         (list +java-string+) +lisp-object+)
    1298       (emit-putstatic *this-class* g +lisp-object+)
    1299       (setf *static-code* *code*)
    1300       g)))
     1275      (emit-putstatic *this-class* g +lisp-object+))
     1276    g))
    13011277
    13021278(defknown compile-constant (t t t) t)
     
    38243800                                   :if-exists :supersede)))
    38253801      (with-class-file class-file
     3802  (make-constructor class-file)
    38263803        (let ((*current-compiland* compiland))
    38273804          (with-saved-compiler-policy
     
    68766853                               :flags '(:final :public)))
    68776854         (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))
    68786857         (*current-code-attribute* code)
    68796858         (*code* ())
     
    68846863         (*thread* nil)
    68856864         (*initialize-thread-var* nil)
    6886          (label-START (gensym)))
     6865         (label-START (gensym))
     6866   prologue)
    68876867
    68886868    (class-add-method class-file method)
     
    68966876    (dolist (var (compiland-free-specials compiland))
    68976877      (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    ;;;;
    68986908
    68996909    (when *using-arg-array*
     
    70407050
    70417051    ;; Go back and fill in prologue.
    7042     (let ((code *code*))
     7052    #+nil (let ((code *code*))
    70437053      (setf *code* ())
    70447054      (let ((arity (compiland-arity compiland)))
     
    70677077        (maybe-initialize-thread-var))
    70687078      (setf *code* (nconc code *code*)))
     7079   
     7080    (setf *code* (nconc prologue *code*))
    70697081
    70707082    (setf (abcl-class-file-superclass class-file)
     
    70777089    (setf (code-max-locals code) *registers-allocated*)
    70787090    (setf (code-code code) *code*))
    7079 
    7080 
    70817091  t)
    70827092
     
    71237133
    71247134    (with-class-file (compiland-class-file compiland)
     7135      (make-constructor *class-file*)
    71257136      (with-saved-compiler-policy
    71267137        (p2-compiland compiland)
  • branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12980 r12983  
    292292(defstruct (constant-member-ref (:constructor
    293293                                 %make-constant-member-ref
    294                                      (tag index class-index name/type-index))
     294                                     (tag index class name/type))
    295295                                (:include constant))
    296296  "Structure holding information on a member reference type item
    297297(a field, method or interface method reference) in the constant pool."
    298   class-index
    299   name/type-index)
     298  class
     299  name/type)
    300300
    301301(declaim (inline make-constant-field-ref make-constant-method-ref
    302302                 make-constant-interface-method-ref))
    303 (defun make-constant-field-ref (index class-index name/type-index)
     303(defun make-constant-field-ref (index class name/type)
    304304  "Creates a `constant-member-ref' instance containing a field reference."
    305   (%make-constant-member-ref 9 index class-index name/type-index))
    306 
    307 (defun make-constant-method-ref (index class-index name/type-index)
     305  (%make-constant-member-ref 9 index class name/type))
     306
     307(defun make-constant-method-ref (index class name/type)
    308308  "Creates a `constant-member-ref' instance containing a method reference."
    309   (%make-constant-member-ref 10 index class-index name/type-index))
    310 
    311 (defun make-constant-interface-method-ref (index class-index name/type-index)
     309  (%make-constant-member-ref 10 index class name/type))
     310
     311(defun make-constant-interface-method-ref (index class name/type)
    312312  "Creates a `constant-member-ref' instance containing an
    313313interface-method reference."
    314   (%make-constant-member-ref 11 index class-index name/type-index))
     314  (%make-constant-member-ref 11 index class name/type))
    315315
    316316(defstruct (constant-string (:constructor
     
    355355(defstruct (constant-name/type (:constructor
    356356                                make-constant-name/type (index
    357                                                          name-index
    358                                                          descriptor-index))
     357                                                         name
     358                                                         descriptor))
    359359                               (:include constant
    360360                                         (tag 12)))
    361361  "Structure holding information on a 'name-and-type' type item in the
    362362constant pool; this type of element is used by 'member-ref' type items."
    363   name-index
    364   descriptor-index)
     363  name
     364  descriptor)
    365365
    366366(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
     
    396396  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    397397    (unless entry
    398       (let ((c (constant-index (pool-add-class pool class)))
    399             (n/t (constant-index (pool-add-name/type pool name type))))
     398      (let ((c (pool-add-class pool class))
     399            (n/t (pool-add-name/type pool name type)))
    400400        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
    401401            (gethash (acons name type class) (pool-entries pool)) entry))
     
    411411  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    412412    (unless entry
    413       (let ((c (constant-index (pool-add-class pool class)))
    414             (n/t (constant-index (pool-add-name/type pool name type))))
     413      (let ((c (pool-add-class pool class))
     414            (n/t (pool-add-name/type pool name type)))
    415415        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
    416416              (gethash (acons name type class) (pool-entries pool)) entry))
     
    425425  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    426426    (unless entry
    427       (let ((c (constant-index (pool-add-class pool class)))
    428             (n/t (constant-index (pool-add-name/type pool name type))))
     427      (let ((c (pool-add-class pool class))
     428            (n/t (pool-add-name/type pool name type)))
    429429        (setf entry
    430430            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
     
    492492                           (internal-field-ref type))))
    493493    (unless entry
    494       (let ((n (constant-index (pool-add-utf8 pool name)))
    495             (i-t (constant-index (pool-add-utf8 pool internal-type))))
     494      (let ((n (pool-add-utf8 pool name))
     495            (i-t (pool-add-utf8 pool internal-type)))
    496496        (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
    497497              (gethash (cons name type) (pool-entries pool)) entry))
     
    734734                     stream))
    735735          ((9 10 11)           ; fieldref methodref InterfaceMethodref
    736            (write-u2 (constant-member-ref-class-index entry) stream)
    737            (write-u2 (constant-member-ref-name/type-index entry) stream))
     736           (write-u2 (constant-index (constant-member-ref-class entry)) stream)
     737           (write-u2 (constant-index (constant-member-ref-name/type entry)) stream))
    738738          (12                           ; nameAndType
    739            (write-u2 (constant-name/type-name-index entry) stream)
    740            (write-u2 (constant-name/type-descriptor-index entry) stream))
     739           (write-u2 (constant-index (constant-name/type-name entry)) stream)
     740           (write-u2 (constant-index (constant-name/type-descriptor entry)) stream))
    741741          (7                            ; class
    742742           (write-u2 (constant-class-name-index entry) stream))
     
    758758      ((9 10 11) (sys::%format t "ref: ~a,~a~%"
    759759                               (constant-member-ref-class-index entry)
    760                                (constant-member-ref-name/type-index entry)))
     760                               (constant-member-ref-name/type entry)))
    761761      (12 (sys::%format t "n/t: ~a,~a~%"
    762                         (constant-name/type-name-index entry)
    763                         (constant-name/type-descriptor-index entry)))
     762                        (constant-name/type-name entry)
     763                        (constant-name/type-descriptor entry)))
    764764      (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry)))
    765765      (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
     
    848848  name
    849849  descriptor
    850   attributes
    851   initial-locals)
     850  attributes)
    852851
    853852
     
    883882  (method-add-attribute
    884883   method
    885    (make-code-attribute (+ (length (cdr (method-descriptor method)))
    886                            (if (member :static (method-access-flags method))
    887                                0 1))))) ;; 1 == implicit 'this'
     884   (make-code-attribute (compute-initial-method-locals method))))
    888885
    889886(defun method-ensure-code (method)
     
    904901  "Prepares `method' for serialization."
    905902  (let ((pool (class-file-constants class)))
    906     (setf (method-initial-locals method)
    907     (compute-initial-method-locals class method)
    908     (method-access-flags method)
     903    (setf (method-access-flags method)
    909904          (map-flags (method-access-flags method))
    910905          (method-descriptor method)
     
    980975  labels ;; an alist
    981976
    982   ;; these two are used for handling nested WITH-CODE-TO-METHOD blocks
     977  ;; these are used for handling nested WITH-CODE-TO-METHOD blocks
    983978  (current-local 0)
    984   stack-map-frames)
     979  computed-locals
     980  computed-stack)
    985981
    986982
     
    10661062  (write-attributes (code-attributes code) stream))
    10671063
    1068 (defun make-code-attribute (arg-count)
     1064(defun make-code-attribute (locals)
    10691065  "Creates an empty 'Code' attribute for a method which takes
    10701066`arg-count` parameters, including the implicit `this` parameter."
    1071   (%make-code-attribute :max-locals arg-count))
     1067  (%make-code-attribute :max-locals (length locals)
     1068      :computed-locals locals))
    10721069
    10731070(defun code-add-attribute (code attribute)
     
    10981095  (let* ((length 0)
    10991096   labels ;; alist
    1100    stack-map-table
    1101    (*basic-block* (when compute-stack-map-table-p
     1097   stack-map-table)
     1098#||  (*basic-block* (when compute-stack-map-table-p
    11021099        (make-basic-block
    11031100         :offset 0
     
    11051102         (method-initial-locals method))))
    11061103   (root-block *basic-block*)
    1107    *basic-blocks*)
     1104   *basic-blocks*)||#
     1105    compute-stack-map-table-p :todo
    11081106    (declare (type (unsigned-byte 16) length))
    11091107    ;; Pass 1: calculate label offsets and overall length.
     
    11121110      (let* ((instruction (aref code i))
    11131111             (opcode (instruction-opcode instruction)))
     1112  (setf (instruction-offset instruction) length)
    11141113        (if (= opcode 202) ; LABEL
    11151114            (let ((label (car (instruction-args instruction))))
    11161115              (set label length)
    11171116              (setf labels
    1118                     (acons label length labels))
    1119         (incf length (opcode-size opcode))))))
     1117                    (acons label length labels)))
     1118      (incf length (opcode-size opcode)))))
    11201119    ;; Pass 2: replace labels with calculated offsets.
    11211120    (let ((index 0))
     
    11301129                              index)))
    11311130              (setf (instruction-args instruction) (s2 offset))))
    1132     (when compute-stack-map-table-p
    1133       (funcall (opcode-effect-function opcode)
    1134          instruction index))
    11351131          (unless (= (instruction-opcode instruction) 202) ; LABEL
    11361132            (incf index (opcode-size (instruction-opcode instruction)))))))
     
    12151211
    12161212(defvar *current-code-attribute* nil)
     1213(defvar *method* nil)
    12171214
    12181215(defun save-code-specials (code)
     
    12341231         (save-code-specials *current-code-attribute*))
    12351232       (let* ((,m ,method)
     1233        (*method* ,m)
    12361234              (,c (method-ensure-code ,method))
    12371235              (*pool* (class-file-constants ,class-file))
    12381236              (*code* (code-code ,c))
     1237              (*code-locals* (code-computed-locals ,c))
     1238        (*code-stack* (code-computed-stack ,c))
    12391239              (*registers-allocated* (code-max-locals ,c))
    12401240              (*register* (code-current-local ,c))
     
    12431243         (setf (code-code ,c) *code*
    12441244               (code-current-local ,c) *register*
    1245                (code-max-locals ,c) *registers-allocated*))
     1245               (code-max-locals ,c) *registers-allocated*
     1246         (code-computed-locals ,c) *code-locals*
     1247         (code-computed-stack ,c) *code-stack*))
    12461248       (when *current-code-attribute*
    12471249         (restore-code-specials *current-code-attribute*)))))
     
    14261428  (write-u2 (uninitialized-variable-info-offset vti) stream))
    14271429
    1428 (defconst *opcode-effect-table*
    1429   (make-array 256 :initial-element #'(lambda (&rest args) (car args))))
    1430 
    1431 (defun opcode-effect-function (opcode)
    1432   (svref *opcode-effect-table* opcode))
    1433 
    1434 (defstruct basic-block label offset input-locals input-stack output-locals output-stack successors)
    1435 
    1436 (defun basic-block-add-successor (basic-block successor)
    1437   (push successor (basic-block-successors basic-block)))
    1438 
    1439 (defvar *basic-block*)
    1440 (defvar *basic-blocks* nil "An alist that associates labels with corresponding basic blocks")
    1441 
    1442 (defun label-basic-block (label)
    1443   (or (cdr (assoc label *basic-blocks*))
    1444       (setf (assoc label *basic-blocks*)
    1445       (make-basic-block :label label
    1446             :offset (symbol-value label)))))
    1447 
    1448 (defmacro define-opcode-effect (opcode &body body)
    1449   `(setf (svref *opcode-effect-table*
    1450     (opcode-number ',opcode))
    1451    (if (and (symbolp (car body)) (null (cdr body)))
    1452        `(function ,(car body))
    1453        #'(lambda (instruction offset)
    1454      (declare (ignorable instruction offset))
    1455      ,@body))))
    1456 
    1457 (defun compute-initial-method-locals (class method)
     1430(defun compute-initial-method-locals (method)
    14581431  (let (locals)
    14591432    (unless (member :static (method-access-flags method))
     
    14621435    (push :uninitialized-this locals)
    14631436    ;;the method is an instance method.
    1464     (push (class-file-class class) locals)))
     1437    (push :this locals)))
    14651438    (dolist (x (cdr (method-descriptor method)))
    14661439      (push x locals))
     
    14681441
    14691442(defun smf-type->variable-info (type)
    1470   (case type))
    1471 
    1472 (defun smf-get (pos)
    1473   (or (nth pos (basic-block-output-locals *basic-block*))
    1474       (error "Locals inconsistency: get ~A but locals are ~A"
    1475        pos (length (basic-block-output-locals *basic-block*)))))
    1476 
    1477 (defun smf-set (pos type)
    1478   (if (< pos (length (basic-block-output-locals *basic-block*)))
    1479       (setf (nth pos (basic-block-output-locals *basic-block*)) type)
    1480       (progn
    1481   (setf (basic-block-output-locals *basic-block*)
    1482         (append (basic-block-output-locals *basic-block*) (list nil)))
    1483   (smf-set pos type))))
    1484 
    1485 (defun smf-push (type)
    1486   (push type (basic-block-output-stack *basic-block*))
    1487   (when (or (eq type :long) (eq type :double))
    1488     (push :top (basic-block-output-stack *basic-block*))))
    1489 
    1490 (defun smf-pop ()
    1491   (pop (basic-block-output-stack *basic-block*)))
    1492 
    1493 (defun smf-popn (n)
    1494   (dotimes (i n)
    1495     (pop (basic-block-output-stack *basic-block*))))
    1496 
    1497 (defun smf-element-of (type)
    1498   (if (and (consp type) (eq (car type) :array-of))
    1499       (cdr type)
    1500       (cons :element-of type)))
    1501 
    1502 (defun smf-array-of (type)
    1503   (if (and (consp type) (eq (car type) :element-of))
    1504       (cdr type)
    1505       (cons :array-of type)))
    1506 
    1507 (define-opcode-effect aconst_null (smf-push :null))
    1508 (define-opcode-effect iconst_m1 (smf-push :int))
    1509 (define-opcode-effect iconst_0 (smf-push :int))
    1510 (define-opcode-effect iconst_1 (smf-push :int))
    1511 (define-opcode-effect iconst_2 (smf-push :int))
    1512 (define-opcode-effect iconst_3 (smf-push :int))
    1513 (define-opcode-effect iconst_4 (smf-push :int))
    1514 (define-opcode-effect iconst_5 (smf-push :int))
    1515 (define-opcode-effect lconst_0 (smf-push :long))
    1516 (define-opcode-effect lconst_1 (smf-push :long))
    1517 (define-opcode-effect fconst_0 (smf-push :float))
    1518 (define-opcode-effect fconst_1 (smf-push :float))
    1519 (define-opcode-effect fconst_2 (smf-push :float))
    1520 (define-opcode-effect dconst_0 (smf-push :double))
    1521 (define-opcode-effect dconst_1 (smf-push :double))
    1522 (define-opcode-effect bipush (smf-push :int))
    1523 (define-opcode-effect sipush (smf-push :int))
    1524 (define-opcode-effect ldc (smf-push (car (instruction-args instruction))))
    1525 (define-opcode-effect iload (smf-push :int))
    1526 (define-opcode-effect lload (smf-push :long))
    1527 (define-opcode-effect fload (smf-push :float))
    1528 (define-opcode-effect dload (smf-push :double))
    1529 (define-opcode-effect aload
    1530     (smf-push (smf-get (car (instruction-args instruction)))))
    1531 (define-opcode-effect iload_0 (smf-push :int))
    1532 (define-opcode-effect iload_1 (smf-push :int))
    1533 (define-opcode-effect iload_2 (smf-push :int))
    1534 (define-opcode-effect iload_3 (smf-push :int))
    1535 (define-opcode-effect lload_0 (smf-push :long))
    1536 (define-opcode-effect lload_1 (smf-push :long))
    1537 (define-opcode-effect lload_2 (smf-push :long))
    1538 (define-opcode-effect lload_3 (smf-push :long))
    1539 (define-opcode-effect fload_0 (smf-push :float))
    1540 (define-opcode-effect fload_1 (smf-push :float))
    1541 (define-opcode-effect fload_2 (smf-push :float))
    1542 (define-opcode-effect fload_3 (smf-push :float))
    1543 (define-opcode-effect dload_0 (smf-push :double))
    1544 (define-opcode-effect dload_1 (smf-push :double))
    1545 (define-opcode-effect dload_2 (smf-push :double))
    1546 (define-opcode-effect dload_3 (smf-push :double))
    1547 #|(define-opcode-effect aload_0 42 1 1)
    1548 (define-opcode-effect aload_1 43 1 1)
    1549 (define-opcode-effect aload_2 44 1 1)
    1550 (define-opcode-effect aload_3 45 1 1)|#
    1551 (define-opcode-effect iaload (smf-popn 2) (smf-push :int))
    1552 (define-opcode-effect laload (smf-popn 2) (smf-push :long))
    1553 (define-opcode-effect faload (smf-popn 2) (smf-push :float))
    1554 (define-opcode-effect daload (smf-popn 2) (smf-push :double))
    1555 #+nil ;;until there's newarray
    1556 (define-opcode-effect aaload
    1557          (progn
    1558      (smf-pop)
    1559      (smf-push (smf-element-of (smf-pop)))))
    1560 (define-opcode-effect baload (smf-popn 2) (smf-push :int))
    1561 (define-opcode-effect caload (smf-popn 2) (smf-push :int))
    1562 (define-opcode-effect saload (smf-popn 2) (smf-push :int))
    1563 
    1564 (defun iaf-store-effect (instruction offset)
    1565   (declare (ignore offset))
    1566   (let ((t1 (smf-pop))
    1567     (arg (car (instruction-args instruction))))
    1568       (smf-set arg t1)
    1569       (when (> arg 0)
    1570   (let ((t2 (smf-get (1- arg))))
    1571     (when (or (eq t2 :long) (eq t2 :double))
    1572       (smf-set (1- arg) :top))))))
    1573 
    1574 (defun ld-store-effect (instruction offset)
    1575   (declare (ignore offset))
    1576   (smf-pop)
    1577   (let ((t1 (smf-pop))
    1578     (arg (car (instruction-args instruction))))
    1579       (smf-set arg t1)
    1580       (smf-set (1+ arg) :top)
    1581       (when (> arg 0)
    1582   (let ((t2 (smf-get (1- arg))))
    1583     (when (or (eq t2 :long) (eq t2 :double))
    1584       (smf-set (1- arg) :top))))))
    1585 
    1586 (define-opcode-effect istore iaf-store-effect)
    1587 (define-opcode-effect lstore ld-store-effect)
    1588 (define-opcode-effect fstore iaf-store-effect)
    1589 (define-opcode-effect dstore ld-store-effect)
    1590 (define-opcode-effect astore iaf-store-effect)
    1591 #|(define-opcode istore_0 59 1 -1)
    1592 (define-opcode istore_1 60 1 -1)
    1593 (define-opcode istore_2 61 1 -1)
    1594 (define-opcode istore_3 62 1 -1)
    1595 (define-opcode lstore_0 63 1 -2)
    1596 (define-opcode lstore_1 64 1 -2)
    1597 (define-opcode lstore_2 65 1 -2)
    1598 (define-opcode lstore_3 66 1 -2)
    1599 (define-opcode fstore_0 67 1 nil)
    1600 (define-opcode fstore_1 68 1 nil)
    1601 (define-opcode fstore_2 69 1 nil)
    1602 (define-opcode fstore_3 70 1 nil)
    1603 (define-opcode dstore_0 71 1 nil)
    1604 (define-opcode dstore_1 72 1 nil)
    1605 (define-opcode dstore_2 73 1 nil)
    1606 (define-opcode dstore_3 74 1 nil)
    1607 (define-opcode astore_0 75 1 -1)|#
    1608 ;;TODO
    1609 #|(define-opcode astore_1 76 1 -1)
    1610 (define-opcode astore_2 77 1 -1)
    1611 (define-opcode astore_3 78 1 -1)
    1612 (define-opcode iastore 79 1 -3)
    1613 (define-opcode lastore 80 1 -4)
    1614 (define-opcode fastore 81 1 -3)
    1615 (define-opcode dastore 82 1 -4)
    1616 (define-opcode aastore 83 1 -3)
    1617 (define-opcode bastore 84 1 nil)
    1618 (define-opcode castore 85 1 nil)
    1619 (define-opcode sastore 86 1 nil)
    1620 (define-opcode pop 87 1 -1)
    1621 (define-opcode pop2 88 1 -2)
    1622 (define-opcode dup 89 1 1)
    1623 (define-opcode dup_x1 90 1 1)
    1624 (define-opcode dup_x2 91 1 1)
    1625 (define-opcode dup2 92 1 2)
    1626 (define-opcode dup2_x1 93 1 2)
    1627 (define-opcode dup2_x2 94 1 2)
    1628 (define-opcode swap 95 1 0)
    1629 (define-opcode iadd 96 1 -1)
    1630 (define-opcode ladd 97 1 -2)
    1631 (define-opcode fadd 98 1 -1)
    1632 (define-opcode dadd 99 1 -2)
    1633 (define-opcode isub 100 1 -1)
    1634 (define-opcode lsub 101 1 -2)
    1635 (define-opcode fsub 102 1 -1)
    1636 (define-opcode dsub 103 1 -2)
    1637 (define-opcode imul 104 1 -1)
    1638 (define-opcode lmul 105 1 -2)
    1639 (define-opcode fmul 106 1 -1)
    1640 (define-opcode dmul 107 1 -2)
    1641 (define-opcode idiv 108 1 nil)
    1642 (define-opcode ldiv 109 1 nil)
    1643 (define-opcode fdiv 110 1 nil)
    1644 (define-opcode ddiv 111 1 nil)
    1645 (define-opcode irem 112 1 nil)
    1646 (define-opcode lrem 113 1 nil)
    1647 (define-opcode frem 114 1 nil)
    1648 (define-opcode drem 115 1 nil)
    1649 (define-opcode ineg 116 1 0)
    1650 (define-opcode lneg 117 1 0)
    1651 (define-opcode fneg 118 1 0)
    1652 (define-opcode dneg 119 1 0)
    1653 (define-opcode ishl 120 1 -1)
    1654 (define-opcode lshl 121 1 -1)
    1655 (define-opcode ishr 122 1 -1)
    1656 (define-opcode lshr 123 1 -1)
    1657 (define-opcode iushr 124 1 nil)
    1658 (define-opcode lushr 125 1 nil)
    1659 (define-opcode iand 126 1 -1)
    1660 (define-opcode land 127 1 -2)
    1661 (define-opcode ior 128 1 -1)
    1662 (define-opcode lor 129 1 -2)
    1663 (define-opcode ixor 130 1 -1)
    1664 (define-opcode lxor 131 1 -2)
    1665 (define-opcode iinc 132 3 0)
    1666 (define-opcode i2l 133 1 1)
    1667 (define-opcode i2f 134 1 0)
    1668 (define-opcode i2d 135 1 1)
    1669 (define-opcode l2i 136 1 -1)
    1670 (define-opcode l2f 137 1 -1)
    1671 (define-opcode l2d 138 1 0)
    1672 (define-opcode f2i 139 1 nil)
    1673 (define-opcode f2l 140 1 nil)
    1674 (define-opcode f2d 141 1 1)
    1675 (define-opcode d2i 142 1 nil)
    1676 (define-opcode d2l 143 1 nil)
    1677 (define-opcode d2f 144 1 -1)
    1678 (define-opcode i2b 145 1 nil)
    1679 (define-opcode i2c 146 1 nil)
    1680 (define-opcode i2s 147 1 nil)
    1681 (define-opcode lcmp 148 1 -3)
    1682 (define-opcode fcmpl 149 1 -1)
    1683 (define-opcode fcmpg 150 1 -1)
    1684 (define-opcode dcmpl 151 1 -3)
    1685 (define-opcode dcmpg 152 1 -3)
    1686 (define-opcode ifeq 153 3 -1)
    1687 (define-opcode ifne 154 3 -1)
    1688 (define-opcode iflt 155 3 -1)
    1689 (define-opcode ifge 156 3 -1)
    1690 (define-opcode ifgt 157 3 -1)
    1691 (define-opcode ifle 158 3 -1)
    1692 (define-opcode if_icmpeq 159 3 -2)
    1693 (define-opcode if_icmpne 160 3 -2)
    1694 (define-opcode if_icmplt 161 3 -2)
    1695 (define-opcode if_icmpge 162 3 -2)
    1696 (define-opcode if_icmpgt 163 3 -2)
    1697 (define-opcode if_icmple 164 3 -2)
    1698 (define-opcode if_acmpeq 165 3 -2)
    1699 (define-opcode if_acmpne 166 3 -2)
    1700 (define-opcode goto 167 3 0)
    1701 ;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
    1702 ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
    1703 (define-opcode tableswitch 170 0 nil)
    1704 (define-opcode lookupswitch 171 0 nil)
    1705 (define-opcode ireturn 172 1 nil)
    1706 (define-opcode lreturn 173 1 nil)
    1707 (define-opcode freturn 174 1 nil)
    1708 (define-opcode dreturn 175 1 nil)
    1709 (define-opcode areturn 176 1 -1)
    1710 (define-opcode return 177 1 0)
    1711 (define-opcode getstatic 178 3 1)
    1712 (define-opcode putstatic 179 3 -1)
    1713 (define-opcode getfield 180 3 0)
    1714 (define-opcode putfield 181 3 -2)
    1715 (define-opcode invokevirtual 182 3 nil)
    1716 (define-opcode invokespecial 183 3 nil)
    1717 (define-opcode invokestatic 184 3 nil)
    1718 (define-opcode invokeinterface 185 5 nil)
    1719 (define-opcode unused 186 0 nil)
    1720 (define-opcode new 187 3 1)
    1721 (define-opcode newarray 188 2 nil)
    1722 (define-opcode anewarray 189 3 0)
    1723 (define-opcode arraylength 190 1 0)
    1724 (define-opcode athrow 191 1 0)
    1725 (define-opcode checkcast 192 3 0)
    1726 (define-opcode instanceof 193 3 0)
    1727 (define-opcode monitorenter 194 1 -1)
    1728 (define-opcode monitorexit 195 1 -1)
    1729 (define-opcode wide 196 0 nil)
    1730 (define-opcode multianewarray 197 4 nil)
    1731 (define-opcode ifnull 198 3 -1)
    1732 (define-opcode ifnonnull 199 3 nil)
    1733 (define-opcode goto_w 200 5 nil)
    1734 ;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
    1735 (define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
    1736 ;; (define-opcode push-value 203 nil 1)
    1737 ;; (define-opcode store-value 204 nil -1)
    1738 (define-opcode clear-values 205 0 0)  ;; virtual: does not exist in the JVM
    1739 ;;(define-opcode var-ref 206 0 0)|#
     1443  :todo)
    17401444
    17411445#|
  • branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12980 r12983  
    3232(in-package #:jvm)
    3333
    34 
    3534;;    OPCODES
    3635
     
    3938(defconst *opcodes* (make-hash-table :test 'equalp))
    4039
    41 (defstruct jvm-opcode name number size stack-effect)
    42 
    43 (defun %define-opcode (name number size stack-effect)
     40(defstruct jvm-opcode name number size stack-effect effect-function)
     41
     42(defun %define-opcode (name number size stack-effect effect-function)
    4443  (declare (type fixnum number size))
    4544  (let* ((name (string name))
     
    4746                                  :number number
    4847                                  :size size
    49                                   :stack-effect stack-effect)))
     48                                  :stack-effect stack-effect
     49          :effect-function effect-function)))
    5050     (setf (svref *opcode-table* number) opcode)
    5151     (setf (gethash name *opcodes*) opcode)
    5252     (setf (gethash number *opcodes*) opcode)))
    5353
    54 (defmacro define-opcode (name number size stack-effect)
    55   `(%define-opcode ',name ,number ,size ,stack-effect))
     54(defmacro define-opcode (name number size stack-effect &body body)
     55  `(%define-opcode ',name ,number ,size ,stack-effect
     56       ,(if (and (symbolp (car body)) (null (cdr body)))
     57      (if (null (car body))
     58          #'identity
     59          `(function ,(car body)))
     60      `(lambda (instruction)
     61         (declare (ignorable instruction))
     62         ,@body))))
    5663
    5764;; name number size stack-effect (nil if unknown)
    5865(define-opcode nop 0 1 0)
    59 (define-opcode aconst_null 1 1 1)
    60 (define-opcode iconst_m1 2 1 1)
    61 (define-opcode iconst_0 3 1 1)
    62 (define-opcode iconst_1 4 1 1)
    63 (define-opcode iconst_2 5 1 1)
    64 (define-opcode iconst_3 6 1 1)
    65 (define-opcode iconst_4 7 1 1)
    66 (define-opcode iconst_5 8 1 1)
    67 (define-opcode lconst_0 9 1 2)
    68 (define-opcode lconst_1 10 1 2)
    69 (define-opcode fconst_0 11 1 1)
    70 (define-opcode fconst_1 12 1 1)
    71 (define-opcode fconst_2 13 1 1)
    72 (define-opcode dconst_0 14 1 2)
    73 (define-opcode dconst_1 15 1 2)
    74 (define-opcode bipush 16 2 1)
    75 (define-opcode sipush 17 3 1)
    76 (define-opcode ldc 18 2 1)
    77 (define-opcode ldc_w 19 3 1)
    78 (define-opcode ldc2_w 20 3 2)
    79 (define-opcode iload 21 2 1)
    80 (define-opcode lload 22 2 2)
    81 (define-opcode fload 23 2 nil)
    82 (define-opcode dload 24 2 nil)
    83 (define-opcode aload 25 2 1)
    84 (define-opcode iload_0 26 1 1)
    85 (define-opcode iload_1 27 1 1)
    86 (define-opcode iload_2 28 1 1)
    87 (define-opcode iload_3 29 1 1)
    88 (define-opcode lload_0 30 1 2)
    89 (define-opcode lload_1 31 1 2)
    90 (define-opcode lload_2 32 1 2)
    91 (define-opcode lload_3 33 1 2)
    92 (define-opcode fload_0 34 1 nil)
    93 (define-opcode fload_1 35 1 nil)
    94 (define-opcode fload_2 36 1 nil)
    95 (define-opcode fload_3 37 1 nil)
    96 (define-opcode dload_0 38 1 nil)
    97 (define-opcode dload_1 39 1 nil)
    98 (define-opcode dload_2 40 1 nil)
    99 (define-opcode dload_3 41 1 nil)
    100 (define-opcode aload_0 42 1 1)
    101 (define-opcode aload_1 43 1 1)
    102 (define-opcode aload_2 44 1 1)
    103 (define-opcode aload_3 45 1 1)
    104 (define-opcode iaload 46 1 -1)
    105 (define-opcode laload 47 1 0)
    106 (define-opcode faload 48 1 -1)
    107 (define-opcode daload 49 1 0)
    108 (define-opcode aaload 50 1 -1)
    109 (define-opcode baload 51 1 nil)
    110 (define-opcode caload 52 1 nil)
    111 (define-opcode saload 53 1 nil)
    112 (define-opcode istore 54 2 -1)
    113 (define-opcode lstore 55 2 -2)
    114 (define-opcode fstore 56 2 nil)
    115 (define-opcode dstore 57 2 nil)
    116 (define-opcode astore 58 2 -1)
    117 (define-opcode istore_0 59 1 -1)
    118 (define-opcode istore_1 60 1 -1)
    119 (define-opcode istore_2 61 1 -1)
    120 (define-opcode istore_3 62 1 -1)
    121 (define-opcode lstore_0 63 1 -2)
    122 (define-opcode lstore_1 64 1 -2)
    123 (define-opcode lstore_2 65 1 -2)
    124 (define-opcode lstore_3 66 1 -2)
    125 (define-opcode fstore_0 67 1 nil)
    126 (define-opcode fstore_1 68 1 nil)
    127 (define-opcode fstore_2 69 1 nil)
    128 (define-opcode fstore_3 70 1 nil)
    129 (define-opcode dstore_0 71 1 nil)
    130 (define-opcode dstore_1 72 1 nil)
    131 (define-opcode dstore_2 73 1 nil)
    132 (define-opcode dstore_3 74 1 nil)
    133 (define-opcode astore_0 75 1 -1)
    134 (define-opcode astore_1 76 1 -1)
    135 (define-opcode astore_2 77 1 -1)
    136 (define-opcode astore_3 78 1 -1)
    137 (define-opcode iastore 79 1 -3)
    138 (define-opcode lastore 80 1 -4)
    139 (define-opcode fastore 81 1 -3)
    140 (define-opcode dastore 82 1 -4)
    141 (define-opcode aastore 83 1 -3)
    142 (define-opcode bastore 84 1 nil)
    143 (define-opcode castore 85 1 nil)
    144 (define-opcode sastore 86 1 nil)
    145 (define-opcode pop 87 1 -1)
    146 (define-opcode pop2 88 1 -2)
    147 (define-opcode dup 89 1 1)
    148 (define-opcode dup_x1 90 1 1)
    149 (define-opcode dup_x2 91 1 1)
    150 (define-opcode dup2 92 1 2)
    151 (define-opcode dup2_x1 93 1 2)
    152 (define-opcode dup2_x2 94 1 2)
    153 (define-opcode swap 95 1 0)
    154 (define-opcode iadd 96 1 -1)
    155 (define-opcode ladd 97 1 -2)
    156 (define-opcode fadd 98 1 -1)
    157 (define-opcode dadd 99 1 -2)
    158 (define-opcode isub 100 1 -1)
    159 (define-opcode lsub 101 1 -2)
    160 (define-opcode fsub 102 1 -1)
    161 (define-opcode dsub 103 1 -2)
    162 (define-opcode imul 104 1 -1)
    163 (define-opcode lmul 105 1 -2)
    164 (define-opcode fmul 106 1 -1)
    165 (define-opcode dmul 107 1 -2)
    166 (define-opcode idiv 108 1 nil)
    167 (define-opcode ldiv 109 1 nil)
    168 (define-opcode fdiv 110 1 nil)
    169 (define-opcode ddiv 111 1 nil)
    170 (define-opcode irem 112 1 nil)
    171 (define-opcode lrem 113 1 nil)
    172 (define-opcode frem 114 1 nil)
    173 (define-opcode drem 115 1 nil)
     66(define-opcode aconst_null 1 1 1 (smf-push :null))
     67(define-opcode iconst_m1 2 1 1 (smf-push :int))
     68(define-opcode iconst_0 3 1 1 (smf-push :int))
     69(define-opcode iconst_1 4 1 1 (smf-push :int))
     70(define-opcode iconst_2 5 1 1 (smf-push :int))
     71(define-opcode iconst_3 6 1 1 (smf-push :int))
     72(define-opcode iconst_4 7 1 1 (smf-push :int))
     73(define-opcode iconst_5 8 1 1 (smf-push :int))
     74(define-opcode lconst_0 9 1 2 (smf-push :long))
     75(define-opcode lconst_1 10 1 2 (smf-push :long))
     76(define-opcode fconst_0 11 1 1 (smf-push :float))
     77(define-opcode fconst_1 12 1 1 (smf-push :float))
     78(define-opcode fconst_2 13 1 1 (smf-push :float))
     79(define-opcode dconst_0 14 1 2 (smf-push :double))
     80(define-opcode dconst_1 15 1 2 (smf-push :duble))
     81(define-opcode bipush 16 2 1 (smf-push :int))
     82(define-opcode sipush 17 3 1 (smf-push :int))
     83(define-opcode ldc 18 2 1 (smf-push (car (instruction-args instruction))))
     84(define-opcode ldc_w 19 3 1 (smf-push (car (instruction-args instruction))))
     85(define-opcode ldc2_w 20 3 2
     86  (smf-push (car (instruction-args instruction)))
     87  (smf-push :top))
     88(define-opcode iload 21 2 1 (smf-push :int))
     89(define-opcode lload 22 2 2 (smf-push :long))
     90(define-opcode fload 23 2 nil (smf-push :float))
     91(define-opcode dload 24 2 nil (smf-push :double))
     92(define-opcode aload 25 2 1
     93  (smf-push (smf-get (car (instruction-args instruction)))))
     94(define-opcode iload_0 26 1 1 (smf-push :int))
     95(define-opcode iload_1 27 1 1 (smf-push :int))
     96(define-opcode iload_2 28 1 1 (smf-push :int))
     97(define-opcode iload_3 29 1 1 (smf-push :int))
     98(define-opcode lload_0 30 1 2 (smf-push :long))
     99(define-opcode lload_1 31 1 2 (smf-push :long))
     100(define-opcode lload_2 32 1 2 (smf-push :long))
     101(define-opcode lload_3 33 1 2 (smf-push :long))
     102(define-opcode fload_0 34 1 nil (smf-push :float))
     103(define-opcode fload_1 35 1 nil (smf-push :float))
     104(define-opcode fload_2 36 1 nil (smf-push :float))
     105(define-opcode fload_3 37 1 nil (smf-push :float))
     106(define-opcode dload_0 38 1 nil (smf-push :double))
     107(define-opcode dload_1 39 1 nil (smf-push :double))
     108(define-opcode dload_2 40 1 nil (smf-push :double))
     109(define-opcode dload_3 41 1 nil (smf-push :double))
     110(define-opcode aload_0 42 1 1 (smf-push (smf-get 0)))
     111(define-opcode aload_1 43 1 1 (smf-push (smf-get 1)))
     112(define-opcode aload_2 44 1 1 (smf-push (smf-get 2)))
     113(define-opcode aload_3 45 1 1 (smf-push (smf-get 3)))
     114(define-opcode iaload 46 1 -1 (smf-popn 2) (smf-push :int))
     115(define-opcode laload 47 1 0 (smf-popn 2) (smf-push :long))
     116(define-opcode faload 48 1 -1 (smf-popn 2) (smf-push :float))
     117(define-opcode daload 49 1 0 (smf-popn 2) (smf-push :double))
     118(define-opcode aaload 50 1 -1
     119  (progn
     120    (smf-pop)
     121    (smf-push (smf-element-of (smf-pop)))))
     122(define-opcode baload 51 1 nil (smf-popn 2) (smf-push :int))
     123(define-opcode caload 52 1 nil (smf-popn 2) (smf-push :int))
     124(define-opcode saload 53 1 nil (smf-popn 2) (smf-push :int))
     125
     126(defun iaf-store-effect (arg)
     127  (let ((t1 (smf-pop)))
     128    (sys::%format t "iaf-store ~S~%" (list arg t1))
     129    (smf-set arg t1)
     130    (when (> arg 0)
     131      (let ((t2 (smf-get (1- arg))))
     132  (when (or (eq t2 :long) (eq t2 :double))
     133    (smf-set (1- arg) :top))))))
     134
     135(defun ld-store-effect (arg)
     136  (smf-pop)
     137  (let ((t1 (smf-pop)))
     138    (smf-set arg t1)
     139    (smf-set (1+ arg) :top)
     140    (when (> arg 0)
     141      (let ((t2 (smf-get (1- arg))))
     142  (when (or (eq t2 :long) (eq t2 :double))
     143    (smf-set (1- arg) :top))))))
     144
     145(define-opcode istore 54 2 -1
     146  (iaf-store-effect (car (instruction-args instruction))))
     147(define-opcode lstore 55 2 -2
     148  (ld-store-effect (car (instruction-args instruction))))
     149(define-opcode fstore 56 2 nil
     150  (iaf-store-effect (car (instruction-args instruction))))
     151(define-opcode dstore 57 2 nil
     152  (ld-store-effect (car (instruction-args instruction))))
     153(define-opcode astore 58 2 -1
     154  (iaf-store-effect (car (instruction-args instruction))))
     155(define-opcode istore_0 59 1 -1 (iaf-store-effect 0))
     156(define-opcode istore_1 60 1 -1 (iaf-store-effect 1))
     157(define-opcode istore_2 61 1 -1 (iaf-store-effect 2))
     158(define-opcode istore_3 62 1 -1 (iaf-store-effect 3))
     159(define-opcode lstore_0 63 1 -2 (ld-store-effect 0))
     160(define-opcode lstore_1 64 1 -2 (ld-store-effect 1))
     161(define-opcode lstore_2 65 1 -2 (ld-store-effect 2))
     162(define-opcode lstore_3 66 1 -2 (ld-store-effect 3))
     163(define-opcode fstore_0 67 1 nil (iaf-store-effect 0))
     164(define-opcode fstore_1 68 1 nil (iaf-store-effect 1))
     165(define-opcode fstore_2 69 1 nil (iaf-store-effect 2))
     166(define-opcode fstore_3 70 1 nil (iaf-store-effect 3))
     167(define-opcode dstore_0 71 1 nil (dl-store-effect 0))
     168(define-opcode dstore_1 72 1 nil (dl-store-effect 1))
     169(define-opcode dstore_2 73 1 nil (dl-store-effect 2))
     170(define-opcode dstore_3 74 1 nil (dl-store-effect 3))
     171(define-opcode astore_0 75 1 -1 (iaf-store-effect 0))
     172(define-opcode astore_1 76 1 -1 (iaf-store-effect 1))
     173(define-opcode astore_2 77 1 -1 (iaf-store-effect 2))
     174(define-opcode astore_3 78 1 -1 (iaf-store-effect 3))
     175(define-opcode iastore 79 1 -3 (smf-popn 3))
     176(define-opcode lastore 80 1 -4 (smf-popn 4))
     177(define-opcode fastore 81 1 -3 (smf-popn 3))
     178(define-opcode dastore 82 1 -4 (smf-popn 4))
     179(define-opcode aastore 83 1 -3 (smf-popn 3))
     180(define-opcode bastore 84 1 nil (smf-popn 3))
     181(define-opcode castore 85 1 nil (smf-popn 3))
     182(define-opcode sastore 86 1 nil (smf-popn 3))
     183(define-opcode pop 87 1 -1 (smf-pop))
     184(define-opcode pop2 88 1 -2 (smf-popn 2))
     185(define-opcode dup 89 1 1
     186  (let ((t1 (smf-pop)))
     187    (smf-push t1)
     188    (smf-push t1)))
     189(define-opcode dup_x1 90 1 1
     190  (let ((t1 (smf-pop)) (t2 (smf-pop)))
     191    (smf-push t1)
     192    (smf-push t2)
     193    (smf-push t1)))
     194(define-opcode dup_x2 91 1 1
     195  (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop)))
     196    (smf-push t1)
     197    (smf-push t3)
     198    (smf-push t2)
     199    (smf-push t1)))
     200(define-opcode dup2 92 1 2
     201  (let ((t1 (smf-pop)) (t2 (smf-pop)))
     202    (smf-push t2)
     203    (smf-push t1)
     204    (smf-push t2)
     205    (smf-push t1)))
     206(define-opcode dup2_x1 93 1 2
     207  (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop)))
     208    (smf-push t2)
     209    (smf-push t1)
     210    (smf-push t3)
     211    (smf-push t2)
     212    (smf-push t1)))
     213(define-opcode dup2_x2 94 1 2
     214  (let ((t1 (smf-pop)) (t2 (smf-pop))
     215  (t3 (smf-pop)) (t4 (smf-pop)))
     216    (smf-push t2)
     217    (smf-push t1)
     218    (smf-push t4)
     219    (smf-push t3)
     220    (smf-push t2)
     221    (smf-push t1)))
     222(define-opcode swap 95 1 0
     223  (let ((t1 (smf-pop)) (t2 (smf-pop)))
     224    (smf-push t1)
     225    (smf-push t2)))
     226(define-opcode iadd 96 1 -1 (smf-popn 2) (smf-push :int))
     227(define-opcode ladd 97 1 -2 (smf-popn 4) (smf-push :long))
     228(define-opcode fadd 98 1 -1 (smf-popn 2) (smf-push :float))
     229(define-opcode dadd 99 1 -2 (smf-popn 4) (smf-push :double))
     230(define-opcode isub 100 1 -1 (smf-popn 2) (smf-push :int))
     231(define-opcode lsub 101 1 -2 (smf-popn 4) (smf-push :long))
     232(define-opcode fsub 102 1 -1 (smf-popn 2) (smf-push :float))
     233(define-opcode dsub 103 1 -2 (smf-popn 4) (smf-push :double))
     234(define-opcode imul 104 1 -1 (smf-popn 2) (smf-push :int))
     235(define-opcode lmul 105 1 -2 (smf-popn 4) (smf-push :long))
     236(define-opcode fmul 106 1 -1 (smf-popn 2) (smf-push :float))
     237(define-opcode dmul 107 1 -2 (smf-popn 4) (smf-push :double))
     238(define-opcode idiv 108 1 nil (smf-popn 2) (smf-push :int))
     239(define-opcode ldiv 109 1 nil (smf-popn 4) (smf-push :long))
     240(define-opcode fdiv 110 1 nil (smf-popn 2) (smf-push :float))
     241(define-opcode ddiv 111 1 nil (smf-popn 4) (smf-push :double))
     242(define-opcode irem 112 1 nil (smf-popn 2) (smf-push :int))
     243(define-opcode lrem 113 1 nil (smf-popn 4) (smf-push :long))
     244(define-opcode frem 114 1 nil (smf-popn 2) (smf-push :float))
     245(define-opcode drem 115 1 nil (smf-popn 4) (smf-push :double))
    174246(define-opcode ineg 116 1 0)
    175247(define-opcode lneg 117 1 0)
    176248(define-opcode fneg 118 1 0)
    177249(define-opcode dneg 119 1 0)
    178 (define-opcode ishl 120 1 -1)
    179 (define-opcode lshl 121 1 -1)
    180 (define-opcode ishr 122 1 -1)
    181 (define-opcode lshr 123 1 -1)
    182 (define-opcode iushr 124 1 nil)
    183 (define-opcode lushr 125 1 nil)
    184 (define-opcode iand 126 1 -1)
    185 (define-opcode land 127 1 -2)
    186 (define-opcode ior 128 1 -1)
    187 (define-opcode lor 129 1 -2)
    188 (define-opcode ixor 130 1 -1)
    189 (define-opcode lxor 131 1 -2)
    190 (define-opcode iinc 132 3 0)
    191 (define-opcode i2l 133 1 1)
    192 (define-opcode i2f 134 1 0)
    193 (define-opcode i2d 135 1 1)
    194 (define-opcode l2i 136 1 -1)
    195 (define-opcode l2f 137 1 -1)
    196 (define-opcode l2d 138 1 0)
    197 (define-opcode f2i 139 1 nil)
    198 (define-opcode f2l 140 1 nil)
    199 (define-opcode f2d 141 1 1)
    200 (define-opcode d2i 142 1 nil)
    201 (define-opcode d2l 143 1 nil)
    202 (define-opcode d2f 144 1 -1)
     250(define-opcode ishl 120 1 -1 (smf-popn 2) (smf-push :int))
     251(define-opcode lshl 121 1 -1 (smf-popn 3) (smf-push :long))
     252(define-opcode ishr 122 1 -1 (smf-popn 2) (smf-push :int))
     253(define-opcode lshr 123 1 -1 (smf-popn 3) (smf-push :long))
     254(define-opcode iushr 124 1 nil (smf-popn 2) (smf-push :int))
     255(define-opcode lushr 125 1 nil (smf-popn 3) (smf-push :long))
     256(define-opcode iand 126 1 -1 (smf-popn 2) (smf-push :int))
     257(define-opcode land 127 1 -2 (smf-popn 4) (smf-push :long))
     258(define-opcode ior 128 1 -1 (smf-popn 2) (smf-push :int))
     259(define-opcode lor 129 1 -2 (smf-popn 4) (smf-push :long))
     260(define-opcode ixor 130 1 -1 (smf-popn 2) (smf-push :int))
     261(define-opcode lxor 131 1 -2 (smf-popn 4) (smf-push :long))
     262(define-opcode iinc 132 3 0
     263  (sys::%format t "AAAAAAAAAAAA ~A~%" (instruction-args instruction))
     264  (smf-set (car (instruction-args instruction)) :int))
     265(define-opcode i2l 133 1 1 (smf-pop) (smf-push :long))
     266(define-opcode i2f 134 1 0 (smf-pop) (smf-push :float))
     267(define-opcode i2d 135 1 1 (smf-pop) (smf-push :double))
     268(define-opcode l2i 136 1 -1 (smf-popn 2) (smf-push :int))
     269(define-opcode l2f 137 1 -1 (smf-popn 2) (smf-push :float))
     270(define-opcode l2d 138 1 0 (smf-popn 2) (smf-push :double))
     271(define-opcode f2i 139 1 nil (smf-pop) (smf-push :int))
     272(define-opcode f2l 140 1 nil (smf-pop) (smf-push :long))
     273(define-opcode f2d 141 1 1 (smf-pop) (smf-push :double))
     274(define-opcode d2i 142 1 nil (smf-popn 2) (smf-push :int))
     275(define-opcode d2l 143 1 nil (smf-popn 2) (smf-push :long))
     276(define-opcode d2f 144 1 -1 (smf-popn 2) (smf-push :float))
    203277(define-opcode i2b 145 1 nil)
    204278(define-opcode i2c 146 1 nil)
    205279(define-opcode i2s 147 1 nil)
    206 (define-opcode lcmp 148 1 -3)
    207 (define-opcode fcmpl 149 1 -1)
    208 (define-opcode fcmpg 150 1 -1)
    209 (define-opcode dcmpl 151 1 -3)
    210 (define-opcode dcmpg 152 1 -3)
    211 (define-opcode ifeq 153 3 -1)
    212 (define-opcode ifne 154 3 -1)
    213 (define-opcode iflt 155 3 -1)
    214 (define-opcode ifge 156 3 -1)
    215 (define-opcode ifgt 157 3 -1)
    216 (define-opcode ifle 158 3 -1)
    217 (define-opcode if_icmpeq 159 3 -2)
    218 (define-opcode if_icmpne 160 3 -2)
    219 (define-opcode if_icmplt 161 3 -2)
    220 (define-opcode if_icmpge 162 3 -2)
    221 (define-opcode if_icmpgt 163 3 -2)
    222 (define-opcode if_icmple 164 3 -2)
    223 (define-opcode if_acmpeq 165 3 -2)
    224 (define-opcode if_acmpne 166 3 -2)
     280(define-opcode lcmp 148 1 -3 (smf-popn 4) (smf-push :int))
     281(define-opcode fcmpl 149 1 -1 (smf-popn 2) (smf-push :int))
     282(define-opcode fcmpg 150 1 -1 (smf-popn 2) (smf-push :int))
     283(define-opcode dcmpl 151 1 -3 (smf-popn 4) (smf-push :int))
     284(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))
     291(define-opcode if_icmpeq 159 3 -2 (smf-popn 2))
     292(define-opcode if_icmpne 160 3 -2 (smf-popn 2))
     293(define-opcode if_icmplt 161 3 -2 (smf-popn 2))
     294(define-opcode if_icmpge 162 3 -2 (smf-popn 2))
     295(define-opcode if_icmpgt 163 3 -2 (smf-popn 2))
     296(define-opcode if_icmple 164 3 -2 (smf-popn 2))
     297(define-opcode if_acmpeq 165 3 -2 (smf-popn 2))
     298(define-opcode if_acmpne 166 3 -2 (smf-popn 2))
    225299(define-opcode goto 167 3 0)
    226300;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
    227301;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
    228 (define-opcode tableswitch 170 0 nil)
    229 (define-opcode lookupswitch 171 0 nil)
    230 (define-opcode ireturn 172 1 nil)
    231 (define-opcode lreturn 173 1 nil)
    232 (define-opcode freturn 174 1 nil)
    233 (define-opcode dreturn 175 1 nil)
    234 (define-opcode areturn 176 1 -1)
     302(define-opcode tableswitch 170 0 nil (smf-pop))
     303(define-opcode lookupswitch 171 0 nil (smf-pop))
     304(define-opcode ireturn 172 1 nil (smf-pop))
     305(define-opcode lreturn 173 1 nil (smf-popn 2))
     306(define-opcode freturn 174 1 nil (smf-pop))
     307(define-opcode dreturn 175 1 nil (smf-popn 2))
     308(define-opcode areturn 176 1 -1 (smf-pop))
    235309(define-opcode return 177 1 0)
    236 (define-opcode getstatic 178 3 1)
    237 (define-opcode putstatic 179 3 -1)
    238 (define-opcode getfield 180 3 0)
    239 (define-opcode putfield 181 3 -2)
    240 (define-opcode invokevirtual 182 3 nil)
    241 (define-opcode invokespecial 183 3 nil)
    242 (define-opcode invokestatic 184 3 nil)
    243 (define-opcode invokeinterface 185 5 nil)
    244 (define-opcode unused 186 0 nil)
    245 (define-opcode new 187 3 1)
    246 (define-opcode newarray 188 2 nil)
    247 (define-opcode anewarray 189 3 0)
    248 (define-opcode arraylength 190 1 0)
    249 (define-opcode athrow 191 1 0)
    250 (define-opcode checkcast 192 3 0)
    251 (define-opcode instanceof 193 3 0)
    252 (define-opcode monitorenter 194 1 -1)
    253 (define-opcode monitorexit 195 1 -1)
     310(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))))
     314(define-opcode putstatic 179 3 -1
     315  (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction)))
     316  (smf-popt (third (instruction-args instruction))))
     317(define-opcode getfield 180 3 0
     318  (smf-pop)
     319  (smf-push (third (instruction-args instruction))))
     320(define-opcode putfield 181 3 -2
     321  (smf-popt (third (instruction-args instruction)))
     322  (smf-pop))
     323(define-opcode invokevirtual 182 3 nil
     324  (smf-popt (third (instruction-args instruction)))
     325  (smf-pop)
     326  (smf-push (third (instruction-args instruction))))
     327(define-opcode invokespecial 183 3 nil
     328  (smf-popt (third (instruction-args instruction)))
     329  (smf-pop)
     330  (smf-push (third (instruction-args instruction))))
     331(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))))
     335(define-opcode invokeinterface 185 5 nil
     336  (smf-popt (third (instruction-args instruction)))
     337  (smf-pop)
     338  (smf-push (third (instruction-args instruction))))
     339(define-opcode invokedynamic 186 0 nil
     340  (smf-popt (second (instruction-args instruction)))
     341  (smf-push (second (instruction-args instruction))))
     342(define-opcode new 187 3 1
     343  (smf-push (first (instruction-args instruction))))
     344(define-opcode newarray 188 2 nil
     345  (smf-pop)
     346  (smf-push `(:array-of ,(first (instruction-args instruction)))))
     347(define-opcode anewarray 189 3 0
     348  (smf-pop)
     349  (smf-push `(:array-of ,(first (instruction-args instruction)))))
     350(define-opcode arraylength 190 1 0
     351  (smf-pop)
     352  (smf-push :int))
     353(define-opcode athrow 191 1 0 (smf-pop))
     354(define-opcode checkcast 192 3 0
     355  (smf-pop)
     356  (smf-push (first (instruction-args instruction))))
     357(define-opcode instanceof 193 3 0
     358  (smf-pop)
     359  (smf-push :int))
     360(define-opcode monitorenter 194 1 -1 (smf-pop))
     361(define-opcode monitorexit 195 1 -1 (smf-pop))
    254362(define-opcode wide 196 0 nil)
    255363(define-opcode multianewarray 197 4 nil)
    256 (define-opcode ifnull 198 3 -1)
    257 (define-opcode ifnonnull 199 3 nil)
     364(define-opcode ifnull 198 3 -1 (smf-pop))
     365(define-opcode ifnonnull 199 3 nil (smf-pop))
    258366(define-opcode goto_w 200 5 nil)
    259367;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
     
    279387        (error "Unknown opcode ~S." opcode-name))))
    280388
     389
    281390(declaim (ftype (function (t) fixnum) opcode-size))
    282391(defun opcode-size (opcode-number)
     
    290399  (jvm-opcode-stack-effect (svref *opcode-table* opcode-number)))
    291400
    292 
    293 
     401(declaim (ftype (function (t) t) opcode-effect-function))
     402(defun opcode-effect-function (opcode-number)
     403  (declare (optimize speed))
     404  (jvm-opcode-effect-function (svref *opcode-table* opcode-number)))
     405
     406;;Stack map table functions
     407(defun smf-get (pos)
     408  (or (nth pos *code-locals*)
     409      (sys::%format t "Locals inconsistency: get ~A but locals are ~A~%" ;;TODO error
     410        pos *code-locals*)))
     411
     412(defun smf-set (pos type)
     413  (if (< pos (length *code-locals*))
     414      (setf (nth pos *code-locals*) type)
     415      (progn
     416  (setf *code-locals*
     417        (append *code-locals* (list nil)))
     418  (smf-set pos type))))
     419
     420(defun smf-push (type)
     421  (push type *code-stack*)
     422  (when (or (eq type :long) (eq type :double))
     423    (push :top *code-stack)))
     424
     425(defun smf-pop ()
     426  ;(sys::%format t "smf-pop ~A~%" *code-stack*)
     427  (pop *code-stack*))
     428
     429(defun smf-popt (type)
     430  (declare (ignore type)) ;TODO
     431  (pop *code-stack*))
     432
     433(defun smf-popn (n)
     434  (dotimes (i n)
     435    (pop *code-stack*)))
     436
     437(defun smf-element-of (type)
     438  (if (and (consp type) (eq (car type) :array-of))
     439      (cdr type)
     440      (cons :element-of type)))
     441
     442(defun smf-array-of (type)
     443  (if (and (consp type) (eq (car type) :element-of))
     444      (cdr type)
     445      (cons :array-of type)))
    294446
    295447;;   INSTRUCTION
     
    300452  stack
    301453  depth
    302   wide)
     454  wide
     455  input-locals
     456  input-stack
     457  output-locals
     458  output-stack
     459  ;;the calculated offset of the instruction
     460  offset)
    303461
    304462(defun make-instruction (opcode args)
     
    308466    (when (memq :wide-prefix args)
    309467      (setf (inst-wide inst) t))
     468    (setf (instruction-input-locals inst) *code-locals*)
     469    (setf (instruction-input-stack inst) *code-stack*)
    310470    inst))
    311471
     
    341501;; our only user and we'll hard-code the use of *code*.
    342502(defvar *code* nil)
     503(defvar *code-locals* nil)
     504(defvar *code-stack* nil)
    343505
    344506(defknown %%emit * t)
     
    361523             (symbolp (cadr instr)))
    362524    (setf instr (opcode-number (cadr instr))))
    363   (if (fixnump instr)
    364       `(%%emit ,instr ,@args)
    365       `(%emit ,instr ,@args)))
     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)))
    366536
    367537
     
    396566         (inline branch-p))
    397567(defun branch-p (opcode)
    398 ;;  (declare (optimize speed))
    399 ;;  (declare (type '(integer 0 255) opcode))
     568  (declare (optimize speed))
     569  (declare (type '(integer 0 255) opcode))
    400570  (or (<= 153 opcode 167)
    401571      (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
  • branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp

    r12918 r12983  
    125125  lambda-name
    126126  lambda-list ; as advertised
    127   static-code
     127  static-initializer
     128  constructor
    128129  objects ;; an alist of externalized objects and their field names
    129130  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
     
    164165                                            :lambda-name lambda-name
    165166                                            :lambda-list lambda-list
    166                                             :access-flags '(:public :final))))
     167                                            :access-flags '(:public :final)))
     168   (static-initializer (make-method :static-initializer
     169            :void nil :flags '(:public :static)))
     170   (constructor (make-method :constructor :void nil
     171           :flags '(:public))))
     172
     173    (setf (abcl-class-file-static-initializer class-file) static-initializer)
     174    (class-add-method class-file static-initializer)
     175
     176    (setf (abcl-class-file-constructor class-file) constructor)
     177    (class-add-method class-file constructor)
     178
    167179    (when *file-compilation*
    168180      (let ((source-attribute
     
    177189            (*class-file*           ,var)
    178190            (*pool*                 (abcl-class-file-constants ,var))
    179             (*static-code*          (abcl-class-file-static-code ,var))
    180191            (*externalized-objects* (abcl-class-file-objects ,var))
    181192            (*declared-functions*   (abcl-class-file-functions ,var)))
    182193       (progn ,@body)
    183        (setf (abcl-class-file-static-code ,var)  *static-code*
    184              (abcl-class-file-objects ,var)      *externalized-objects*
     194       (setf (abcl-class-file-objects ,var)      *externalized-objects*
    185195             (abcl-class-file-functions ,var)    *declared-functions*))))
    186196
Note: See TracChangeset for help on using the changeset viewer.