Changeset 12786
- Timestamp:
- 07/06/10 21:24:56 (13 years ago)
- Location:
- branches/generic-class-file/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
-
compiler-pass2.lisp (modified) (47 diffs)
-
jvm-class-file.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12764 r12786 201 201 (defconstant +fasl-loader-class+ 202 202 "org/armedbear/lisp/FaslClassLoader") 203 (defconstant +java-string+ "Ljava/lang/String;")204 (defconstant +java-object+ "Ljava/lang/Object;")205 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")206 (defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil")207 203 (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") 208 204 (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") … … 262 258 (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") 263 259 260 (defun !class-name (class-name) 261 "To be eliminated when all hard-coded strings are replaced by `class-name' 262 structures" 263 (if (typep class-name 'class-name) 264 (class-name-internal class-name) 265 class-name)) 266 267 (defun !class-ref (class-name) 268 "To be eliminated when all hard-coded strings are 269 replaced by `class-name' structures" 270 (if (typep class-name 'class-name) 271 (class-ref class-name) 272 class-name)) 273 264 274 (defstruct (instruction (:constructor %make-instruction (opcode args))) 265 275 (opcode 0 :type (integer 0 255)) … … 343 353 (declaim (inline emit-push-nil)) 344 354 (defun emit-push-nil () 345 (emit 'getstatic +lisp -class+ "NIL" +lisp-object+))355 (emit 'getstatic +lisp+ "NIL" +lisp-object+)) 346 356 347 357 (defknown emit-push-nil-symbol () t) 348 358 (declaim (inline emit-push-nil-symbol)) 349 359 (defun emit-push-nil-symbol () 350 (emit 'getstatic +lisp-nil -class+ "NIL" +lisp-symbol+))360 (emit 'getstatic +lisp-nil+ "NIL" +lisp-symbol+)) 351 361 352 362 (defknown emit-push-t () t) 353 363 (declaim (inline emit-push-t)) 354 364 (defun emit-push-t () 355 (emit 'getstatic +lisp -class+ "T" +lisp-symbol+))365 (emit 'getstatic +lisp+ "T" +lisp-symbol+)) 356 366 357 367 (defknown emit-push-false (t) t) … … 495 505 (declaim (ftype (function (t t) cons) get-descriptor-info)) 496 506 (defun get-descriptor-info (arg-types return-type) 497 (let* ((key (list arg-types return-type)) 507 (let* ((arg-types (mapcar #'!class-ref arg-types)) 508 (return-type (!class-ref return-type)) 509 (key (list arg-types return-type)) 498 510 (ht *descriptors*) 499 511 (descriptor-info (gethash1 key ht))) … … 510 522 (descriptor (car info)) 511 523 (stack-effect (cdr info)) 524 (class-name (!class-name class-name)) 512 525 (instruction (emit 'invokestatic class-name method-name descriptor))) 513 526 (setf (instruction-stack instruction) stack-effect))) … … 575 588 (defknown emit-unbox-boolean () t) 576 589 (defun emit-unbox-boolean () 577 (emit 'instanceof +lisp-nil -class+)590 (emit 'instanceof +lisp-nil+) 578 591 (emit 'iconst_1) 579 592 (emit 'ixor)) ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit … … 693 706 (descriptor (car info)) 694 707 (stack-effect (cdr info)) 708 (class-name (!class-name class-name)) 695 709 (instruction (emit 'invokevirtual class-name method-name descriptor))) 696 710 (declare (type (signed-byte 8) stack-effect)) … … 710 724 (descriptor (car info)) 711 725 (stack-effect (cdr info)) 726 (class-name (!class-name class-name)) 712 727 (instruction (emit 'invokespecial class-name "<init>" descriptor))) 713 728 (declare (type (signed-byte 8) stack-effect)) … … 785 800 (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name 786 801 +lisp-symbol+) 787 (emit-invokestatic +lisp -class+ "type_error"802 (emit-invokestatic +lisp+ "type_error" 788 803 (lisp-object-arg-types 2) +lisp-object+) 789 804 (emit 'pop) ; Needed for JVM stack consistency. … … 843 858 (unless (> *speed* *safety*) 844 859 (let ((label1 (gensym))) 845 (emit 'getstatic +lisp -class+ "interrupted" "Z")860 (emit 'getstatic +lisp+ "interrupted" "Z") 846 861 (emit 'ifeq label1) 847 (emit-invokestatic +lisp -class+ "handleInterrupt" nil nil)862 (emit-invokestatic +lisp+ "handleInterrupt" nil nil) 848 863 (label label1)))) 849 864 … … 1208 1223 (define-resolver (178 179) (instruction) 1209 1224 (let* ((args (instruction-args instruction)) 1210 (index (pool-field (first args) (second args) (third args)))) 1225 (index (pool-field (!class-name (first args)) 1226 (second args) (third args)))) 1211 1227 (inst (instruction-opcode instruction) (u2 index)))) 1212 1228 … … 1226 1242 (define-resolver (182 183 184) (instruction) 1227 1243 (let* ((args (instruction-args instruction)) 1228 (index (pool-method (first args) (second args) (third args)))) 1244 (index (pool-method (!class-name (first args)) 1245 (second args) (third args)))) 1229 1246 (setf (instruction-args instruction) (u2 index)) 1230 1247 instruction)) … … 1249 1266 (define-resolver (180 181) (instruction) 1250 1267 (let* ((args (instruction-args instruction)) 1251 (index (pool-field (first args) (second args) (third args)))) 1268 (index (pool-field (!class-name (first args)) 1269 (second args) (third args)))) 1252 1270 (inst (instruction-opcode instruction) (u2 index)))) 1253 1271 … … 1255 1273 (define-resolver (187 189 192 193) (instruction) 1256 1274 (let* ((args (instruction-args instruction)) 1257 (index (pool-class ( first args))))1275 (index (pool-class (!class-name (first args))))) 1258 1276 (inst (instruction-opcode instruction) (u2 index)))) 1259 1277 … … 1774 1792 (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name)))) 1775 1793 (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name))))) 1776 (emit-invokestatic +lisp-class+ "internInPackage" 1777 (list +java-string+ +java-string+) +lisp-symbol+)) 1794 (emit-invokestatic +lisp+ "internInPackage" 1795 (list +java-string+ +java-string+) 1796 +lisp-symbol+)) 1778 1797 (t 1779 1798 ;; No name. … … 1786 1805 (s (sys::%format nil "~S" lambda-list))) 1787 1806 (emit 'ldc (pool-string s)) 1788 (emit-invokestatic +lisp -class+ "readObjectFromString"1807 (emit-invokestatic +lisp+ "readObjectFromString" 1789 1808 (list +java-string+) +lisp-object+)) 1790 1809 (emit-push-nil))) … … 1856 1875 (progn 1857 1876 (emit 'ldc (pool-string (symbol-name keyword))) 1858 (emit-invokestatic +lisp -class+ "internKeyword"1877 (emit-invokestatic +lisp+ "internKeyword" 1859 1878 (list +java-string+) +lisp-symbol+)) 1860 1879 ;; symbol is not really a keyword; yes, that's allowed! … … 1863 1882 (emit 'ldc (pool-string 1864 1883 (package-name (symbol-package keyword)))) 1865 (emit-invokestatic +lisp -class+ "internInPackage"1884 (emit-invokestatic +lisp+ "internInPackage" 1866 1885 (list +java-string+ +java-string+) 1867 1886 +lisp-symbol+)))) … … 2094 2113 (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \"" 2095 2114 (package-name pkg) "\")"))) 2096 (emit-invokestatic +lisp -class+ "readObjectFromString"2115 (emit-invokestatic +lisp+ "readObjectFromString" 2097 2116 (list +java-string+) +lisp-object+)) 2098 2117 … … 2103 2122 (dump-form object stream)))) 2104 2123 (emit 'ldc (pool-string s)) 2105 (emit-invokestatic +lisp -class+ "readObjectFromString"2124 (emit-invokestatic +lisp+ "readObjectFromString" 2106 2125 (list +java-string+) +lisp-object+))) 2107 2126 … … 2121 2140 ((keywordp symbol) 2122 2141 (emit 'ldc (pool-string (symbol-name symbol))) 2123 (emit-invokestatic +lisp -class+ "internKeyword"2142 (emit-invokestatic +lisp+ "internKeyword" 2124 2143 (list +java-string+) +lisp-symbol+)) 2125 2144 (t 2126 2145 (emit 'ldc (pool-string (symbol-name symbol))) 2127 2146 (emit 'ldc (pool-string (package-name (symbol-package symbol)))) 2128 (emit-invokestatic +lisp -class+ "internInPackage"2147 (emit-invokestatic +lisp+ "internInPackage" 2129 2148 (list +java-string+ +java-string+) 2130 2149 +lisp-symbol+))))) … … 2190 2209 (remember field-name object) 2191 2210 (emit 'ldc (pool-string field-name)) 2192 (emit-invokestatic +lisp -class+ "recall"2211 (emit-invokestatic +lisp+ "recall" 2193 2212 (list +java-string+) +lisp-object+) 2194 2213 (when (string/= field-type +lisp-object+) … … 2308 2327 (declare-field g +lisp-object+ +field-access-private+) 2309 2328 (emit 'ldc (pool-string s)) 2310 (emit-invokestatic +lisp -class+ "readObjectFromString"2329 (emit-invokestatic +lisp+ "readObjectFromString" 2311 2330 (list +java-string+) +lisp-object+) 2312 2331 (emit 'putstatic *this-class* g +lisp-object+) … … 2328 2347 (declare-field g +lisp-object+ +field-access-private+) 2329 2348 (emit 'ldc (pool-string s)) 2330 (emit-invokestatic +lisp -class+ "readObjectFromString"2349 (emit-invokestatic +lisp+ "readObjectFromString" 2331 2350 (list +java-string+) +lisp-object+) 2332 (emit-invokestatic +lisp -class+ "loadTimeValue"2351 (emit-invokestatic +lisp+ "loadTimeValue" 2333 2352 (lisp-object-arg-types 1) +lisp-object+) 2334 2353 (emit 'putstatic *this-class* g +lisp-object+) … … 2353 2372 (declare-field g obj-ref +field-access-private+) 2354 2373 (emit 'ldc (pool-string g)) 2355 (emit-invokestatic +lisp -class+ "recall"2374 (emit-invokestatic +lisp+ "recall" 2356 2375 (list +java-string+) +lisp-object+) 2357 2376 (when (and obj-class (string/= obj-class +lisp-object-class+)) … … 2707 2726 (compile-form arg1 'stack nil) 2708 2727 (compile-form arg2 'stack nil) 2709 (emit-invokestatic +lisp -class+ "memq"2728 (emit-invokestatic +lisp+ "memq" 2710 2729 (lisp-object-arg-types 2) "Z") 2711 2730 (emit-move-from-stack target representation))) … … 2724 2743 (compile-form arg2 'stack nil) 2725 2744 (cond ((eq type1 'SYMBOL) ; FIXME 2726 (emit-invokestatic +lisp -class+ "memq"2745 (emit-invokestatic +lisp+ "memq" 2727 2746 (lisp-object-arg-types 2) "Z")) 2728 2747 (t 2729 (emit-invokestatic +lisp -class+ "memql"2748 (emit-invokestatic +lisp+ "memql" 2730 2749 (lisp-object-arg-types 2) "Z"))) 2731 2750 (emit-move-from-stack target representation))) … … 2736 2755 (cond ((and (null representation) (null (cdr form))) 2737 2756 (emit-push-current-thread) 2738 (emit-invokestatic +lisp -class+ "gensym"2757 (emit-invokestatic +lisp+ "gensym" 2739 2758 (list +lisp-thread+) +lisp-symbol+) 2740 2759 (emit-move-from-stack target)) … … 2757 2776 (compile-form arg3 'stack nil) 2758 2777 (maybe-emit-clear-values arg1 arg2 arg3))) 2759 (emit-invokestatic +lisp -class+ "get"2778 (emit-invokestatic +lisp+ "get" 2760 2779 (lisp-object-arg-types (if arg3 3 2)) 2761 2780 +lisp-object+) … … 2779 2798 arg2 'stack nil 2780 2799 arg3 'stack nil) 2781 (emit-invokestatic +lisp -class+ "getf"2800 (emit-invokestatic +lisp+ "getf" 2782 2801 (lisp-object-arg-types 3) +lisp-object+) 2783 2802 (fix-boxing representation nil) … … 3085 3104 (emit 'checkcast +lisp-compiled-closure-class+) 3086 3105 (duplicate-closure-array compiland) 3087 (emit-invokestatic +lisp -class+ "makeCompiledClosure"3106 (emit-invokestatic +lisp+ "makeCompiledClosure" 3088 3107 (list +lisp-object+ +closure-binding-array+) 3089 3108 +lisp-object+))))) … … 3568 3587 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3569 3588 arg2 'stack nil) 3570 (emit-invokestatic +lisp -class+ "memq"3589 (emit-invokestatic +lisp+ "memq" 3571 3590 (lisp-object-arg-types 2) "Z") 3572 3591 'ifeq))) … … 3578 3597 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3579 3598 arg2 'stack nil) 3580 (emit-invokestatic +lisp -class+ "memql"3599 (emit-invokestatic +lisp+ "memql" 3581 3600 (lisp-object-arg-types 2) "Z") 3582 3601 'ifeq))) … … 3818 3837 (emit-clear-values) 3819 3838 (compile-form (second form) 'stack nil) 3820 (emit-invokestatic +lisp -class+ "multipleValueList"3839 (emit-invokestatic +lisp+ "multipleValueList" 3821 3840 (lisp-object-arg-types 1) +lisp-object+) 3822 3841 (fix-boxing representation nil) … … 3854 3873 (2 3855 3874 (compile-form (second form) 'stack nil) 3856 (emit-invokestatic +lisp -class+ "coerceToFunction"3875 (emit-invokestatic +lisp+ "coerceToFunction" 3857 3876 (lisp-object-arg-types 1) +lisp-object+) 3858 3877 (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)) … … 3864 3883 (aload function-register) 3865 3884 (emit-push-current-thread) 3866 (emit-invokestatic +lisp -class+ "multipleValueCall1"3885 (emit-invokestatic +lisp+ "multipleValueCall1" 3867 3886 (list +lisp-object+ +lisp-object+ +lisp-thread+) 3868 3887 +lisp-object+))) … … 3873 3892 (values-register (allocate-register))) 3874 3893 (compile-form (second form) 'stack nil) 3875 (emit-invokestatic +lisp -class+ "coerceToFunction"3894 (emit-invokestatic +lisp+ "coerceToFunction" 3876 3895 (lisp-object-arg-types 1) +lisp-object+) 3877 3896 (emit-move-from-stack function-register) … … 4578 4597 (emit-push-variable (tagbody-id-variable tag-block)) 4579 4598 (emit-load-externalized-object (tag-label tag)) ; Tag. 4580 (emit-invokestatic +lisp -class+ "nonLocalGo" (lisp-object-arg-types 2)4599 (emit-invokestatic +lisp+ "nonLocalGo" (lisp-object-arg-types 2) 4581 4600 +lisp-object+) 4582 4601 ;; Following code will not be reached, but is needed for JVM stack … … 4655 4674 ((check-arg-count form 1)) 4656 4675 (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil) 4657 (emit-invokestatic +lisp -class+ "coerceToFunction"4676 (emit-invokestatic +lisp+ "coerceToFunction" 4658 4677 (lisp-object-arg-types 1) +lisp-object+) 4659 4678 (emit-move-from-stack target)) … … 4748 4767 (emit-clear-values) 4749 4768 (compile-form result-form 'stack nil) 4750 (emit-invokestatic +lisp -class+ "nonLocalReturn" (lisp-object-arg-types 3)4769 (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) 4751 4770 +lisp-object+) 4752 4771 ;; Following code will not be reached, but is needed for JVM stack … … 4825 4844 ;; Compile call to Lisp.progvBindVars(). 4826 4845 (emit-push-current-thread) 4827 (emit-invokestatic +lisp -class+ "progvBindVars"4846 (emit-invokestatic +lisp+ "progvBindVars" 4828 4847 (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) 4829 4848 ;; Implicit PROGN. … … 4939 4958 (emit 'checkcast +lisp-compiled-closure-class+) 4940 4959 (duplicate-closure-array parent) 4941 (emit-invokestatic +lisp -class+ "makeCompiledClosure"4960 (emit-invokestatic +lisp+ "makeCompiledClosure" 4942 4961 (list +lisp-object+ +closure-binding-array+) 4943 4962 +lisp-object+))) … … 5032 5051 ((compiland-closure-register *current-compiland*) 5033 5052 (duplicate-closure-array *current-compiland*) 5034 (emit-invokestatic +lisp -class+ "makeCompiledClosure"5053 (emit-invokestatic +lisp+ "makeCompiledClosure" 5035 5054 (list +lisp-object+ +closure-binding-array+) 5036 5055 +lisp-object+)) … … 5069 5088 (emit 'checkcast +lisp-compiled-closure-class+) 5070 5089 (duplicate-closure-array *current-compiland*) 5071 (emit-invokestatic +lisp -class+ "makeCompiledClosure"5090 (emit-invokestatic +lisp+ "makeCompiledClosure" 5072 5091 (list +lisp-object+ +closure-binding-array+) 5073 5092 +lisp-object+))))) … … 5526 5545 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int 5527 5546 arg2 'stack :int) 5528 (emit-invokestatic +lisp -class+ "mod" '("I" "I") "I")5547 (emit-invokestatic +lisp+ "mod" '("I" "I") "I") 5529 5548 (emit-move-from-stack target representation)) 5530 5549 ((fixnum-type-p type2) … … 5821 5840 (compile-form arg2 'stack nil) 5822 5841 (maybe-emit-clear-values arg1 arg2) 5823 (emit-invokestatic +lisp -class+ "writeByte"5842 (emit-invokestatic +lisp+ "writeByte" 5824 5843 (list "I" +lisp-object+) nil) 5825 5844 (when target … … 7481 7500 (emit 'ifne LABEL1) 7482 7501 (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) 7483 (emit-invokestatic +lisp -class+ "type_error"7502 (emit-invokestatic +lisp+ "type_error" 7484 7503 (lisp-object-arg-types 2) +lisp-object+) 7485 7504 (label LABEL1)) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
r12785 r12786 103 103 ,documentation)) 104 104 105 (define-class-name + !java-object+ "java.lang.Object")106 (define-class-name + !java-string+ "java.lang.String")105 (define-class-name +java-object+ "java.lang.Object") 106 (define-class-name +java-string+ "java.lang.String") 107 107 (define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") 108 108 (define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") 109 (define-class-name + !lisp+ "org.armedbear.lisp.Lisp")110 (define-class-name + !lisp-nil+ "org.armedbear.lisp.Nil")109 (define-class-name +lisp+ "org.armedbear.lisp.Lisp") 110 (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") 111 111 (define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") 112 112 (define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol")
Note: See TracChangeset
for help on using the changeset viewer.
