Changeset 12881
- Timestamp:
- 08/09/10 11:31:52 (13 years ago)
- 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 46 46 47 47 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 84 52 (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 90 55 (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 107 64 (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 117 67 (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)) 172 81 173 82 (defknown u2 (fixnum) cons) … … 333 242 (declaim (ftype (function * t) emit-invokestatic)) 334 243 (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))) 341 247 (instruction (apply #'%emit 'invokestatic (u2 index)))) 342 248 (setf (instruction-stack instruction) stack-effect))) … … 357 263 (defknown emit-invokevirtual (t t t t) t) 358 264 (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))) 365 268 (instruction (apply #'%emit 'invokevirtual (u2 index)))) 366 269 (declare (type (signed-byte 8) stack-effect)) … … 377 280 (defknown emit-invokespecial-init (string list) t) 378 281 (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))) 385 285 (instruction (apply #'%emit 'invokespecial (u2 index)))) 386 286 (declare (type (signed-byte 8) stack-effect)) … … 1277 1177 (defknown declare-field (t t t) t) 1278 1178 (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)))) 1281 1182 (class-add-field *class-file* field)) 1282 1183 (let ((field (make-field name (internal-field-ref descriptor)))) … … 7201 7102 (write-u2 3 stream) 7202 7103 (write-u2 45 stream) 7203 (write-constant -poolstream)7104 (write-constants *pool* stream) 7204 7105 ;; access flags 7205 7106 (write-u2 #x21 stream) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
r12879 r12881 138 138 (defmacro with-class-file (class-file &body body) 139 139 (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)) 144 143 (*fields* (abcl-class-file-fields ,var)) 145 144 (*static-code* (abcl-class-file-static-code ,var)) … … 147 146 (*declared-functions* (abcl-class-file-functions ,var))) 148 147 (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* 153 149 (abcl-class-file-static-code ,var) *static-code* 154 150 (abcl-class-file-objects ,var) *externalized-objects*
Note: See TracChangeset
for help on using the changeset viewer.