Changeset 12881


Ignore:
Timestamp:
08/09/10 11:31:52 (12 years ago)
Author:
ehuelsmann
Message:

Switch pass2 to the pool routines from jvm-class-file.lisp.

Location:
branches/generic-class-file/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12879 r12881  
    4646
    4747
    48 (defun dump-pool ()
    49   (let ((pool (reverse *pool*))
    50         entry type)
    51     (dotimes (index (1- *pool-count*))
    52       (setq entry (car pool))
    53       (setq type (case (car entry)
    54                    (7 'class)
    55                    (9 'field)
    56                    (10 'method)
    57                    (11 'interface)
    58                    (8 'string)
    59                    (3 'integer)
    60                    (4 'float)
    61                    (5 'long)
    62                    (6 'double)
    63                    (12 'name-and-type)
    64                    (1 'utf8)))
    65       (format t "~D: ~A ~S~%" (1+ index) type entry)
    66       (setq pool (cdr pool))))
    67   t)
    68 
    69 (defknown pool-get (t) (integer 1 65535))
    70 (defun pool-get (entry)
    71   (declare (optimize speed (safety 0)))
    72   (let* ((ht *pool-entries*)
    73          (index (gethash1 entry ht)))
    74     (declare (type hash-table ht))
    75     (unless index
    76       (setf index *pool-count*)
    77       (push entry *pool*)
    78       (setf (gethash entry ht) index)
    79       (setf *pool-count* (1+ index)))
    80     index))
    81 
    82 (declaim (ftype (function (string) fixnum) pool-name))
    83 (declaim (inline pool-name))
     48(declaim (inline pool-name pool-string pool-name-and-type
     49                 pool-class pool-field pool-method pool-int
     50                 pool-float pool-long pool-double))
     51
    8452(defun pool-name (name)
    85   (declare (optimize speed))
    86   (pool-get (list 1 (length name) name)))
    87 
    88 (declaim (ftype (function (string string) fixnum) pool-name-and-type))
    89 (declaim (inline pool-name-and-type))
     53  (pool-add-utf8 *pool* name))
     54
    9055(defun pool-name-and-type (name type)
    91   (declare (optimize speed))
    92   (pool-get (list 12
    93                   (pool-name name)
    94                   (pool-name type))))
    95 
    96 ;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
    97 ;; as opposed to "org.armedbear.lisp.Lisp").
    98 (declaim (ftype (function (string) fixnum) pool-class))
    99 (declaim (inline pool-class))
    100 (defun pool-class (class-name)
    101   (declare (optimize speed))
    102   (pool-get (list 7 (pool-name (class-name-internal class-name)))))
    103 
    104 ;; (tag class-index name-and-type-index)
    105 (declaim (ftype (function (string string string) fixnum) pool-field))
    106 (declaim (inline pool-field))
     56  (pool-add-name/type *pool* name type))
     57
     58(defun pool-class (name)
     59  (pool-add-class *pool* name))
     60
     61(defun pool-string (string)
     62  (pool-add-string *pool* string))
     63
    10764(defun pool-field (class-name field-name type-name)
    108   (declare (optimize speed))
    109   (pool-get (list 9
    110                   (pool-class class-name)
    111                   (pool-name-and-type field-name
    112                                       (internal-field-ref type-name)))))
    113 
    114 ;; (tag class-index name-and-type-index)
    115 (declaim (ftype (function (string string string) fixnum) pool-method))
    116 (declaim (inline pool-method))
     65  (pool-add-field-ref *pool* class-name field-name type-name))
     66
    11767(defun pool-method (class-name method-name type-name)
    118   (declare (optimize speed))
    119   (pool-get (list 10
    120                   (pool-class class-name)
    121                   (pool-name-and-type method-name type-name))))
    122 
    123 (declaim (ftype (function (string) fixnum) pool-string))
    124 (defun pool-string (string)
    125   (declare (optimize speed))
    126   (pool-get (list 8 (pool-name string))))
    127 
    128 (defknown pool-int (fixnum) (integer 1 65535))
    129 (defun pool-int (n)
    130   (declare (optimize speed))
    131   (pool-get (list 3 n)))
    132 
    133 (defknown pool-float (single-float) (integer 1 65535))
    134 (defun pool-float (n)
    135   (declare (optimize speed))
    136   (pool-get (list 4 (%float-bits n))))
    137 
    138 (defun pool-long/double (entry)
    139   (let* ((ht *pool-entries*)
    140          (index (gethash1 entry ht)))
    141     (declare (type hash-table ht))
    142     (unless index
    143       (setf index *pool-count*)
    144       (push entry *pool*)
    145       (setf (gethash entry ht) index)
    146       ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
    147       ;; constants take up two entries in the constant_pool table of the class
    148       ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
    149       ;; item in the constant_pool table at index n, then the next usable item in
    150       ;; the pool is located at index n+2. The constant_pool index n+1 must be
    151       ;; valid but is considered unusable." So:
    152       (setf *pool-count* (+ index 2)))
    153     index))
    154 
    155 (defknown pool-long (integer) (integer 1 65535))
    156 (defun pool-long (n)
    157   (declare (optimize speed))
    158   (declare (type java-long n))
    159   (let* ((entry (list 5
    160                       (logand (ash n -32) #xffffffff)
    161                       (logand n #xffffffff))))
    162     (pool-long/double entry)))
    163 
    164 (defknown pool-double (double-float) (integer 1 65535))
    165 (defun pool-double (n)
    166   (declare (optimize speed))
    167   (let* ((n (%float-bits n))
    168          (entry (list 6
    169                       (logand (ash n -32) #xffffffff)
    170                       (logand n #xffffffff))))
    171     (pool-long/double entry)))
     68  (pool-add-method-ref *pool* class-name method-name type-name))
     69
     70(defun pool-int (int)
     71  (pool-add-int *pool* int))
     72
     73(defun pool-float (float)
     74  (pool-add-float *pool* float))
     75
     76(defun pool-long (long)
     77  (pool-add-long *pool* long))
     78
     79(defun pool-double (double)
     80  (pool-add-double *pool* double))
    17281
    17382(defknown u2 (fixnum) cons)
     
    333242(declaim (ftype (function * t) emit-invokestatic))
    334243(defun emit-invokestatic (class-name method-name arg-types return-type)
    335   (let* ((descriptor (apply #'descriptor return-type arg-types))
    336          (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
    337          (index (if (null *current-code-attribute*)
    338                     (pool-method class-name method-name descriptor)
    339                     (pool-add-method-ref *pool* class-name
    340                                          method-name (cons return-type arg-types))))
     244  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
     245         (index (pool-add-method-ref *pool* class-name
     246                                     method-name (cons return-type arg-types)))
    341247         (instruction (apply #'%emit 'invokestatic (u2 index))))
    342248    (setf (instruction-stack instruction) stack-effect)))
     
    357263(defknown emit-invokevirtual (t t t t) t)
    358264(defun emit-invokevirtual (class-name method-name arg-types return-type)
    359   (let* ((descriptor (apply #'descriptor return-type arg-types))
    360          (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
    361          (index (if (null *current-code-attribute*)
    362                     (pool-method class-name method-name descriptor)
    363                     (pool-add-method-ref *pool* class-name
    364                                          method-name (cons return-type arg-types))))
     265  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
     266         (index (pool-add-method-ref *pool* class-name
     267                                     method-name (cons return-type arg-types)))
    365268         (instruction (apply #'%emit 'invokevirtual (u2 index))))
    366269    (declare (type (signed-byte 8) stack-effect))
     
    377280(defknown emit-invokespecial-init (string list) t)
    378281(defun emit-invokespecial-init (class-name arg-types)
    379   (let* ((descriptor (apply #'descriptor :void arg-types))
    380          (stack-effect (apply #'descriptor-stack-effect :void arg-types))
    381          (index (if (null *current-code-attribute*)
    382                     (pool-method class-name "<init>" descriptor)
    383                     (pool-add-method-ref *pool* class-name
    384                                          "<init>" (cons nil arg-types))))
     282  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
     283         (index (pool-add-method-ref *pool* class-name
     284                                     "<init>" (cons nil arg-types)))
    385285         (instruction (apply #'%emit 'invokespecial (u2 index))))
    386286    (declare (type (signed-byte 8) stack-effect))
     
    12771177(defknown declare-field (t t t) t)
    12781178(defun declare-field (name descriptor)
    1279   (if *current-code-attribute*
    1280       (let ((field (!make-field name descriptor '(:final :static :private))))
     1179  (if nil ;; *current-code-attribute*
     1180      (let ((field (!make-field name descriptor
     1181                                :flags '(:final :static :private))))
    12811182        (class-add-field *class-file* field))
    12821183      (let ((field (make-field name (internal-field-ref descriptor))))
     
    72017102    (write-u2 3 stream)
    72027103    (write-u2 45 stream)
    7203     (write-constant-pool stream)
     7104    (write-constants *pool* stream)
    72047105    ;; access flags
    72057106    (write-u2 #x21 stream)
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

    r12879 r12881  
    138138(defmacro with-class-file (class-file &body body)
    139139  (let ((var (gensym)))
    140     `(let* ((,var ,class-file)
    141             (*pool*                 (abcl-class-file-pool ,var))
    142             (*pool-count*           (abcl-class-file-pool-count ,var))
    143             (*pool-entries*         (abcl-class-file-pool-entries ,var))
     140    `(let* ((,var                   ,class-file)
     141            (*class-file*           ,var)
     142            (*pool*                 (abcl-class-file-constants ,var))
    144143            (*fields*               (abcl-class-file-fields ,var))
    145144            (*static-code*          (abcl-class-file-static-code ,var))
     
    147146            (*declared-functions*   (abcl-class-file-functions ,var)))
    148147       (progn ,@body)
    149        (setf (abcl-class-file-pool ,var)         *pool*
    150              (abcl-class-file-pool-count ,var)   *pool-count*
    151              (abcl-class-file-pool-entries ,var) *pool-entries*
    152              (abcl-class-file-fields ,var)       *fields*
     148       (setf (abcl-class-file-fields ,var)       *fields*
    153149             (abcl-class-file-static-code ,var)  *static-code*
    154150             (abcl-class-file-objects ,var)      *externalized-objects*
Note: See TracChangeset for help on using the changeset viewer.