Changeset 12856
- Timestamp:
- 08/02/10 20:59:52 (13 years ago)
- Location:
- branches/generic-class-file/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
-
compile-file.lisp (modified) (1 diff)
-
compiler-pass2.lisp (modified) (90 diffs)
-
jvm-class-file.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
r12852 r12856 700 700 (jvm::emit-invokevirtual +fasl-classloader+ 701 701 "putFunction" 702 (list "I"jvm::+lisp-object+) jvm::+lisp-object+)702 (list :int jvm::+lisp-object+) jvm::+lisp-object+) 703 703 (jvm::emit 'jvm::pop)) 704 704 t)))))) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12855 r12856 215 215 "To be eliminated when all hard-coded strings are 216 216 replaced by `class-name' structures" 217 (if ( typep class-name 'class-name)218 ( class-ref class-name)217 (if (or (symbolp class-name) (typep class-name 'class-name)) 218 (internal-field-ref class-name) 219 219 class-name)) 220 220 … … 413 413 (emit 'pop2))))) 414 414 415 (declaim (ftype (function (t t) cons) make-descriptor-info))416 (defun make-descriptor-info (arg-types return-type)417 (let ((descriptor (with-standard-io-syntax418 (with-output-to-string (s)419 (princ #\( s)420 (dolist (type arg-types)421 (princ type s))422 (princ #\) s)423 (princ (or return-type "V") s))))424 (stack-effect (let ((result (cond ((null return-type) 0)425 ((or (equal return-type "J")426 (equal return-type "D")) 2)427 (t 1))))428 (dolist (type arg-types result)429 (decf result (if (or (equal type "J")430 (equal type "D"))431 2 1))))))432 (cons descriptor stack-effect)))433 434 (defparameter *descriptors* (make-hash-table :test #'equal))435 436 (declaim (ftype (function (t t) cons) get-descriptor-info))437 (defun get-descriptor-info (arg-types return-type)438 (let* ((arg-types (mapcar #'!class-ref arg-types))439 (return-type (!class-ref return-type))440 (key (list arg-types return-type))441 (ht *descriptors*)442 (descriptor-info (gethash1 key ht)))443 (declare (type hash-table ht))444 (or descriptor-info445 (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))446 447 415 (declaim (inline get-descriptor)) 448 416 (defun get-descriptor (arg-types return-type) 449 ( car (get-descriptor-info arg-types return-type)))417 (apply #'descriptor return-type arg-types)) 450 418 451 419 (declaim (ftype (function * t) emit-invokestatic)) 452 420 (defun emit-invokestatic (class-name method-name arg-types return-type) 453 (let* ((info (get-descriptor-info arg-types return-type)) 454 (descriptor (car info)) 455 (stack-effect (cdr info)) 421 (let* ((descriptor (apply #'descriptor return-type arg-types)) 422 (stack-effect (apply #'descriptor-stack-effect return-type arg-types)) 456 423 (index (if (null *current-code-attribute*) 457 424 (pool-method class-name method-name descriptor) … … 476 443 (defknown emit-invokevirtual (t t t t) t) 477 444 (defun emit-invokevirtual (class-name method-name arg-types return-type) 478 (let* ((info (get-descriptor-info arg-types return-type)) 479 (descriptor (car info)) 480 (stack-effect (cdr info)) 445 (let* ((descriptor (apply #'descriptor return-type arg-types)) 446 (stack-effect (apply #'descriptor-stack-effect return-type arg-types)) 481 447 (index (if (null *current-code-attribute*) 482 448 (pool-method class-name method-name descriptor) … … 497 463 (defknown emit-invokespecial-init (string list) t) 498 464 (defun emit-invokespecial-init (class-name arg-types) 499 (let* ((info (get-descriptor-info arg-types nil)) 500 (descriptor (car info)) 501 (stack-effect (cdr info)) 465 (let* ((descriptor (apply #'descriptor :void arg-types)) 466 (stack-effect (apply #'descriptor-stack-effect :void arg-types)) 502 467 (index (if (null *current-code-attribute*) 503 468 (pool-method class-name "<init>" descriptor) … … 525 490 ((equal type +lisp-thread+) 526 491 "LispThread") 527 ((equal type "C")492 ((equal type :char) 528 493 "char") 529 ((equal type "I")494 ((equal type :int) 530 495 "int") 531 ((equal type "Z")496 ((equal type :boolean) 532 497 "boolean") 533 ((null type) 498 ((or (null type) 499 (eq type :void)) 534 500 "void") 535 501 (t … … 594 560 (cond ((> *safety* 0) 595 561 (emit-invokestatic +lisp-character+ "getValue" 596 (lisp-object-arg-types 1) "C"))562 (lisp-object-arg-types 1) :char)) 597 563 (t 598 564 (emit 'checkcast +lisp-character+) 599 (emit 'getfield +lisp-character+ "value" "C"))))565 (emit 'getfield +lisp-character+ "value" :char)))) 600 566 601 567 ;; source type / … … 624 590 when converting the internal representation to a LispObject.") 625 591 626 (defvar rep-arg-chars627 '((:boolean . "Z")628 (:char . "C")629 (:int . "I")630 (:long . "J")631 (:float . "F")632 (:double . "D"))633 "Lists the argument type identifiers for each634 of the internal representations.")635 592 636 593 (defun convert-representation (in out) … … 643 600 ;; Convert back to a lisp object 644 601 (when in 645 (let ((class (cdr (assoc in rep-classes))) 646 (arg-spec (cdr (assoc in rep-arg-chars)))) 647 (emit-invokestatic class "getInstance" (list arg-spec) 648 class))) 602 (let ((class (cdr (assoc in rep-classes)))) 603 (emit-invokestatic class "getInstance" (list in) class))) 649 604 (return-from convert-representation)) 650 605 (let* ((in-map (cdr (assoc in rep-conversion))) … … 660 615 (funcall op)) 661 616 ((stringp op) 662 (emit-invokevirtual +lisp-object+ op nil 663 (cdr (assoc out rep-arg-chars)))) 617 (emit-invokevirtual +lisp-object+ op nil out)) 664 618 (t 665 619 (emit op)))))) … … 816 770 (unless (> *speed* *safety*) 817 771 (let ((label1 (gensym))) 818 (emit-getstatic +lisp+ "interrupted" "Z")772 (emit-getstatic +lisp+ "interrupted" :boolean) 819 773 (emit 'ifeq label1) 820 774 (emit-invokestatic +lisp+ "handleInterrupt" nil nil) … … 895 849 (cond ((= *safety* 3) 896 850 (emit-invokestatic +lisp-fixnum+ "getValue" 897 (lisp-object-arg-types 1) "I"))851 (lisp-object-arg-types 1) :int)) 898 852 (t 899 853 (emit 'checkcast +lisp-fixnum+) 900 (emit 'getfield +lisp-fixnum+ "value" "I"))))854 (emit 'getfield +lisp-fixnum+ "value" :int)))) 901 855 902 856 (defknown emit-unbox-long () t) 903 857 (defun emit-unbox-long () 904 858 (emit-invokestatic +lisp-bignum+ "longValue" 905 (lisp-object-arg-types 1) "J"))859 (lisp-object-arg-types 1) :long)) 906 860 907 861 (defknown emit-unbox-float () t) … … 910 864 (cond ((= *safety* 3) 911 865 (emit-invokestatic +lisp-single-float+ "getValue" 912 (lisp-object-arg-types 1) "F"))866 (lisp-object-arg-types 1) :float)) 913 867 (t 914 868 (emit 'checkcast +lisp-single-float+) 915 (emit 'getfield +lisp-single-float+ "value" "F"))))869 (emit 'getfield +lisp-single-float+ "value" :float)))) 916 870 917 871 (defknown emit-unbox-double () t) … … 920 874 (cond ((= *safety* 3) 921 875 (emit-invokestatic +lisp-double-float+ "getValue" 922 (lisp-object-arg-types 1) "D"))876 (lisp-object-arg-types 1) :double)) 923 877 (t 924 878 (emit 'checkcast +lisp-double-float+) 925 (emit 'getfield +lisp-double-float+ "value" "D"))))879 (emit 'getfield +lisp-double-float+ "value" :double)))) 926 880 927 881 (defknown fix-boxing (t t) t) … … 934 888 (< *safety* 3)) 935 889 (emit 'checkcast +lisp-fixnum+) 936 (emit 'getfield +lisp-fixnum+ "value" "I"))890 (emit 'getfield +lisp-fixnum+ "value" :int)) 937 891 (t 938 (emit-invokevirtual +lisp-object+ "intValue" nil "I"))))892 (emit-invokevirtual +lisp-object+ "intValue" nil :int)))) 939 893 ((eq required-representation :char) 940 894 (emit-unbox-character)) … … 942 896 (emit-unbox-boolean)) 943 897 ((eq required-representation :long) 944 (emit-invokevirtual +lisp-object+ "longValue" nil "J"))898 (emit-invokevirtual +lisp-object+ "longValue" nil :long)) 945 899 ((eq required-representation :float) 946 (emit-invokevirtual +lisp-object+ "floatValue" nil "F"))900 (emit-invokevirtual +lisp-object+ "floatValue" nil :float)) 947 901 ((eq required-representation :double) 948 (emit-invokevirtual +lisp-object+ "doubleValue" nil "D"))902 (emit-invokevirtual +lisp-object+ "doubleValue" nil :double)) 949 903 (t (assert nil)))) 950 904 … … 1821 1775 (emit-push-nil) 1822 1776 (emit-push-t)) ;; we don't need the actual supplied-p symbol 1823 (emit-getstatic +lisp-closure+ "OPTIONAL" "I")1777 (emit-getstatic +lisp-closure+ "OPTIONAL" :int) 1824 1778 (emit-invokespecial-init +lisp-closure-parameter+ 1825 1779 (list +lisp-symbol+ +lisp-object+ 1826 +lisp-object+ "I")))1780 +lisp-object+ :int))) 1827 1781 1828 1782 (parameters-to-array (param key key-params-register) … … 2025 1979 (emit-push-constant-int n) 2026 1980 (emit-invokestatic +lisp-fixnum+ "getInstance" 2027 '( "I") +lisp-fixnum+))1981 '(:int) +lisp-fixnum+)) 2028 1982 ((<= most-negative-java-long n most-positive-java-long) 2029 1983 (emit-push-constant-long n) 2030 1984 (emit-invokestatic +lisp-bignum+ "getInstance" 2031 '( "J") +lisp-integer+))1985 '(:long) +lisp-integer+)) 2032 1986 (t 2033 1987 (let* ((*print-base* 10) … … 2036 1990 (emit-push-constant-int 10) 2037 1991 (emit-invokestatic +lisp-bignum+ "getInstance" 2038 (list +java-string+ "I") +lisp-integer+)))))1992 (list +java-string+ :int) +lisp-integer+))))) 2039 1993 2040 1994 (defun serialize-character (c) 2041 1995 "Generates code to restore a serialized character." 2042 1996 (emit-push-constant-int (char-code c)) 2043 (emit-invokestatic +lisp-character+ "getInstance" '( "C")1997 (emit-invokestatic +lisp-character+ "getInstance" '(:char) 2044 1998 +lisp-character+)) 2045 1999 … … 2049 2003 (emit 'dup) 2050 2004 (emit 'ldc (pool-float s)) 2051 (emit-invokespecial-init +lisp-single-float+ '( "F")))2005 (emit-invokespecial-init +lisp-single-float+ '(:float))) 2052 2006 2053 2007 (defun serialize-double (d) … … 2056 2010 (emit 'dup) 2057 2011 (emit 'ldc2_w (pool-double d)) 2058 (emit-invokespecial-init +lisp-double-float+ '( "D")))2012 (emit-invokespecial-init +lisp-double-float+ '(:double))) 2059 2013 2060 2014 (defun serialize-string (string) … … 2091 2045 ((null (symbol-package symbol)) 2092 2046 (emit-push-constant-int (dump-uninterned-symbol-index symbol)) 2093 (emit-invokestatic +lisp-load+ "getUninternedSymbol" '( "I")2047 (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int) 2094 2048 +lisp-object+) 2095 2049 (emit 'checkcast +lisp-symbol+)) … … 2334 2288 ((integerp form) 2335 2289 (emit-load-externalized-object form) 2336 (emit-invokevirtual +lisp-object+ "intValue" nil "I"))2290 (emit-invokevirtual +lisp-object+ "intValue" nil :int)) 2337 2291 (t 2338 2292 (sys::%format t "compile-constant int representation~%") … … 2345 2299 ((integerp form) 2346 2300 (emit-load-externalized-object form) 2347 (emit-invokevirtual +lisp-object+ "longValue" nil "J"))2301 (emit-invokevirtual +lisp-object+ "longValue" nil :long)) 2348 2302 (t 2349 2303 (sys::%format t "compile-constant long representation~%") … … 2473 2427 (emit-invokevirtual +lisp-object+ 2474 2428 unboxed-method-name 2475 nil "Z"))2429 nil :boolean)) 2476 2430 ((NIL) 2477 2431 (emit-invokevirtual +lisp-object+ … … 2608 2562 2609 2563 (defun emit-ifne-for-eql (representation instruction-type) 2610 (emit-invokevirtual +lisp-object+ "eql" instruction-type "Z")2564 (emit-invokevirtual +lisp-object+ "eql" instruction-type :boolean) 2611 2565 (convert-representation :boolean representation)) 2612 2566 … … 2634 2588 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 2635 2589 arg2 'stack :int) 2636 (emit-ifne-for-eql representation '( "I")))2590 (emit-ifne-for-eql representation '(:int))) 2637 2591 ((fixnum-type-p type1) 2638 2592 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int 2639 2593 arg2 'stack nil) 2640 2594 (emit 'swap) 2641 (emit-ifne-for-eql representation '( "I")))2595 (emit-ifne-for-eql representation '(:int))) 2642 2596 ((eq type2 'CHARACTER) 2643 2597 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 2644 2598 arg2 'stack :char) 2645 (emit-ifne-for-eql representation '( "C")))2599 (emit-ifne-for-eql representation '(:char))) 2646 2600 ((eq type1 'CHARACTER) 2647 2601 (compile-forms-and-maybe-emit-clear-values arg1 'stack :char 2648 2602 arg2 'stack nil) 2649 2603 (emit 'swap) 2650 (emit-ifne-for-eql representation '( "C")))2604 (emit-ifne-for-eql representation '(:char))) 2651 2605 (t 2652 2606 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil … … 2655 2609 (:boolean 2656 2610 (emit-invokevirtual +lisp-object+ "eql" 2657 (lisp-object-arg-types 1) "Z"))2611 (lisp-object-arg-types 1) :boolean)) 2658 2612 ((NIL) 2659 2613 (emit-invokevirtual +lisp-object+ "EQL" … … 2671 2625 (compile-form arg2 'stack nil) 2672 2626 (emit-invokestatic +lisp+ "memq" 2673 (lisp-object-arg-types 2) "Z")2627 (lisp-object-arg-types 2) :boolean) 2674 2628 (emit-move-from-stack target representation))) 2675 2629 (t … … 2688 2642 (cond ((eq type1 'SYMBOL) ; FIXME 2689 2643 (emit-invokestatic +lisp+ "memq" 2690 (lisp-object-arg-types 2) "Z"))2644 (lisp-object-arg-types 2) :boolean)) 2691 2645 (t 2692 2646 (emit-invokestatic +lisp+ "memql" 2693 (lisp-object-arg-types 2) "Z")))2647 (lisp-object-arg-types 2) :boolean))) 2694 2648 (emit-move-from-stack target representation))) 2695 2649 (t … … 3003 2957 (emit-push-constant-int (length *closure-variables*)) ;; length 3004 2958 (emit-invokestatic +java-system+ "arraycopy" 3005 (list +java-object+ "I"3006 +java-object+ "I" "I") nil)2959 (list +java-object+ :int 2960 +java-object+ :int :int) nil) 3007 2961 (aload register))) ;; reload dest value 3008 2962 … … 3127 3081 (>= "isGreaterThanOrEqualTo") 3128 3082 (= "isEqualTo")) 3129 '( "I")3130 "Z")3083 '(:int) 3084 :boolean) 3131 3085 ;; Java boolean on stack here 3132 3086 (convert-representation :boolean representation) … … 3253 3207 (let ((arg (%cadr form))) 3254 3208 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 3255 (emit-invokevirtual +lisp-object+ java-predicate nil "Z")3209 (emit-invokevirtual +lisp-object+ java-predicate nil :boolean) 3256 3210 'ifeq))) 3257 3211 … … 3275 3229 (let ((arg (%cadr form))) 3276 3230 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 3277 (emit-invokevirtual +lisp-object+ "constantp" nil "Z")3231 (emit-invokevirtual +lisp-object+ "constantp" nil :boolean) 3278 3232 'ifeq))) 3279 3233 … … 3466 3420 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3467 3421 arg2 'stack :char) 3468 (emit-invokevirtual +lisp-object+ "eql" '( "C") "Z")3422 (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 3469 3423 'ifeq) 3470 3424 ((eq type1 'CHARACTER) … … 3472 3426 arg2 'stack nil) 3473 3427 (emit 'swap) 3474 (emit-invokevirtual +lisp-object+ "eql" '( "C") "Z")3428 (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 3475 3429 'ifeq) 3476 3430 ((fixnum-type-p type2) 3477 3431 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3478 3432 arg2 'stack :int) 3479 (emit-invokevirtual +lisp-object+ "eql" '( "I") "Z")3433 (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 3480 3434 'ifeq) 3481 3435 ((fixnum-type-p type1) … … 3483 3437 arg2 'stack nil) 3484 3438 (emit 'swap) 3485 (emit-invokevirtual +lisp-object+ "eql" '( "I") "Z")3439 (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 3486 3440 'ifeq) 3487 3441 (t … … 3489 3443 arg2 'stack nil) 3490 3444 (emit-invokevirtual +lisp-object+ "eql" 3491 (lisp-object-arg-types 1) "Z")3445 (lisp-object-arg-types 1) :boolean) 3492 3446 'ifeq))))) 3493 3447 … … 3505 3459 (emit-invokevirtual +lisp-object+ 3506 3460 translated-op 3507 '( "I") "Z"))3461 '(:int) :boolean)) 3508 3462 (t 3509 3463 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil … … 3511 3465 (emit-invokevirtual +lisp-object+ 3512 3466 translated-op 3513 (lisp-object-arg-types 1) "Z")))3467 (lisp-object-arg-types 1) :boolean))) 3514 3468 'ifeq))) 3515 3469 … … 3532 3486 arg2 'stack nil) 3533 3487 (emit-invokestatic +lisp+ "memq" 3534 (lisp-object-arg-types 2) "Z")3488 (lisp-object-arg-types 2) :boolean) 3535 3489 'ifeq))) 3536 3490 … … 3542 3496 arg2 'stack nil) 3543 3497 (emit-invokestatic +lisp+ "memql" 3544 (lisp-object-arg-types 2) "Z")3498 (lisp-object-arg-types 2) :boolean) 3545 3499 'ifeq))) 3546 3500 … … 3561 3515 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3562 3516 arg2 'stack :int) 3563 (emit-invokevirtual +lisp-object+ "isNotEqualTo" '( "I") "Z")3517 (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 3564 3518 'ifeq) 3565 3519 ((fixnum-type-p type1) … … 3569 3523 arg2 'stack nil) 3570 3524 (emit 'swap) 3571 (emit-invokevirtual +lisp-object+ "isNotEqualTo" '( "I") "Z")3525 (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 3572 3526 'ifeq) 3573 3527 (t … … 3575 3529 arg2 'stack nil) 3576 3530 (emit-invokevirtual +lisp-object+ "isNotEqualTo" 3577 (lisp-object-arg-types 1) "Z")3531 (lisp-object-arg-types 1) :boolean) 3578 3532 'ifeq))))) 3579 3533 … … 3618 3572 (>= "isGreaterThanOrEqualTo") 3619 3573 (= "isEqualTo")) 3620 '( "I") "Z")3574 '(:int) :boolean) 3621 3575 'ifeq) 3622 3576 ((fixnum-type-p type1) … … 3633 3587 (>= "isLessThanOrEqualTo") 3634 3588 (= "isEqualTo")) 3635 '( "I") "Z")3589 '(:int) :boolean) 3636 3590 'ifeq) 3637 3591 (t … … 3645 3599 (>= "isGreaterThanOrEqualTo") 3646 3600 (= "isEqualTo")) 3647 (lisp-object-arg-types 1) "Z")3601 (lisp-object-arg-types 1) :boolean) 3648 3602 'ifeq)))))) 3649 3603 … … 4022 3976 (emit-push-constant-int (length vars)) 4023 3977 (emit-invokevirtual +lisp-thread+ "getValues" 4024 (list +lisp-object+ "I") +lisp-object-array+)3978 (list +lisp-object+ :int) +lisp-object-array+) 4025 3979 ;; Values array is now on the stack at runtime. 4026 3980 (label LABEL2) … … 5157 5111 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5158 5112 arg2 'stack :int) 5159 (emit-invokevirtual +lisp-object+ "ash" '( "I") +lisp-object+)5113 (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+) 5160 5114 (fix-boxing representation result-type))) 5161 5115 (emit-move-from-stack target representation)) … … 5221 5175 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5222 5176 arg2 'stack :int) 5223 (emit-invokevirtual +lisp-object+ "LOGAND" '( "I") +lisp-object+)5177 (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) 5224 5178 (fix-boxing representation result-type) 5225 5179 (emit-move-from-stack target representation)) … … 5230 5184 ;; swap args 5231 5185 (emit 'swap) 5232 (emit-invokevirtual +lisp-object+ "LOGAND" '( "I") +lisp-object+)5186 (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) 5233 5187 (fix-boxing representation result-type) 5234 5188 (emit-move-from-stack target representation)) … … 5293 5247 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5294 5248 arg2 'stack :int) 5295 (emit-invokevirtual +lisp-object+ "LOGIOR" '( "I") +lisp-object+)5249 (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) 5296 5250 (fix-boxing representation result-type) 5297 5251 (emit-move-from-stack target representation)) … … 5302 5256 ;; swap args 5303 5257 (emit 'swap) 5304 (emit-invokevirtual +lisp-object+ "LOGIOR" '( "I") +lisp-object+)5258 (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) 5305 5259 (fix-boxing representation result-type) 5306 5260 (emit-move-from-stack target representation)) … … 5357 5311 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5358 5312 arg2 'stack :int) 5359 (emit-invokevirtual +lisp-object+ "LOGXOR" '( "I") +lisp-object+)5313 (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+) 5360 5314 (fix-boxing representation result-type)) 5361 5315 (t … … 5441 5395 (emit-push-constant-int size) 5442 5396 (emit-push-constant-int position) 5443 (emit-invokevirtual +lisp-object+ "LDB" '( "I" "I") +lisp-object+)5397 (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) 5444 5398 (fix-boxing representation nil) 5445 5399 (emit-move-from-stack target representation)))) … … 5451 5405 (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved 5452 5406 (emit 'pop) 5453 (emit-invokevirtual +lisp-object+ "LDB" '( "I" "I") +lisp-object+)5407 (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) 5454 5408 (fix-boxing representation nil) 5455 5409 (emit-move-from-stack target representation)) … … 5470 5424 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int 5471 5425 arg2 'stack :int) 5472 (emit-invokestatic +lisp+ "mod" '( "I" "I") "I")5426 (emit-invokestatic +lisp+ "mod" '(:int :int) :int) 5473 5427 (emit-move-from-stack target representation)) 5474 5428 ((fixnum-type-p type2) 5475 5429 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5476 5430 arg2 'stack :int) 5477 (emit-invokevirtual +lisp-object+ "MOD" '( "I") +lisp-object+)5431 (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) 5478 5432 (fix-boxing representation nil) ; FIXME use derived result type 5479 5433 (emit-move-from-stack target representation)) … … 5550 5504 (emit-push-constant-int 1) ; errorp 5551 5505 (emit-invokestatic +lisp-class+ "findClass" 5552 (list +lisp-object+ "Z") +lisp-object+)5506 (list +lisp-object+ :boolean) +lisp-object+) 5553 5507 (fix-boxing representation nil) 5554 5508 (emit-move-from-stack target representation)) … … 5558 5512 arg2 'stack :boolean) 5559 5513 (emit-invokestatic +lisp-class+ "findClass" 5560 (list +lisp-object+ "Z") +lisp-object+)5514 (list +lisp-object+ :boolean) +lisp-object+) 5561 5515 (fix-boxing representation nil) 5562 5516 (emit-move-from-stack target representation))) … … 5633 5587 (emit 'dup) 5634 5588 (compile-forms-and-maybe-emit-clear-values arg 'stack :int) 5635 (emit-invokespecial-init +lisp-simple-vector+ '( "I"))5589 (emit-invokespecial-init +lisp-simple-vector+ '(:int)) 5636 5590 (emit-move-from-stack target representation))) 5637 5591 (t … … 5662 5616 (emit 'dup) 5663 5617 (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) 5664 (emit-invokespecial-init class '( "I"))5618 (emit-invokespecial-init class '(:int)) 5665 5619 (emit-move-from-stack target representation) 5666 5620 (return-from p2-make-sequence))))) … … 5677 5631 (emit 'dup) 5678 5632 (compile-forms-and-maybe-emit-clear-values arg 'stack :int) 5679 (emit-invokespecial-init +lisp-simple-string+ '( "I"))5633 (emit-invokespecial-init +lisp-simple-string+ '(:int)) 5680 5634 (emit-move-from-stack target representation))) 5681 5635 (t … … 5757 5711 (maybe-emit-clear-values arg1 arg2) 5758 5712 (emit 'swap) 5759 (emit-invokevirtual +lisp-stream+ "_writeByte" '( "I") nil)5713 (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil) 5760 5714 (when target 5761 5715 (emit-push-nil) … … 5766 5720 (maybe-emit-clear-values arg1 arg2) 5767 5721 (emit-invokestatic +lisp+ "writeByte" 5768 (list "I"+lisp-object+) nil)5722 (list :int +lisp-object+) nil) 5769 5723 (when target 5770 5724 (emit-push-nil) … … 5786 5740 (emit-push-nil) 5787 5741 (emit-invokevirtual +lisp-stream+ "readLine" 5788 (list "Z"+lisp-object+) +lisp-object+)5742 (list :boolean +lisp-object+) +lisp-object+) 5789 5743 (emit-move-from-stack target)) 5790 5744 (t … … 5800 5754 (emit-push-nil) 5801 5755 (emit-invokevirtual +lisp-stream+ "readLine" 5802 (list "Z"+lisp-object+) +lisp-object+)5756 (list :boolean +lisp-object+) +lisp-object+) 5803 5757 (emit-move-from-stack target) 5804 5758 ) … … 6363 6317 (ecase representation 6364 6318 (:int 6365 (emit-invokevirtual +lisp-object+ "length" nil "I"))6319 (emit-invokevirtual +lisp-object+ "length" nil :int)) 6366 6320 ((:long :float :double) 6367 (emit-invokevirtual +lisp-object+ "length" nil "I")6321 (emit-invokevirtual +lisp-object+ "length" nil :int) 6368 6322 (convert-representation :int representation)) 6369 6323 (:boolean 6370 6324 ;; FIXME We could optimize this all away in unsafe calls. 6371 (emit-invokevirtual +lisp-object+ "length" nil "I")6325 (emit-invokevirtual +lisp-object+ "length" nil :int) 6372 6326 (emit 'pop) 6373 6327 (emit 'iconst_1)) … … 6426 6380 list-form 'stack nil) 6427 6381 (emit 'swap) 6428 (emit-invokevirtual +lisp-object+ "NTH" '( "I") +lisp-object+)6382 (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+) 6429 6383 (fix-boxing representation nil) ; FIXME use derived result type 6430 6384 (emit-move-from-stack target representation))) … … 6465 6419 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 6466 6420 (emit-push-int arg2) 6467 (emit-invokevirtual +lisp-object+ "multiplyBy" '( "I") +lisp-object+)6421 (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+) 6468 6422 (fix-boxing representation result-type) 6469 6423 (emit-move-from-stack target representation)) … … 6519 6473 "isLessThanOrEqualTo" 6520 6474 "isGreaterThanOrEqualTo") 6521 (lisp-object-arg-types 1) "Z")6475 (lisp-object-arg-types 1) :boolean) 6522 6476 (let ((LABEL1 (gensym))) 6523 6477 (emit 'ifeq LABEL1) … … 6584 6538 (emit 'swap)) 6585 6539 (emit-invokevirtual +lisp-object+ "add" 6586 '( "I") +lisp-object+)6540 '(:int) +lisp-object+) 6587 6541 (fix-boxing representation result-type) 6588 6542 (emit-move-from-stack target representation)) … … 6656 6610 (emit-invokevirtual +lisp-object+ 6657 6611 "subtract" 6658 '( "I") +lisp-object+)6612 '(:int) +lisp-object+) 6659 6613 (fix-boxing representation result-type) 6660 6614 (emit-move-from-stack target representation)) … … 6682 6636 (maybe-emit-clear-values arg1 arg2) 6683 6637 (emit-invokevirtual +lisp-abstract-string+ "charAt" 6684 '( "I") "C")6638 '(:int) :char) 6685 6639 (emit-move-from-stack target representation)) 6686 6640 ((and (eq representation :char) … … 6693 6647 (maybe-emit-clear-values arg1 arg2) 6694 6648 (emit-invokevirtual +lisp-abstract-string+ "charAt" 6695 '( "I") "C")6649 '(:int) :char) 6696 6650 (emit-move-from-stack target representation)) 6697 6651 ((fixnum-type-p type2) … … 6700 6654 (emit-invokevirtual +lisp-object+ 6701 6655 (symbol-name op) ;; "CHAR" or "SCHAR" 6702 '( "I") +lisp-object+)6656 '(:int) +lisp-object+) 6703 6657 (when (eq representation :char) 6704 6658 (emit-unbox-character)) … … 6737 6691 (emit-move-from-stack value-register :char)) 6738 6692 (maybe-emit-clear-values arg1 arg2 arg3) 6739 (emit-invokevirtual class "setCharAt" '( "I" "C") nil)6693 (emit-invokevirtual class "setCharAt" '(:int :char) nil) 6740 6694 (when target 6741 6695 (emit 'iload value-register) … … 6753 6707 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 6754 6708 arg2 'stack :int) 6755 (emit-invokevirtual +lisp-object+ "SVREF" '( "I") +lisp-object+)6709 (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+) 6756 6710 (fix-boxing representation nil) 6757 6711 (emit-move-from-stack target representation))) … … 6773 6727 (emit-move-from-stack value-register nil)) 6774 6728 (maybe-emit-clear-values arg1 arg2 arg3) 6775 (emit-invokevirtual +lisp-object+ "svset" (list "I"+lisp-object+) nil)6729 (emit-invokevirtual +lisp-object+ "svset" (list :int +lisp-object+) nil) 6776 6730 (when value-register 6777 6731 (aload value-register) … … 6808 6762 (compile-form (second form) 'stack nil) 6809 6763 (compile-form (third form) 'stack :int) 6810 (emit-invokevirtual +lisp-object+ "elt" '( "I") +lisp-object+)6764 (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+) 6811 6765 (fix-boxing representation nil) ; FIXME use derived result type 6812 6766 (emit-move-from-stack target representation)) … … 6825 6779 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 6826 6780 arg2 'stack :int) 6827 (emit-invokevirtual +lisp-object+ "aref" '( "I") "I"))6781 (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) 6828 6782 (:long 6829 6783 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 6830 6784 arg2 'stack :int) 6831 (emit-invokevirtual +lisp-object+ "aref_long" '( "I") "J"))6785 (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) 6832 6786 (:char 6833 6787 (cond ((compiler-subtypep type1 'string) … … 6837 6791 (maybe-emit-clear-values arg1 arg2) 6838 6792 (emit-invokevirtual +lisp-abstract-string+ 6839 "charAt" '( "I") "C"))6793 "charAt" '(:int) :char)) 6840 6794 (t 6841 6795 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 6842 6796 arg2 'stack :int) 6843 (emit-invokevirtual +lisp-object+ "AREF" '( "I") +lisp-object+)6797 (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) 6844 6798 (emit-unbox-character)))) 6845 6799 ((nil :float :double :boolean) … … 6848 6802 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 6849 6803 arg2 'stack :int) 6850 (emit-invokevirtual +lisp-object+ "AREF" '( "I") +lisp-object+)6804 (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) 6851 6805 (convert-representation nil representation))) 6852 6806 (emit-move-from-stack target representation))) … … 6881 6835 (maybe-emit-clear-values arg1 arg2 arg3) 6882 6836 (cond ((fixnum-type-p type3) 6883 (emit-invokevirtual +lisp-object+ "aset" '( "I" "I") nil))6837 (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil)) 6884 6838 (t 6885 (emit-invokevirtual +lisp-object+ "aset" (list "I"+lisp-object+) nil)))6839 (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil))) 6886 6840 (when value-register 6887 6841 (cond ((fixnum-type-p type3) … … 6920 6874 (emit-push-constant-int arg2) 6921 6875 (emit-invokevirtual +lisp-object+ "getSlotValue" 6922 '( "I") +lisp-object+)))6876 '(:int) +lisp-object+))) 6923 6877 (emit-move-from-stack target representation)) 6924 6878 ((fixnump arg2) … … 6928 6882 (:int 6929 6883 (emit-invokevirtual +lisp-object+ "getFixnumSlotValue" 6930 '( "I") "I"))6884 '(:int) :int)) 6931 6885 ((nil :char :long :float :double) 6932 6886 (emit-invokevirtual +lisp-object+ "getSlotValue" 6933 '( "I") +lisp-object+)6887 '(:int) +lisp-object+) 6934 6888 ;; (convert-representation NIL NIL) is a no-op 6935 6889 (convert-representation nil representation)) 6936 6890 (:boolean 6937 6891 (emit-invokevirtual +lisp-object+ "getSlotValueAsBoolean" 6938 '( "I") "Z")))6892 '(:int) :boolean))) 6939 6893 (emit-move-from-stack target representation)) 6940 6894 (t … … 6975 6929 (astore value-register)) 6976 6930 (emit-invokevirtual +lisp-object+ "setSlotValue" 6977 (list "I"+lisp-object+) nil)6931 (list :int +lisp-object+) nil) 6978 6932 (when value-register 6979 6933 (aload value-register) … … 7040 6994 arg2 'stack nil) 7041 6995 (emit 'swap) 7042 (emit-invokevirtual +lisp-object+ "nthcdr" '( "I") +lisp-object+)6996 (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+) 7043 6997 (fix-boxing representation nil) 7044 6998 (emit-move-from-stack target representation)) … … 7355 7309 (let ((arg (%cadr form))) 7356 7310 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 7357 (emit-invokevirtual +lisp-object+ "sxhash" nil "I")7311 (emit-invokevirtual +lisp-object+ "sxhash" nil :int) 7358 7312 (convert-representation :int representation) 7359 7313 (emit-move-from-stack target representation))) … … 7836 7790 (setf *hairy-arglist-p* t) 7837 7791 (return-from analyze-args 7838 ( get-descriptor (list +lisp-object-array+) +lisp-object+)))7792 (descriptor +lisp-object+ +lisp-object-array+))) 7839 7793 (return-from analyze-args 7840 7794 (cond ((<= arg-count call-registers-limit) 7841 (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+)) 7795 (apply #'descriptor +lisp-object+ 7796 (lisp-object-arg-types arg-count))) 7842 7797 (t (setf *using-arg-array* t) 7843 7798 (setf (compiland-arity compiland) arg-count) 7844 ( get-descriptor (list +lisp-object-array+) +lisp-object+)))))7799 (descriptor +lisp-object+ +lisp-object-array+))))) 7845 7800 (when (or (memq '&KEY args) 7846 7801 (memq '&OPTIONAL args) … … 7848 7803 (setf *using-arg-array* t) 7849 7804 (setf *hairy-arglist-p* t) 7850 (return-from analyze-args 7851 (get-descriptor (list +lisp-object-array+) +lisp-object+))) 7805 (return-from analyze-args (descriptor +lisp-object+ +lisp-object-array+))) 7852 7806 (cond ((<= arg-count call-registers-limit) 7853 ( get-descriptor (lisp-object-arg-types (length args))7854 +lisp-object+))7807 (apply #'descriptor +lisp-object+ 7808 (lisp-object-arg-types (length args)))) 7855 7809 (t 7856 7810 (setf *using-arg-array* t) 7857 7811 (setf (compiland-arity compiland) arg-count) 7858 ( get-descriptor (list +lisp-object-array+) +lisp-object+)))))7812 (descriptor +lisp-object+ +lisp-object-array+))))) 7859 7813 7860 7814 (defmacro with-open-class-file ((var class-file) &body body) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
r12853 r12856 214 214 "Returns a string describing the `return-type' and `argument-types' 215 215 in JVM-internal representation." 216 (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) 217 (internal-field-ref return-type))) 216 (let* ((arg-strings (mapcar #'internal-field-ref argument-types)) 217 (ret-string (internal-field-ref return-type)) 218 (size (+ 2 (reduce #'+ arg-strings 219 :key #'length 220 :initial-value (length ret-string)))) 221 (str (make-array size :fill-pointer 0 :element-type 'character))) 222 (with-output-to-string (s str) 223 (princ #\( s) 224 (dolist (arg-string arg-strings) 225 (princ arg-string s)) 226 (princ #\) s) 227 (princ ret-string s)) 228 str) 229 ;; (format nil "(~{~A~})~A" 230 ;; (internal-field-ref return-type)) 231 ) 232 233 (defun descriptor-stack-effect (return-type &rest argument-types) 234 "Returns the effect on the stack position of the `argument-types' and 235 `return-type' of a method call. 236 237 If the method consumes an implicit `this' argument, this function does not 238 take that effect into account." 239 (flet ((type-stack-effect (arg) 240 (case arg 241 ((:long :double) 2) 242 ((nil :void) 0) 243 (otherwise 1)))) 244 (+ (reduce #'- argument-types 245 :key #'type-stack-effect 246 :initial-value 0) 247 (type-stack-effect return-type)))) 218 248 219 249
Note: See TracChangeset
for help on using the changeset viewer.
