Changeset 12953


Ignore:
Timestamp:
10/06/10 22:03:56 (13 years ago)
Author:
astalla
Message:

invokedynamic: support for the new typechecking verifier (half-way, compilation broken!)

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

Legend:

Unmodified
Added
Removed

  • branches/invokedynamic/abcl/src/org/armedbear/lisp/JavaClassLoader.java

    r12802 r12953  
    118118                return c;
    119119            }
    120         }
    121         catch (VerifyError e)
    122           {
     120        } catch (VerifyError e) {
    123121            error(new LispError("Class verification failed: " + e.getMessage()));
    124           }
    125         catch (Throwable t) {
     122  } catch (Throwable t) {
     123      Debug.trace("Classloading error for " + className);
    126124            Debug.trace(t);
     125      LispThread.currentThread().printBacktrace();
     126      Debug.trace("Classloading error for " + className);
    127127        }
    128128        return null;

  • branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java

    r12921 r12953  
    4141  public static final long startTimeMillis = System.currentTimeMillis();
    4242
    43   static { Linkage.registerBootstrapMethod(Function.class, "linkLispFunction"); }
     43    //  static { Linkage.registerBootstrapMethod(Function.class, "linkLispFunction"); }
    4444
    4545  public static void main(final String[] args)
    … …  
    5757      };
    5858    new Thread(null, r, "interpreter", 4194304L).start();
    59     try {
     59    /*try {
    6060        for(int i = 0; i < 2; i++) {
    6161          Thread.sleep(5000);
    6262          InvokeDynamic.<LispObject>#"COMMON-LISP:PRINT"((LispObject) new SimpleString("foo"));
    6363          InvokeDynamic.<LispObject>#"COMMON-LISP:PRINT"((LispObject) new SimpleString("bar"));
    64           InvokeDynamic.<LispObject>#"CL-USER::FOO"((LispObject) new SimpleString("baz"));
     64    //          InvokeDynamic.<LispObject>#"CL-USER::FOO"((LispObject) new SimpleString("baz"));
    6565        }
    6666    } catch(Throwable t) {
    6767      t.printStackTrace();
    68     }
     68      }*/
    6969    //java.dyn.InvokeDynamic.foo(new SimpleString("foo"));
    7070  }

  • branches/invokedynamic/abcl/src/org/armedbear/lisp/compile-system.lisp

    r12918 r12953  
    271271
    272272(defun compile-system (&key quit (zip t) output-path)
    273   (let ((status -1))
    274     (check-lisp-home)
    275     (time
    276      (with-compilation-unit ()
    277        (let ((*compile-file-zip* zip)
    278              failure-p)
    279          (handler-bind (((or warning
    280                              compiler-error)
    281                          #'(lambda (c)
    282                              (declare (ignore c))
    283                              (setf failure-p t)
    284                              ;; only register that we had this type of signal
    285                              ;; defer the actual handling to another handler
    286                              nil)))
    287            (%compile-system :output-path output-path))
    288          (unless failure-p
    289            (setf status 0)))))
    290     (create-system-logical-translations output-path)
     273  (let ((status -1) failure)
     274    (handler-bind ((error #'(lambda (c)
     275            (declare (ignore c))
     276            (let ((*print-circle* t))
     277        (pprint (sys::backtrace-as-list)))
     278            nil)))
     279      (check-lisp-home)
     280      (time
     281       (with-compilation-unit ()
     282   (let ((*compile-file-zip* zip))
     283     (handler-bind (((or warning
     284             compiler-error)
     285         #'(lambda (c)
     286             (setf failure c)
     287             ;; only register that we had this type of signal
     288             ;; defer the actual handling to another handler
     289             nil)))
     290       (%compile-system :output-path output-path))
     291     (unless failure
     292       (setf status 0)))))
     293      (create-system-logical-translations output-path))
     294    (when failure
     295      (format t "Failure: ~A~%" failure))
    291296    (when quit
    292297      (quit :status status))))

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

    r12918 r12953  
    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 (pool-add-method-ref *pool* class-name
    208                                      method-name (cons return-type arg-types)))
     207         (index (constant-index (pool-add-method-ref
     208         *pool* class-name
     209         method-name (cons return-type arg-types))))
    209210         (instruction (apply #'%emit 'invokestatic (u2 index))))
    210211    (setf (instruction-stack instruction) stack-effect)))
    … …  
    226227(defun emit-invokevirtual (class-name method-name arg-types return-type)
    227228  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
    228          (index (pool-add-method-ref *pool* class-name
    229                                      method-name (cons return-type arg-types)))
     229         (index (constant-index (pool-add-method-ref
     230         *pool* class-name
     231         method-name (cons return-type arg-types))))
    230232         (instruction (apply #'%emit 'invokevirtual (u2 index))))
    231233    (declare (type (signed-byte 8) stack-effect))
    … …  
    243245(defun emit-invokespecial-init (class-name arg-types)
    244246  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
    245          (index (pool-add-method-ref *pool* class-name
    246                                      "<init>" (cons nil arg-types)))
     247         (index (constant-index (pool-add-method-ref
     248         *pool* class-name
     249         "<init>" (cons nil arg-types))))
    247250         (instruction (apply #'%emit 'invokespecial (u2 index))))
    248251    (declare (type (signed-byte 8) stack-effect))
    … …  
    284287(defknown emit-getstatic (t t t) t)
    285288(defun emit-getstatic (class-name field-name type)
    286   (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    287     (apply #'%emit 'getstatic (u2 index))))
     289  (let ((ref (pool-add-field-ref *pool* class-name field-name type)))
     290    (apply #'%emit 'getstatic (u2 (constant-index ref)))))
    288291
    289292(defknown emit-putstatic (t t t) t)
    290293(defun emit-putstatic (class-name field-name type)
    291   (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    292     (apply #'%emit 'putstatic (u2 index))))
     294  (let ((ref (pool-add-field-ref *pool* class-name field-name type)))
     295    (apply #'%emit 'putstatic (u2 (constant-index ref)))))
    293296
    294297(declaim (inline emit-getfield emit-putfield))
    295298(defknown emit-getfield (t t t) t)
    296299(defun emit-getfield (class-name field-name type)
    297   (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
    298     (apply #'%emit 'getfield (u2 index))))
     300  (let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
     301    (apply #'%emit 'getfield (u2 (constant-index ref)))))
    299302
    300303(defknown emit-putfield (t t t) t)
    301304(defun emit-putfield (class-name field-name type)
    302   (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
    303     (apply #'%emit 'putfield (u2 index))))
     305  (let* ((ref (pool-add-field-ref *pool* class-name field-name type)))
     306    (apply #'%emit 'putfield (u2 (constant-index ref)))))
    304307
    305308
    … …  
    307310(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
    308311(defun emit-new (class-name)
    309   (apply #'%emit 'new (u2 (pool-class class-name))))
     312  (apply #'%emit 'new (u2 (constant-index (pool-class class-name)))))
    310313
    311314(defknown emit-anewarray (t) t)
    312315(defun emit-anewarray (class-name)
    313   (apply #'%emit 'anewarray (u2 (pool-class class-name))))
     316  (apply #'%emit 'anewarray (u2 (constant-index (pool-class class-name)))))
    314317
    315318(defknown emit-checkcast (t) t)
    316319(defun emit-checkcast (class-name)
    317   (apply #'%emit 'checkcast (u2 (pool-class class-name))))
     320  (apply #'%emit 'checkcast (u2 (constant-index (pool-class class-name)))))
    318321
    319322(defknown emit-instanceof (t) t)
    320323(defun emit-instanceof (class-name)
    321   (apply #'%emit 'instanceof (u2 (pool-class class-name))))
     324  (apply #'%emit 'instanceof (u2 (constant-index (pool-class class-name)))))
    322325
    323326
    … …  
    908911
    909912
     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))
     930
    910931(defvar *source-line-number* nil)
    911932
    … …  
    919940                                            (abcl-class-file-lambda-name class)
    920941                                            (abcl-class-file-lambda-list class)))
     942  (class-add-method class (make-static-initializer))
    921943  (finalize-class-file class)
    922944  (write-class-file class stream))
    923 
    924945
    925946(defknown declare-field (t t t) t)

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

    r12918 r12953  
    134134(define-class-name +java-string+ "java.lang.String")
    135135(define-class-name +java-system+ "java.lang.System")
     136(define-class-name +java-class+ "java.lang.Class")
    136137(define-class-name +lisp-object+ "org.armedbear.lisp.LispObject")
     138(define-class-name +dyn-linkage+ "java.dyn.Linkage")
     139(define-class-name +dyn-invokedynamic+ "java.dyn.InvokeDynamic")
    137140(defconstant +lisp-object-array+ (class-array +lisp-object+))
    138141(define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString")
    … …  
    168171(define-class-name +lisp-go+ "org.armedbear.lisp.Go")
    169172(define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive")
     173(define-class-name +lisp-function+ "org.armedbear.lisp.Function")
    170174(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
    171175(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
    … …  
    277281    (:utf8           1 1)))
    278282
     283(defun constant-type (constant)
     284  (car (find (constant-tag constant) +constant-type-map+ :key #'cadr)))
     285
    279286(defstruct (constant-class (:constructor make-constant-class (index name-index))
    280287                           (:include constant
    … …  
    368375
    369376(defun pool-add-class (pool class)
    370   "Returns the index of the constant-pool class item for `class'.
     377  "Returns the constant-pool class item for `class'.
    371378
    372379`class' must be an instance of `class-name'."
    373380  (let ((entry (gethash class (pool-entries pool))))
    374381    (unless entry
    375       (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
     382      (let ((utf8 (constant-index (pool-add-utf8 pool (class-name-internal class)))))
    376383        (setf entry
    377384              (make-constant-class (incf (pool-index pool)) utf8)
    378385              (gethash class (pool-entries pool)) entry))
    379386      (push entry (pool-entries-list pool)))
    380     (constant-index entry)))
     387    entry))
    381388
    382389(defun pool-add-field-ref (pool class name type)
    383   "Returns the index of the constant-pool item which denotes a reference
     390  "Returns the constant-pool item which denotes a reference
    384391to the `name' field of the `class', being of `type'.
    385392
    … …  
    389396  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    390397    (unless entry
    391       (let ((c (pool-add-class pool class))
    392             (n/t (pool-add-name/type pool name type)))
     398      (let ((c (constant-index (pool-add-class pool class)))
     399            (n/t (constant-index (pool-add-name/type pool name type))))
    393400        (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t)
    394401            (gethash (acons name type class) (pool-entries pool)) entry))
    395402      (push entry (pool-entries-list pool)))
    396     (constant-index entry)))
     403    entry))
    397404
    398405(defun pool-add-method-ref (pool class name type)
    399   "Returns the index of the constant-pool item which denotes a reference
     406  "Returns the constant-pool item which denotes a reference
    400407to the method with `name' in `class', which is of `type'.
    401408
    … …  
    404411  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    405412    (unless entry
    406       (let ((c (pool-add-class pool class))
    407             (n/t (pool-add-name/type pool name type)))
     413      (let ((c (constant-index (pool-add-class pool class)))
     414            (n/t (constant-index (pool-add-name/type pool name type))))
    408415        (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t)
    409416              (gethash (acons name type class) (pool-entries pool)) entry))
    410417      (push entry (pool-entries-list pool)))
    411     (constant-index entry)))
     418    entry))
    412419
    413420(defun pool-add-interface-method-ref (pool class name type)
    414   "Returns the index of the constant-pool item which denotes a reference to
     421  "Returns the constant-pool item which denotes a reference to
    415422the method `name' in the interface `class', which is of `type'.
    416423
    … …  
    418425  (let ((entry (gethash (acons name type class) (pool-entries pool))))
    419426    (unless entry
    420       (let ((c (pool-add-class pool class))
    421             (n/t (pool-add-name/type pool name type)))
     427      (let ((c (constant-index (pool-add-class pool class)))
     428            (n/t (constant-index (pool-add-name/type pool name type))))
    422429        (setf entry
    423430            (make-constant-interface-method-ref (incf (pool-index pool)) c n/t)
    424431            (gethash (acons name type class) (pool-entries pool)) entry))
    425432      (push entry (pool-entries-list pool)))
    426     (constant-index entry)))
     433    entry))
    427434
    428435(defun pool-add-string (pool string)
    429   "Returns the index of the constant-pool item denoting the string."
     436  "Returns the constant-pool item denoting the string."
    430437  (let ((entry (gethash (cons 8 string) ;; 8 == string-tag
    431438                        (pool-entries pool))))
    432439    (unless entry
    433440      (let ((utf8 (pool-add-utf8 pool string)))
    434         (setf entry (make-constant-string (incf (pool-index pool)) utf8)
     441        (setf entry (make-constant-string (incf (pool-index pool))
     442            (constant-index utf8))
    435443              (gethash (cons 8 string) (pool-entries pool)) entry))
    436444      (push entry (pool-entries-list pool)))
    437     (constant-index entry)))
     445    entry))
    438446
    439447(defun pool-add-int (pool int)
    440   "Returns the index of the constant-pool item denoting the int."
     448  "Returns the constant-pool item denoting the int."
    441449  (let ((entry (gethash (cons 3 int) (pool-entries pool))))
    442450    (unless entry
    … …  
    444452            (gethash (cons 3 int) (pool-entries pool)) entry)
    445453      (push entry (pool-entries-list pool)))
    446     (constant-index entry)))
     454    entry))
    447455
    448456(defun pool-add-float (pool float)
    449   "Returns the index of the constant-pool item denoting the float."
     457  "Returns the constant-pool item denoting the float."
    450458  (let ((entry (gethash (cons 4 float) (pool-entries pool))))
    451459    (unless entry
    … …  
    454462            (gethash (cons 4 float) (pool-entries pool)) entry)
    455463      (push entry (pool-entries-list pool)))
    456     (constant-index entry)))
     464    entry))
    457465
    458466(defun pool-add-long (pool long)
    459   "Returns the index of the constant-pool item denoting the long."
     467  "Returns the constant-pool item denoting the long."
    460468  (let ((entry (gethash (cons 5 long) (pool-entries pool))))
    461469    (unless entry
    … …  
    464472      (push entry (pool-entries-list pool))
    465473      (incf (pool-index pool))) ;; double index increase; long takes 2 slots
    466     (constant-index entry)))
     474    entry))
    467475
    468476(defun pool-add-double (pool double)
    469   "Returns the index of the constant-pool item denoting the double."
     477  "Returns constant-pool item denoting the double."
    470478  (let ((entry (gethash (cons 6 double) (pool-entries pool))))
    471479    (unless entry
    … …  
    475483      (push entry (pool-entries-list pool))
    476484      (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots
    477     (constant-index entry)))
     485    entry))
    478486
    479487(defun pool-add-name/type (pool name type)
    480   "Returns the index of the constant-pool item denoting
    481 the name/type identifier."
     488  "Returns the constant-pool item denoting the name/type identifier."
    482489  (let ((entry (gethash (cons name type) (pool-entries pool)))
    483490        (internal-type (if (listp type)
    … …  
    485492                           (internal-field-ref type))))
    486493    (unless entry
    487       (let ((n (pool-add-utf8 pool name))
    488             (i-t (pool-add-utf8 pool internal-type)))
     494      (let ((n (constant-index (pool-add-utf8 pool name)))
     495            (i-t (constant-index (pool-add-utf8 pool internal-type))))
    489496        (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t)
    490497              (gethash (cons name type) (pool-entries pool)) entry))
    491498      (push entry (pool-entries-list pool)))
    492     (constant-index entry)))
     499    entry))
    493500
    494501(defun pool-add-utf8 (pool utf8-as-string)
    495   "Returns the index of the textual value that will be stored in the
    496 class file as UTF-8 encoded data."
     502  "Returns the textual value that will be stored in the class file as UTF-8 encoded data."
    497503  (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8
    498504                        (pool-entries pool))))
    … …  
    501507            (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry)
    502508      (push entry (pool-entries-list pool)))
    503     (constant-index entry)))
     509    entry))
    504510
    505511(defstruct (class-file (:constructor
    … …  
    507513  "Holds the components of a class file."
    508514  (constants (make-pool))
     515  (major-version 51)
     516  (minor-version 0)
    509517  access-flags
    510518  class
    … …  
    568576        (map-flags (class-file-access-flags class)))
    569577  (setf (class-file-superclass class)
    570         (pool-add-class (class-file-constants class)
    571                         (class-file-superclass class))
     578        (constant-index (pool-add-class (class-file-constants class)
     579          (class-file-superclass class)))
    572580        (class-file-class class)
    573         (pool-add-class (class-file-constants class)
    574                         (class-file-class class)))
     581        (constant-index (pool-add-class (class-file-constants class)
     582          (class-file-class class))))
    575583  ;;  (finalize-interfaces)
    576584  (dolist (field (class-file-fields class))
    … …  
    668676  ;; header
    669677  (write-u4 #xCAFEBABE stream)
    670   (write-u2 3 stream)
    671   (write-u2 45 stream)
     678  (write-u2 (class-file-minor-version class) stream)
     679  (write-u2 (class-file-major-version class) stream)
    672680
    673681   ;; constants pool
    … …  
    821829          (map-flags (field-access-flags field))
    822830          (field-descriptor field)
    823           (pool-add-utf8 pool (internal-field-ref (field-descriptor field)))
     831          (constant-index (pool-add-utf8 pool (internal-field-ref (field-descriptor field))))
    824832          (field-name field)
    825           (pool-add-utf8 pool (field-name field))))
     833          (constant-index (pool-add-utf8 pool (field-name field)))))
    826834  (finalize-attributes (field-attributes field) nil class))
    827835
    … …  
    898906          (map-flags (method-access-flags method))
    899907          (method-descriptor method)
    900           (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
     908          (constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method))))
    901909          (method-name method)
    902           (pool-add-utf8 pool (method-name method))))
     910          (constant-index (pool-add-utf8 pool (method-name method)))))
    903911  (finalize-attributes (method-attributes method) nil class))
    904912
    … …  
    930938    ;; assure header: make sure 'name' is in the pool
    931939    (setf (attribute-name attribute)
    932           (pool-add-utf8 (class-file-constants class)
    933                          (attribute-name attribute)))
     940          (constant-index (pool-add-utf8 (class-file-constants class)
     941           (attribute-name attribute))))
    934942    ;; we're saving "root" attributes: attributes which have no parent
    935943    (funcall (attribute-finalizer attribute) attribute att class)))
    … …  
    969977  labels ;; an alist
    970978
    971   (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks
     979  ;; these two are used for handling nested WITH-CODE-TO-METHOD blocks
     980  (current-local 0)
     981  stack-map-frames)
    972982
    973983
    … …  
    986996(defun finalize-code-attribute (code parent class)
    987997  "Prepares the `code' attribute for serialization, within method `parent'."
    988   (declare (ignore parent))
    989998  (let* ((handlers (code-exception-handlers code))
    990999         (c (finalize-code
    … …  
    10001009      (setf (code-max-locals code)
    10011010            (analyze-locals code)))
     1011    (when (>= (class-file-major-version class) 50)
     1012      (code-add-attribute code (compute-stack-map-table class parent)))
    10021013    (multiple-value-bind
    10031014          (c labels)
    … …  
    10221033          (if (null (exception-catch-type exception))
    10231034              0  ;; generic 'catch all' class index number
    1024               (pool-add-class (class-file-constants class)
    1025                               (exception-catch-type exception)))))
     1035              (constant-index (pool-add-class (class-file-constants class)
     1036                (exception-catch-type exception))))))
    10261037
    10271038  (finalize-attributes (code-attributes code) code class))
    … …  
    11181129  (setf (checked-table checked-exceptions)
    11191130        (mapcar #'(lambda (exception)
    1120                     (pool-add-class (class-file-constants class)
    1121                                     exception))
     1131                    (constant-index (pool-add-class (class-file-constants class)
     1132                exception)))
    11221133                (checked-table checked-exceptions))))
    11231134
    … …  
    11831194  (declare (ignorable code class))
    11841195  (setf (source-filename source-file)
    1185         (pool-add-utf8 (class-file-constants class)
    1186                        (source-filename source-file))))
     1196        (constant-index (pool-add-utf8 (class-file-constants class)
     1197               (source-filename source-file)))))
    11871198
    11881199(defun write-source-file (source-file stream)
    … …  
    12591270             (local-start-pc local-variable))
    12601271          (local-name local-variable)
    1261           (pool-add-utf8 (class-file-constants class)
    1262                          (local-name local-variable))
     1272          (constant-index (pool-add-utf8 (class-file-constants class)
     1273           (local-name local-variable)))
    12631274          (local-descriptor local-variable)
    1264           (pool-add-utf8 (class-file-constants class)
    1265                          (local-descriptor local-variable)))))
     1275          (constant-index (pool-add-utf8 (class-file-constants class)
     1276           (local-descriptor local-variable))))))
    12661277
    12671278(defun write-local-variables (local-variables stream)
    … …  
    12741285    (write-u2 (local-index local-variable) stream)))
    12751286
     1287;;Support for the StackMapTable attribute used by the typechecking verifier
     1288;;from class file version number 50.0 onward (astalla)
     1289
     1290(defstruct (stack-map-table-attribute
     1291       (:conc-name stack-map-table-)
     1292       (:include attribute
     1293           (name "StackMapTable")
     1294           (finalizer #'finalize-stack-map-table-attribute)
     1295           (writer #'write-stack-map-table-attribute)))
     1296       ;(:constructor %make-stack-map-table-attribute))
     1297  "The attribute containing the stack map table, a map from bytecode offsets to frames containing information about the types of locals and values on the operand stack at that offset. This is an attribute of a method."
     1298  entries)
     1299
     1300(defun finalize-stack-map-table-attribute (table parent class)
     1301  "Prepares the `stack-map-table' attribute for serialization, within method `parent'."
     1302  (declare (ignore parent class)) ;;TODO
     1303  table)
     1304
     1305(defun write-stack-map-table-attribute (table stream)
     1306  (write-u2 (length (stack-map-table-entries table)) stream)
     1307  (dolist (frame (stack-map-table-entries table))
     1308    (funcall (frame-writer frame) stream)))
     1309
     1310(defstruct (stack-map-frame (:conc-name frame-))
     1311  offset-delta
     1312  writer)
     1313
     1314(defstruct (stack-map-full-frame
     1315       (:conc-name full-frame-)
     1316       (:include stack-map-frame
     1317           (writer #'write-stack-map-full-frame)))
     1318  locals
     1319  stack-items)
     1320
     1321(defun write-stack-map-full-frame (frame stream)
     1322  (write-u1 255 stream)
     1323  (write-u2 (frame-offset-delta frame) stream)
     1324  (write-u2 (length (full-frame-locals frame)) stream)
     1325  (dolist (local (full-frame-locals frame))
     1326    (funcall (verification-type-info-writer local) local stream))
     1327  (write-u2 (length (full-frame-stack-items frame)) stream)
     1328  (dolist (stack-item (full-frame-stack-items frame))
     1329    (funcall (verification-type-info-writer stack-item) stack-item stream)))
     1330
     1331(defstruct verification-type-info tag (writer #'write-simple-verification-type-info))
     1332
     1333(defstruct (top-variable-info (:include verification-type-info (tag 0))))
     1334(defstruct (integer-variable-info (:include verification-type-info (tag 1))))
     1335(defstruct (float-variable-info (:include verification-type-info (tag 2))))
     1336(defstruct (double-variable-info (:include verification-type-info (tag 3))))
     1337(defstruct (long-variable-info (:include verification-type-info (tag 4))))
     1338(defstruct (null-variable-info (:include verification-type-info (tag 5))))
     1339(defstruct (uninitialized-this-variable-info (:include verification-type-info (tag 6))))
     1340(defstruct (object-variable-info
     1341       (:include verification-type-info
     1342           (tag 7) (writer #'write-object-variable-info)))
     1343  constant-pool-index)
     1344(defstruct (uninitialized-variable-info
     1345       (:include verification-type-info
     1346           (tag 8) (writer #'write-unitialized-variable-info)))
     1347  offset)
     1348
     1349(defun write-simple-verification-type-info (vti stream)
     1350  (write-u1 (verification-type-info-tag vti) stream))
     1351(defun write-object-variable-type-info (vti stream)
     1352  (write-u1 (verification-type-info-tag vti) stream)
     1353  (write-u2 (object-variable-info-constant-pool-index vti) stream))
     1354(defun write-uninitialized-verification-type-info (vti stream)
     1355  (write-u1 (verification-type-info-tag vti) stream)
     1356  (write-u2 (uninitialized-variable-info-offset vti) stream))
     1357
     1358(defconst *opcode-effect-table*
     1359  (make-array 256 :initial-element #'(lambda (a b) (declare (ignore b)) a)))
     1360
     1361(defun opcode-effect-function (opcode)
     1362  (svref *opcode-effect-table* opcode))
     1363
     1364(defvar *computed-stack* nil "The list of types on the stack calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.")
     1365
     1366(defvar *computed-locals* nil "The list of types of local variables calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.")
     1367
     1368(defmacro define-opcode-effect (opcode &body body)
     1369  `(setf (svref *opcode-effect-table*
     1370    (opcode-number ',opcode))
     1371   #'(lambda (instruction)
     1372       (declare (ignorable instruction))
     1373       ,@body)))
     1374
     1375(defun update-stack-map-effect! (*computed-stack* *computed-locals* instruction)
     1376  (funcall (opcode-effect-function (instruction-opcode instruction))
     1377     instruction)
     1378  (setf (instruction-stack-map-locals instruction) *computed-locals*)
     1379  (setf (instruction-stack-map-stack instruction) *computed-stack*)
     1380  instruction)
     1381
     1382(defun compute-stack-map-table (class method)
     1383  (let ((table (make-stack-map-table-attribute))
     1384  (*computed-stack* (compute-initial-method-stack class method))
     1385  (*computed-locals*))
     1386    (finalize-stack-map-table table)))
     1387
     1388(defun finalize-stack-map-table (table)
     1389  "Replaces all virtual types in the stack map frames with variable-info objects."
     1390  ;;TODO
     1391  table)
     1392
     1393(defun compute-initial-method-stack (class method)
     1394  (let (locals)
     1395    (unless (member :static (method-access-flags method))
     1396      (if (string= "<init>" (method-name method))
     1397    ;;the method is a constructor.
     1398    (push :uninitialized-this locals)
     1399    ;;the method is an instance method.
     1400    (push (class-name class) locals)))
     1401    (dolist (x (cdr (method-descriptor method)))
     1402      (push x locals))
     1403    locals))
     1404
     1405(defun smf-type->variable-info (type)
     1406  (case type))
     1407
     1408(defun smf-push (type)
     1409  (push type *computed-stack*))
     1410
     1411(defun smf-push2 (type)
     1412  (smf-push type)
     1413  (smf-push :top))
     1414
     1415(defun smf-pop ()
     1416  (pop *computed-stack*))
     1417
     1418(defun smf-popn (n)
     1419  (dotimes (i n)
     1420    (pop *computed-stack*)))
     1421
     1422(defun smf-element-of (type)
     1423  (if (consp type)
     1424      (cdr type)
     1425      (error "Not an array stack map type: ~S" type)))
     1426
     1427(defun smf-array-of (type)
     1428  (cons :array-of type))
     1429
     1430(define-opcode-effect aconst_null (smf-push :null))
     1431(define-opcode-effect iconst_m1 (smf-push :int))
     1432(define-opcode-effect iconst_0 (smf-push :int))
     1433(define-opcode-effect iconst_1 (smf-push :int))
     1434(define-opcode-effect iconst_2 (smf-push :int))
     1435(define-opcode-effect iconst_3 (smf-push :int))
     1436(define-opcode-effect iconst_4 (smf-push :int))
     1437(define-opcode-effect iconst_5 (smf-push :int))
     1438(define-opcode-effect lconst_0 (smf-push2 :long))
     1439(define-opcode-effect lconst_1 (smf-push2 :long))
     1440(define-opcode-effect fconst_0 (smf-push :float))
     1441(define-opcode-effect fconst_1 (smf-push :float))
     1442(define-opcode-effect fconst_2 (smf-push :float))
     1443(define-opcode-effect dconst_0 (smf-push2 :double))
     1444(define-opcode-effect dconst_1 (smf-push2 :double))
     1445(define-opcode-effect bipush (smf-push :int))
     1446(define-opcode-effect sipush (smf-push :int))
     1447(define-opcode-effect ldc
     1448    (case (constant-type (car (instruction-args instruction)))
     1449      (:int (smf-push :int))
     1450      (:long (smf-push2 :long))
     1451      (:float (smf-push :float))
     1452      (:double (smf-push2 :double))
     1453      (t (smf-push (car (instruction-args instruction))))))
     1454(define-opcode-effect iload (smf-push :int))
     1455(define-opcode-effect lload (smf-push2 :long))
     1456(define-opcode-effect fload (smf-push :float))
     1457(define-opcode-effect dload (smf-push2 :double))
     1458#|(define-opcode aload 25 2 1) ;;TODO
     1459(define-opcode iload_0 26 1 1)
     1460(define-opcode iload_1 27 1 1)
     1461(define-opcode iload_2 28 1 1)
     1462(define-opcode iload_3 29 1 1)
     1463(define-opcode lload_0 30 1 2)
     1464(define-opcode lload_1 31 1 2)
     1465(define-opcode lload_2 32 1 2)
     1466(define-opcode lload_3 33 1 2)
     1467(define-opcode fload_0 34 1 nil)
     1468(define-opcode fload_1 35 1 nil)
     1469(define-opcode fload_2 36 1 nil)
     1470(define-opcode fload_3 37 1 nil)
     1471(define-opcode dload_0 38 1 nil)
     1472(define-opcode dload_1 39 1 nil)
     1473(define-opcode dload_2 40 1 nil)
     1474(define-opcode dload_3 41 1 nil)
     1475(define-opcode aload_0 42 1 1)
     1476(define-opcode aload_1 43 1 1)
     1477(define-opcode aload_2 44 1 1)
     1478(define-opcode aload_3 45 1 1)|#
     1479(define-opcode-effect iaload (smf-popn 2) (smf-push :int))
     1480(define-opcode-effect laload (smf-popn 2) (smf-push2 :long))
     1481(define-opcode-effect faload (smf-popn 2) (smf-push :float))
     1482(define-opcode-effect daload (smf-popn 2) (smf-push2 :double))
     1483#+nil ;;until there's newarray
     1484(define-opcode-effect aaload
     1485         (progn
     1486     (smf-pop)
     1487     (smf-push (smf-element-of (smf-pop)))))
     1488(define-opcode-effect baload (smf-popn 2) (smf-push :int))
     1489(define-opcode-effect caload (smf-popn 2) (smf-push :int))
     1490(define-opcode-effect saload (smf-popn 2) (smf-push :int))
     1491#|(define-opcode istore 54 2 -1)
     1492(define-opcode lstore 55 2 -2)
     1493(define-opcode fstore 56 2 nil)
     1494(define-opcode dstore 57 2 nil)
     1495(define-opcode astore 58 2 -1)
     1496(define-opcode istore_0 59 1 -1)
     1497(define-opcode istore_1 60 1 -1)
     1498(define-opcode istore_2 61 1 -1)
     1499(define-opcode istore_3 62 1 -1)
     1500(define-opcode lstore_0 63 1 -2)
     1501(define-opcode lstore_1 64 1 -2)
     1502(define-opcode lstore_2 65 1 -2)
     1503(define-opcode lstore_3 66 1 -2)
     1504(define-opcode fstore_0 67 1 nil)
     1505(define-opcode fstore_1 68 1 nil)
     1506(define-opcode fstore_2 69 1 nil)
     1507(define-opcode fstore_3 70 1 nil)
     1508(define-opcode dstore_0 71 1 nil)
     1509(define-opcode dstore_1 72 1 nil)
     1510(define-opcode dstore_2 73 1 nil)
     1511(define-opcode dstore_3 74 1 nil)
     1512(define-opcode astore_0 75 1 -1)
     1513(define-opcode astore_1 76 1 -1)
     1514(define-opcode astore_2 77 1 -1)
     1515(define-opcode astore_3 78 1 -1)
     1516(define-opcode iastore 79 1 -3)
     1517(define-opcode lastore 80 1 -4)
     1518(define-opcode fastore 81 1 -3)
     1519(define-opcode dastore 82 1 -4)
     1520(define-opcode aastore 83 1 -3)
     1521(define-opcode bastore 84 1 nil)
     1522(define-opcode castore 85 1 nil)
     1523(define-opcode sastore 86 1 nil)
     1524(define-opcode pop 87 1 -1)
     1525(define-opcode pop2 88 1 -2)
     1526(define-opcode dup 89 1 1)
     1527(define-opcode dup_x1 90 1 1)
     1528(define-opcode dup_x2 91 1 1)
     1529(define-opcode dup2 92 1 2)
     1530(define-opcode dup2_x1 93 1 2)
     1531(define-opcode dup2_x2 94 1 2)
     1532(define-opcode swap 95 1 0)
     1533(define-opcode iadd 96 1 -1)
     1534(define-opcode ladd 97 1 -2)
     1535(define-opcode fadd 98 1 -1)
     1536(define-opcode dadd 99 1 -2)
     1537(define-opcode isub 100 1 -1)
     1538(define-opcode lsub 101 1 -2)
     1539(define-opcode fsub 102 1 -1)
     1540(define-opcode dsub 103 1 -2)
     1541(define-opcode imul 104 1 -1)
     1542(define-opcode lmul 105 1 -2)
     1543(define-opcode fmul 106 1 -1)
     1544(define-opcode dmul 107 1 -2)
     1545(define-opcode idiv 108 1 nil)
     1546(define-opcode ldiv 109 1 nil)
     1547(define-opcode fdiv 110 1 nil)
     1548(define-opcode ddiv 111 1 nil)
     1549(define-opcode irem 112 1 nil)
     1550(define-opcode lrem 113 1 nil)
     1551(define-opcode frem 114 1 nil)
     1552(define-opcode drem 115 1 nil)
     1553(define-opcode ineg 116 1 0)
     1554(define-opcode lneg 117 1 0)
     1555(define-opcode fneg 118 1 0)
     1556(define-opcode dneg 119 1 0)
     1557(define-opcode ishl 120 1 -1)
     1558(define-opcode lshl 121 1 -1)
     1559(define-opcode ishr 122 1 -1)
     1560(define-opcode lshr 123 1 -1)
     1561(define-opcode iushr 124 1 nil)
     1562(define-opcode lushr 125 1 nil)
     1563(define-opcode iand 126 1 -1)
     1564(define-opcode land 127 1 -2)
     1565(define-opcode ior 128 1 -1)
     1566(define-opcode lor 129 1 -2)
     1567(define-opcode ixor 130 1 -1)
     1568(define-opcode lxor 131 1 -2)
     1569(define-opcode iinc 132 3 0)
     1570(define-opcode i2l 133 1 1)
     1571(define-opcode i2f 134 1 0)
     1572(define-opcode i2d 135 1 1)
     1573(define-opcode l2i 136 1 -1)
     1574(define-opcode l2f 137 1 -1)
     1575(define-opcode l2d 138 1 0)
     1576(define-opcode f2i 139 1 nil)
     1577(define-opcode f2l 140 1 nil)
     1578(define-opcode f2d 141 1 1)
     1579(define-opcode d2i 142 1 nil)
     1580(define-opcode d2l 143 1 nil)
     1581(define-opcode d2f 144 1 -1)
     1582(define-opcode i2b 145 1 nil)
     1583(define-opcode i2c 146 1 nil)
     1584(define-opcode i2s 147 1 nil)
     1585(define-opcode lcmp 148 1 -3)
     1586(define-opcode fcmpl 149 1 -1)
     1587(define-opcode fcmpg 150 1 -1)
     1588(define-opcode dcmpl 151 1 -3)
     1589(define-opcode dcmpg 152 1 -3)
     1590(define-opcode ifeq 153 3 -1)
     1591(define-opcode ifne 154 3 -1)
     1592(define-opcode iflt 155 3 -1)
     1593(define-opcode ifge 156 3 -1)
     1594(define-opcode ifgt 157 3 -1)
     1595(define-opcode ifle 158 3 -1)
     1596(define-opcode if_icmpeq 159 3 -2)
     1597(define-opcode if_icmpne 160 3 -2)
     1598(define-opcode if_icmplt 161 3 -2)
     1599(define-opcode if_icmpge 162 3 -2)
     1600(define-opcode if_icmpgt 163 3 -2)
     1601(define-opcode if_icmple 164 3 -2)
     1602(define-opcode if_acmpeq 165 3 -2)
     1603(define-opcode if_acmpne 166 3 -2)
     1604(define-opcode goto 167 3 0)
     1605;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
     1606;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
     1607(define-opcode tableswitch 170 0 nil)
     1608(define-opcode lookupswitch 171 0 nil)
     1609(define-opcode ireturn 172 1 nil)
     1610(define-opcode lreturn 173 1 nil)
     1611(define-opcode freturn 174 1 nil)
     1612(define-opcode dreturn 175 1 nil)
     1613(define-opcode areturn 176 1 -1)
     1614(define-opcode return 177 1 0)
     1615(define-opcode getstatic 178 3 1)
     1616(define-opcode putstatic 179 3 -1)
     1617(define-opcode getfield 180 3 0)
     1618(define-opcode putfield 181 3 -2)
     1619(define-opcode invokevirtual 182 3 nil)
     1620(define-opcode invokespecial 183 3 nil)
     1621(define-opcode invokestatic 184 3 nil)
     1622(define-opcode invokeinterface 185 5 nil)
     1623(define-opcode unused 186 0 nil)
     1624(define-opcode new 187 3 1)
     1625(define-opcode newarray 188 2 nil)
     1626(define-opcode anewarray 189 3 0)
     1627(define-opcode arraylength 190 1 0)
     1628(define-opcode athrow 191 1 0)
     1629(define-opcode checkcast 192 3 0)
     1630(define-opcode instanceof 193 3 0)
     1631(define-opcode monitorenter 194 1 -1)
     1632(define-opcode monitorexit 195 1 -1)
     1633(define-opcode wide 196 0 nil)
     1634(define-opcode multianewarray 197 4 nil)
     1635(define-opcode ifnull 198 3 -1)
     1636(define-opcode ifnonnull 199 3 nil)
     1637(define-opcode goto_w 200 5 nil)
     1638;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
     1639(define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
     1640;; (define-opcode push-value 203 nil 1)
     1641;; (define-opcode store-value 204 nil -1)
     1642(define-opcode clear-values 205 0 0)  ;; virtual: does not exist in the JVM
     1643;;(define-opcode var-ref 206 0 0)|#
     1644
    12761645#|
    12771646

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

    r12918 r12953  
    450450                      (inst 'aload (car (instruction-args instruction)))
    451451                      (inst 'aconst_null)
    452                       (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
    453                                                       +lisp-object-array+)))))
     452                      (inst 'putfield (u2 (constant-index
     453             (pool-field +lisp-thread+ "_values"
     454                   +lisp-object-array+))))))
    454455             (vector-push-extend instruction vector)))
    455456          (t
    … …  
    655656    (unless (= (length args) 1)
    656657      (error "Wrong number of args for LDC."))
    657     (if (> (car args) 255)
    658         (inst 19 (u2 (car args))) ; LDC_W
    659         (inst 18 args))))
     658    (let ((index (constant-index (car args))))
     659      (if (> index 255)
     660    (inst 19 (u2 index)) ; LDC_W
     661    (inst 18 args)))))
    660662
    661663;; ldc2_w
    … …  
    664666    (unless (= (length args) 1)
    665667      (error "Wrong number of args for LDC2_W."))
    666     (inst 20 (u2 (car args)))))
     668    (inst 20 (u2 (constant-index (car args))))))
    667669
    668670;; iinc
    … …  
    985987            (setf (svref bytes index) (instruction-opcode instruction))
    986988            (incf index)
    987             (dolist (byte (instruction-args instruction))
    988               (setf (svref bytes index) byte)
     989            (dolist (arg (instruction-args instruction))
     990              (setf (svref bytes index)
     991        (if (constant-p arg) (constant-index arg) arg))
    989992              (incf index)))))
    990993      (values bytes labels))))
Note: See TracChangeset for help on using the changeset viewer.