Changeset 12702 for trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
- Timestamp:
- 05/18/10 21:44:11 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12699 r12702 235 235 (defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector") 236 236 (defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString") 237 (defconstant +lisp-abstract-string+ "Lorg/armedbear/lisp/AbstractString;") 237 238 (defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") 238 239 (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") … … 2169 2170 (single-float "FLT" ,#'eql ,#'serialize-float ,+lisp-single-float+) 2170 2171 (double-float "DBL" ,#'eql ,#'serialize-double ,+lisp-double-float+) 2171 (string "STR" ,#'equal ,#'serialize-string ,+lisp-simple-string+) 2172 (string "STR" ,#'equal ,#'serialize-string 2173 ,+lisp-abstract-string+) ;; because of (not compile-file) 2172 2174 (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+) 2173 2175 (symbol "SYM" ,#'eq ,#'serialize-symbol ,+lisp-symbol+) … … 2204 2206 serialization-table) 2205 2207 (declare (ignore type)) ;; the type has been used in the selection process 2208 (when (not *file-compilation*) ;; in-memory compilation wants object EQ-ness 2209 (setf similarity-fn #'eq)) 2206 2210 (let ((existing (assoc object *externalized-objects* :test similarity-fn))) 2207 2211 (when existing … … 2216 2220 (push (cons object field-name) *externalized-objects*) 2217 2221 2218 (if *declare-inline* 2219 (progn 2220 (funcall dispatch-fn object) 2221 (emit 'putstatic *this-class* field-name field-type)) 2222 (let ((*code* *static-code*)) 2223 (funcall dispatch-fn object) 2224 (emit 'putstatic *this-class* field-name field-type) 2225 (setf *static-code* *code*))) 2222 (cond 2223 ((not *file-compilation*) 2224 (let ((*code* *static-code*)) 2225 (remember field-name object) 2226 (emit 'ldc (pool-string field-name)) 2227 (emit-invokestatic +lisp-class+ "recall" 2228 (list +java-string+) +lisp-object+) 2229 (when (string/= field-type +lisp-object+) 2230 (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) 2231 (emit 'putstatic *this-class* field-name field-type) 2232 (setf *static-code* *code*))) 2233 (*declare-inline* 2234 (funcall dispatch-fn object) 2235 (emit 'putstatic *this-class* field-name field-type)) 2236 (t ;; *file-compilation* and (not *declare-inline*) 2237 (let ((*code* *static-code*)) 2238 (funcall dispatch-fn object) 2239 (emit 'putstatic *this-class* field-name field-type) 2240 (setf *static-code* *code*)))) 2226 2241 2227 2242 (emit 'getstatic *this-class* field-name field-type) … … 2495 2510 (typep form 'single-float) 2496 2511 (typep form 'double-float) 2497 (characterp form)) 2512 (characterp form) 2513 (stringp form) 2514 (packagep form) 2515 (pathnamep form) 2516 (vectorp form)) 2498 2517 (emit-load-externalized-object form)) 2499 2518 ((or (stringp form) … … 2501 2520 (pathnamep form) 2502 2521 (vectorp form)) 2503 (if *file-compilation* 2504 (emit-load-externalized-object form) 2505 (emit 'getstatic *this-class* 2506 (declare-object form) +lisp-object+))) 2522 (emit-load-externalized-object form)) 2507 2523 ((or (hash-table-p form) 2508 2524 (typep form 'generic-function)) … … 2519 2535 (if *file-compilation* 2520 2536 (error "COMPILE-CONSTANT unhandled case ~S" form) 2521 (emit 'getstatic *this-class* 2522 (declare-object form) +lisp-object+)))) 2537 (emit-load-externalized-object form)))) 2523 2538 (emit-move-from-stack target representation)) 2524 2539 … … 3174 3189 (assert (local-function-references-allowed-p local-function)) 3175 3190 (assert (not *file-compilation*)) 3176 (emit 'getstatic *this-class* 3177 (declare-object (local-function-environment local-function) 3178 +lisp-environment+ 3179 +lisp-environment-class+) 3180 +lisp-environment+) 3181 (emit 'getstatic *this-class* 3182 (declare-object (local-function-name local-function)) 3183 +lisp-object+) 3191 (emit-load-externalized-object 3192 (local-function-environmont local-function) 3193 +lisp-environment-class+) 3194 (emit-load-externalized-object (local-function-name local-function)) 3184 3195 (emit-invokevirtual +lisp-environment-class+ "lookupFunction" 3185 3196 (list +lisp-object+) … … 4356 4367 ((variable-environment variable) 4357 4368 (assert (not *file-compilation*)) 4358 (emit 'getstatic *this-class* 4359 (declare-object (variable-environment variable) 4360 +lisp-environment+ 4361 +lisp-environment-class+) 4362 +lisp-environment+) 4369 (emit-load-externalized-object (variable-environment variable) 4370 +lisp-environment-class+) 4363 4371 (emit 'swap) 4364 4372 (emit-push-variable-name variable) … … 4391 4399 ((variable-environment variable) 4392 4400 (assert (not *file-compilation*)) 4393 (emit 'getstatic *this-class* 4394 (declare-object (variable-environment variable) 4395 +lisp-environment+ 4396 +lisp-environment-class+) 4397 +lisp-environment+) 4401 (emit-load-externalized-object (variable-environment variable) 4402 +lisp-environment-class+) 4398 4403 (emit-push-variable-name variable) 4399 4404 (emit-invokevirtual +lisp-environment-class+ "lookup" … … 4663 4668 (tagbody-tags block))) 4664 4669 (aload tag-register) 4665 (emit 'getstatic *this-class* 4666 (if *file-compilation* 4667 (declare-object-as-string (tag-label tag)) 4668 (declare-object (tag-label tag))) 4669 +lisp-object+) 4670 (emit-load-externalized-object (tag-label tag)) 4670 4671 ;; Jump if EQ. 4671 4672 (emit 'if_acmpeq (tag-label tag))) … … 4725 4726 ;; Non-local GO. 4726 4727 (emit-push-variable (tagbody-id-variable tag-block)) 4727 (emit 'getstatic *this-class* 4728 (if *file-compilation* 4729 (declare-object-as-string (tag-label tag)) 4730 (declare-object (tag-label tag))) 4731 +lisp-object+) ; Tag. 4728 (emit-load-externalized-object (tag-label tag)) ; Tag. 4732 4729 (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2) 4733 4730 +lisp-object+) … … 4899 4896 (aver (block-non-local-return-p block)) 4900 4897 (emit-push-variable (block-id-variable block)) 4901 (emit 'getstatic *this-class* 4902 (if *file-compilation* 4903 (declare-object-as-string (block-name block)) 4904 (declare-object (block-name block))) 4905 +lisp-object+) 4898 (emit-load-externalized-object (block-name block)) 4906 4899 (emit-clear-values) 4907 4900 (compile-form result-form 'stack nil) … … 5004 4997 (emit-move-from-stack target representation)) 5005 4998 ((listp obj) 5006 (let ((g (if *file-compilation* 5007 (declare-object-as-string obj) 5008 (declare-object obj)))) 5009 (emit 'getstatic *this-class* g +lisp-object+) 5010 (emit-move-from-stack target representation))) 4999 (emit-load-externalized-object obj) 5000 (emit-move-from-stack target representation)) 5011 5001 ((constantp obj) 5012 5002 (compile-constant obj target representation)) … … 5188 5178 (compile-and-write-to-stream (compiland-class-file compiland) 5189 5179 compiland stream) 5190 (emit 'getstatic *this-class* 5191 (declare-object (load-compiled-function 5192 (sys::%get-output-stream-bytes stream))) 5193 +lisp-object+)))) 5180 (emit-load-externalized-object (load-compiled-function 5181 (sys::%get-output-stream-bytes stream)))))) 5194 5182 (cond ((null *closure-variables*)) ; Nothing to do. 5195 5183 ((compiland-closure-register *current-compiland*) … … 5276 5264 (fboundp name) 5277 5265 (fdefinition name)) 5278 (emit 'getstatic *this-class* 5279 (declare-object (fdefinition name)) +lisp-object+) 5266 (emit-load-externalized-object (fdefinition name)) 5280 5267 (emit-move-from-stack target)) 5281 5268 (t
Note: See TracChangeset
for help on using the changeset viewer.
