Changeset 12837 for trunk/abcl/src/org/armedbear
- Timestamp:
- 07/31/10 12:52:40 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12836 r12837 343 343 (declaim (inline emit-push-nil)) 344 344 (defun emit-push-nil () 345 (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))345 (emit-getstatic +lisp-class+ "NIL" +lisp-object+)) 346 346 347 347 (defknown emit-push-nil-symbol () t) 348 348 (declaim (inline emit-push-nil-symbol)) 349 349 (defun emit-push-nil-symbol () 350 (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+))350 (emit-getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) 351 351 352 352 (defknown emit-push-t () t) 353 353 (declaim (inline emit-push-t)) 354 354 (defun emit-push-t () 355 (emit 'getstatic +lisp-class+ "T" +lisp-symbol+))355 (emit-getstatic +lisp-class+ "T" +lisp-symbol+)) 356 356 357 357 (defknown emit-push-false (t) t) … … 570 570 (setf pretty-string (concatenate 'string pretty-string "[]"))) 571 571 pretty-string)) 572 573 (declaim (inline emit-getstatic emit-putstatic)) 574 (defknown emit-getstatic (t t t) t) 575 (defun emit-getstatic (class-name field-name type) 576 (let ((index (pool-field class-name field-name type))) 577 (apply #'%emit 'getstatic (u2 index)))) 578 579 (defknown emit-putstatic (t t t) t) 580 (defun emit-putstatic (class-name field-name type) 581 (let ((index (pool-field class-name field-name type))) 582 (apply #'%emit 'putstatic (u2 index)))) 572 583 573 584 (defvar type-representations '((:int fixnum) … … 773 784 (emit 'ifne LABEL1) 774 785 (emit-load-local-variable variable) 775 (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name786 (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name 776 787 +lisp-symbol+) 777 788 (emit-invokestatic +lisp-class+ "type_error" … … 833 844 (unless (> *speed* *safety*) 834 845 (let ((label1 (gensym))) 835 (emit 'getstatic +lisp-class+ "interrupted" "Z")846 (emit-getstatic +lisp-class+ "interrupted" "Z") 836 847 (emit 'ifeq label1) 837 848 (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) … … 1197 1208 ;; getstatic, putstatic 1198 1209 (define-resolver (178 179) (instruction) 1199 (let* ((args (instruction-args instruction)) 1200 (index (pool-field (first args) (second args) (third args)))) 1201 (inst (instruction-opcode instruction) (u2 index)))) 1210 ;; we used to create the pool-field here; that moved to the emit-* layer 1211 instruction) 1202 1212 1203 1213 ;; bipush, sipush … … 1835 1845 (emit-push-nil) 1836 1846 (emit-push-t)) ;; we don't need the actual supplied-p symbol 1837 (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I")1847 (emit-getstatic +lisp-closure-class+ "OPTIONAL" "I") 1838 1848 (emit-invokespecial-init +lisp-closure-parameter-class+ 1839 1849 (list +lisp-symbol+ +lisp-object+ … … 2033 2043 "Generates code to restore a serialized integer." 2034 2044 (cond((<= 0 n 255) 2035 (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)2045 (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) 2036 2046 (emit-push-constant-int n) 2037 2047 (emit 'aaload)) … … 2102 2112 (cond 2103 2113 (name 2104 (emit 'getstatic class name +lisp-symbol+))2114 (emit-getstatic class name +lisp-symbol+)) 2105 2115 ((null (symbol-package symbol)) 2106 2116 (emit-push-constant-int (dump-uninterned-symbol-index symbol)) … … 2164 2174 (let ((existing (assoc object *externalized-objects* :test similarity-fn))) 2165 2175 (when existing 2166 (emit 'getstatic *this-class* (cdr existing) field-type)2176 (emit-getstatic *this-class* (cdr existing) field-type) 2167 2177 (when cast 2168 2178 (emit 'checkcast cast)) … … 2183 2193 (when (string/= field-type +lisp-object+) 2184 2194 (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) 2185 (emit 'putstatic *this-class* field-name field-type)2195 (emit-putstatic *this-class* field-name field-type) 2186 2196 (setf *static-code* *code*))) 2187 2197 (*declare-inline* 2188 2198 (funcall dispatch-fn object) 2189 (emit 'putstatic *this-class* field-name field-type))2199 (emit-putstatic *this-class* field-name field-type)) 2190 2200 (t 2191 2201 (let ((*code* *static-code*)) 2192 2202 (funcall dispatch-fn object) 2193 (emit 'putstatic *this-class* field-name field-type)2203 (emit-putstatic *this-class* field-name field-type) 2194 2204 (setf *static-code* *code*)))) 2195 2205 2196 (emit 'getstatic *this-class* field-name field-type)2206 (emit-getstatic *this-class* field-name field-type) 2197 2207 (when cast 2198 2208 (emit 'checkcast cast)) … … 2226 2236 (if (eq class *this-class*) 2227 2237 (progn ;; generated by the DECLARE-OBJECT*'s above 2228 (emit 'getstatic class name +lisp-object+)2238 (emit-getstatic class name +lisp-object+) 2229 2239 (emit 'checkcast +lisp-symbol-class+)) 2230 (emit 'getstatic class name +lisp-symbol+))2240 (emit-getstatic class name +lisp-symbol+)) 2231 2241 (emit-invokevirtual +lisp-symbol-class+ 2232 2242 (if setf … … 2238 2248 (emit-invokevirtual +lisp-object-class+ 2239 2249 "resolve" nil +lisp-object+) 2240 (emit 'putstatic *this-class* f +lisp-object+)2250 (emit-putstatic *this-class* f +lisp-object+) 2241 2251 (if *declare-inline* 2242 2252 (setf saved-code *code*) … … 2274 2284 ; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" 2275 2285 ; (list +java-string+) +lisp-object+) 2276 (emit 'putstatic *this-class* g +lisp-object+)2286 (emit-putstatic *this-class* g +lisp-object+) 2277 2287 (setf *static-code* *code*) 2278 2288 (setf (gethash local-function ht) g)))) … … 2299 2309 (emit-invokestatic +lisp-class+ "readObjectFromString" 2300 2310 (list +java-string+) +lisp-object+) 2301 (emit 'putstatic *this-class* g +lisp-object+)2311 (emit-putstatic *this-class* g +lisp-object+) 2302 2312 (if *declare-inline* 2303 2313 (setf saved-code *code*) … … 2321 2331 (emit-invokestatic +lisp-class+ "loadTimeValue" 2322 2332 (lisp-object-arg-types 1) +lisp-object+) 2323 (emit 'putstatic *this-class* g +lisp-object+)2333 (emit-putstatic *this-class* g +lisp-object+) 2324 2334 (if *declare-inline* 2325 2335 (setf saved-code *code*) … … 2346 2356 (when (and obj-class (string/= obj-class +lisp-object-class+)) 2347 2357 (emit 'checkcast obj-class)) 2348 (emit 'putstatic *this-class* g obj-ref)2358 (emit-putstatic *this-class* g obj-ref) 2349 2359 (setf *static-code* *code*) 2350 2360 g))) … … 3069 3079 (declare-object 3070 3080 (local-function-function local-function))))) 3071 (emit 'getstatic *this-class* g +lisp-object+)3081 (emit-getstatic *this-class* g +lisp-object+) 3072 3082 ; Stack: template-function 3073 3083 (when *closure-variables* … … 4790 4800 (defun p2-load-time-value (form target representation) 4791 4801 (cond (*file-compilation* 4792 (emit 'getstatic *this-class*4802 (emit-getstatic *this-class* 4793 4803 (declare-load-time-value (second form)) +lisp-object+) 4794 4804 (fix-boxing representation nil) … … 4921 4931 (defun emit-make-compiled-closure-for-labels 4922 4932 (local-function compiland declaration) 4923 (emit 'getstatic *this-class* declaration +lisp-object+)4933 (emit-getstatic *this-class* declaration +lisp-object+) 4924 4934 (let ((parent (compiland-parent compiland))) 4925 4935 (when (compiland-closure-register parent) … … 5006 5016 (with-open-class-file (f class-file) 5007 5017 (compile-and-write-to-stream class-file compiland f)) 5008 (emit 'getstatic *this-class*5018 (emit-getstatic *this-class* 5009 5019 (declare-local-function (make-local-function :class-file 5010 5020 class-file)) … … 5052 5062 (declare-object 5053 5063 (local-function-function local-function))))) 5054 (emit 'getstatic *this-class* g +lisp-object+)5064 (emit-getstatic *this-class* g +lisp-object+) 5055 5065 ; Stack: template-function 5056 5066 … … 5063 5073 (emit-move-from-stack target)) 5064 5074 ((inline-ok name) 5065 (emit 'getstatic *this-class*5075 (emit-getstatic *this-class* 5066 5076 (declare-function name) +lisp-object+) 5067 5077 (emit-move-from-stack target)) … … 5093 5103 (declare-object 5094 5104 (local-function-function local-function))))) 5095 (emit 'getstatic *this-class*5105 (emit-getstatic *this-class* 5096 5106 g +lisp-object+))))) ; Stack: template-function 5097 5107 ((and (member name *functions-defined-in-current-file* :test #'equal) 5098 5108 (not (notinline-p name))) 5099 (emit 'getstatic *this-class*5109 (emit-getstatic *this-class* 5100 5110 (declare-setf-function name) +lisp-object+) 5101 5111 (emit-move-from-stack target)) … … 7469 7479 (emit 'instanceof instanceof-class) 7470 7480 (emit 'ifne LABEL1) 7471 (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+)7481 (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) 7472 7482 (emit-invokestatic +lisp-class+ "type_error" 7473 7483 (lisp-object-arg-types 2) +lisp-object+)
Note: See TracChangeset
for help on using the changeset viewer.
