- Timestamp:
- 08/04/10 21:36:42 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12859 r12860 526 526 527 527 528 (defknown emit-new (t) t) 529 (declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof)) 530 (defun emit-new (class-name) 531 (apply #'%emit 'new (u2 (pool-class class-name)))) 532 533 (defknown emit-anewarray (t) t) 534 (defun emit-anewarray (class-name) 535 (apply #'%emit 'anewarray (u2 (pool-class class-name)))) 536 537 (defknown emit-checkcast (t) t) 538 (defun emit-checkcast (class-name) 539 (apply #'%emit 'checkcast (u2 (pool-class class-name)))) 540 541 (defknown emit-instanceof (t) t) 542 (defun emit-instanceof (class-name) 543 (apply #'%emit 'instanceof (u2 (pool-class class-name)))) 544 528 545 529 546 (defvar type-representations '((:int fixnum) … … 559 576 (defknown emit-unbox-boolean () t) 560 577 (defun emit-unbox-boolean () 561 (emit 'instanceof +lisp-nil+)578 (emit-instanceof +lisp-nil+) 562 579 (emit 'iconst_1) 563 580 (emit 'ixor)) ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit … … 569 586 (lisp-object-arg-types 1) :char)) 570 587 (t 571 (emit 'checkcast +lisp-character+)588 (emit-checkcast +lisp-character+) 572 589 (emit-getfield +lisp-character+ "value" :char)))) 573 590 … … 714 731 (LABEL1 (gensym))) 715 732 (emit-load-local-variable variable) 716 (emit 'instanceof instanceof-class)733 (emit-instanceof instanceof-class) 717 734 (emit 'ifne LABEL1) 718 735 (emit-load-local-variable variable) … … 858 875 (lisp-object-arg-types 1) :int)) 859 876 (t 860 (emit 'checkcast +lisp-fixnum+)877 (emit-checkcast +lisp-fixnum+) 861 878 (emit-getfield +lisp-fixnum+ "value" :int)))) 862 879 … … 873 890 (lisp-object-arg-types 1) :float)) 874 891 (t 875 (emit 'checkcast +lisp-single-float+)892 (emit-checkcast +lisp-single-float+) 876 893 (emit-getfield +lisp-single-float+ "value" :float)))) 877 894 … … 883 900 (lisp-object-arg-types 1) :double)) 884 901 (t 885 (emit 'checkcast +lisp-double-float+)902 (emit-checkcast +lisp-double-float+) 886 903 (emit-getfield +lisp-double-float+ "value" :double)))) 887 904 … … 894 911 (cond ((and (fixnum-type-p derived-type) 895 912 (< *safety* 3)) 896 (emit 'checkcast +lisp-fixnum+)913 (emit-checkcast +lisp-fixnum+) 897 914 (emit-getfield +lisp-fixnum+ "value" :int)) 898 915 (t … … 1184 1201 ;; new, anewarray, checkcast, instanceof class-name 1185 1202 (define-resolver (187 189 192 193) (instruction) 1186 (let* ((args (instruction-args instruction)) 1187 (index (pool-class (first args)))) 1188 (inst (instruction-opcode instruction) (u2 index)))) 1203 ;; we used to create the pool-class here; that moved to the emit-* layer 1204 instruction) 1189 1205 1190 1206 ;; iinc … … 1755 1771 `(progn 1756 1772 (emit-push-constant-int (length ,params)) 1757 (emit 'anewarray +lisp-closure-parameter+)1773 (emit-anewarray +lisp-closure-parameter+) 1758 1774 (astore (setf ,register (method-max-locals constructor))) 1759 1775 (incf (method-max-locals constructor)) … … 1765 1781 (aload ,register) 1766 1782 (emit-push-constant-int ,count-sym) 1767 (emit 'new +lisp-closure-parameter+)1783 (emit-new +lisp-closure-parameter+) 1768 1784 (emit 'dup) 1769 1785 ,@body … … 2006 2022 (defun serialize-float (s) 2007 2023 "Generates code to restore a serialized single-float." 2008 (emit 'new +lisp-single-float+)2024 (emit-new +lisp-single-float+) 2009 2025 (emit 'dup) 2010 2026 (emit 'ldc (pool-float s)) … … 2013 2029 (defun serialize-double (d) 2014 2030 "Generates code to restore a serialized double-float." 2015 (emit 'new +lisp-double-float+)2031 (emit-new +lisp-double-float+) 2016 2032 (emit 'dup) 2017 2033 (emit 'ldc2_w (pool-double d)) … … 2020 2036 (defun serialize-string (string) 2021 2037 "Generate code to restore a serialized string." 2022 (emit 'new +lisp-simple-string+)2038 (emit-new +lisp-simple-string+) 2023 2039 (emit 'dup) 2024 2040 (emit 'ldc (pool-string string)) … … 2053 2069 (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int) 2054 2070 +lisp-object+) 2055 (emit 'checkcast +lisp-symbol+))2071 (emit-checkcast +lisp-symbol+)) 2056 2072 ((keywordp symbol) 2057 2073 (emit 'ldc (pool-string (symbol-name symbol))) … … 2112 2128 (emit-getstatic *this-class* (cdr existing) field-type) 2113 2129 (when cast 2114 (emit 'checkcast cast))2130 (emit-checkcast cast)) 2115 2131 (return-from emit-load-externalized-object field-type))) 2116 2132 … … 2128 2144 (list +java-string+) +lisp-object+) 2129 2145 (when (not (eq field-type +lisp-object+)) 2130 (emit 'checkcast field-type))2146 (emit-checkcast field-type)) 2131 2147 (emit-putstatic *this-class* field-name field-type) 2132 2148 (setf *static-code* *code*))) … … 2142 2158 (emit-getstatic *this-class* field-name field-type) 2143 2159 (when cast 2144 (emit 'checkcast cast))2160 (emit-checkcast cast)) 2145 2161 field-type))) 2146 2162 … … 2173 2189 (progn ;; generated by the DECLARE-OBJECT*'s above 2174 2190 (emit-getstatic class name +lisp-object+) 2175 (emit 'checkcast +lisp-symbol+))2191 (emit-checkcast +lisp-symbol+)) 2176 2192 (emit-getstatic class name +lisp-symbol+)) 2177 2193 (emit-invokevirtual +lisp-symbol+ … … 2208 2224 ;; fixme *declare-inline* 2209 2225 (declare-field g +lisp-object+ +field-access-private+) 2210 (emit 'new class-name)2226 (emit-new class-name) 2211 2227 (emit 'dup) 2212 2228 (emit-invokespecial-init class-name '()) … … 2717 2733 (ht-form (%caddr form))) 2718 2734 (compile-form ht-form 'stack nil) 2719 (emit 'checkcast +lisp-hash-table+)2735 (emit-checkcast +lisp-hash-table+) 2720 2736 (compile-form key-form 'stack nil) 2721 2737 (maybe-emit-clear-values ht-form key-form) … … 2735 2751 (value-form (fourth form))) 2736 2752 (compile-form ht-form 'stack nil) 2737 (emit 'checkcast +lisp-hash-table+)2753 (emit-checkcast +lisp-hash-table+) 2738 2754 (compile-form key-form 'stack nil) 2739 2755 (compile-form value-form 'stack nil) … … 2782 2798 (t 2783 2799 (emit-push-constant-int numargs) 2784 (emit 'anewarray +lisp-object+)2800 (emit-anewarray +lisp-object+) 2785 2801 (let ((i 0)) 2786 2802 (dolist (arg args) … … 2957 2973 (emit-push-constant-int 0) ;; srcPos 2958 2974 (emit-push-constant-int (length *closure-variables*)) 2959 (emit 'anewarray +lisp-closure-binding+) ;; dest2975 (emit-anewarray +lisp-closure-binding+) ;; dest 2960 2976 (emit 'dup) 2961 2977 (astore register) ;; save dest value … … 3006 3022 ; Stack: template-function 3007 3023 (when *closure-variables* 3008 (emit 'checkcast +lisp-compiled-closure+)3024 (emit-checkcast +lisp-compiled-closure+) 3009 3025 (duplicate-closure-array compiland) 3010 3026 (emit-invokestatic +lisp+ "makeCompiledClosure" … … 3221 3237 (let ((arg (%cadr form))) 3222 3238 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 3223 (emit 'instanceof java-class)3239 (emit-instanceof java-class) 3224 3240 'ifeq))) 3225 3241 … … 3836 3852 (defun emit-new-closure-binding (variable) 3837 3853 "" 3838 (emit 'new +lisp-closure-binding+) ;; value c-b3854 (emit-new +lisp-closure-binding+) ;; value c-b 3839 3855 (emit 'dup_x1) ;; c-b value c-b 3840 3856 (emit 'swap) ;; c-b c-b value … … 4394 4410 ;; we have a block variable; that should be a closure variable 4395 4411 (assert (not (null (variable-closure-index (tagbody-id-variable block))))) 4396 (emit 'new +lisp-object+)4412 (emit-new +lisp-object+) 4397 4413 (emit 'dup) 4398 4414 (emit-invokespecial-init +lisp-object+ '()) … … 4501 4517 (check-arg-count form 1)) 4502 4518 (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) 4503 (emit 'instanceof +lisp-cons+)4519 (emit-instanceof +lisp-cons+) 4504 4520 (let ((LABEL1 (gensym)) 4505 4521 (LABEL2 (gensym))) … … 4530 4546 (t 4531 4547 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 4532 (emit 'instanceof java-class)4548 (emit-instanceof java-class) 4533 4549 (convert-representation :boolean representation) 4534 4550 (emit-move-from-stack target representation))))) … … 4584 4600 ;; we have a block variable; that should be a closure variable 4585 4601 (assert (not (null (variable-closure-index (block-id-variable block))))) 4586 (emit 'new +lisp-object+)4602 (emit-new +lisp-object+) 4587 4603 (emit 'dup) 4588 4604 (emit-invokespecial-init +lisp-object+ '()) … … 4680 4696 (define-inlined-function p2-cons (form target representation) 4681 4697 ((check-arg-count form 2)) 4682 (emit 'new +lisp-cons+)4698 (emit-new +lisp-cons+) 4683 4699 (emit 'dup) 4684 4700 (let* ((args (%cdr form)) … … 4841 4857 (dformat t "(compiland-closure-register parent) = ~S~%" 4842 4858 (compiland-closure-register parent)) 4843 (emit 'checkcast +lisp-compiled-closure+)4859 (emit-checkcast +lisp-compiled-closure+) 4844 4860 (duplicate-closure-array parent) 4845 4861 (emit-invokestatic +lisp+ "makeCompiledClosure" … … 4971 4987 4972 4988 (when (compiland-closure-register *current-compiland*) 4973 (emit 'checkcast +lisp-compiled-closure+)4989 (emit-checkcast +lisp-compiled-closure+) 4974 4990 (duplicate-closure-array *current-compiland*) 4975 4991 (emit-invokestatic +lisp+ "makeCompiledClosure" … … 5590 5606 (null representation)) 5591 5607 (let ((arg (second form))) 5592 (emit 'new +lisp-simple-vector+)5608 (emit-new +lisp-simple-vector+) 5593 5609 (emit 'dup) 5594 5610 (compile-forms-and-maybe-emit-clear-values arg 'stack :int) … … 5619 5635 (setf class +lisp-simple-vector+))))) 5620 5636 (when class 5621 (emit 'new class)5637 (emit-new class) 5622 5638 (emit 'dup) 5623 5639 (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) … … 5634 5650 (null representation)) 5635 5651 (let ((arg (second form))) 5636 (emit 'new +lisp-simple-string+)5652 (emit-new +lisp-simple-string+) 5637 5653 (emit 'dup) 5638 5654 (compile-forms-and-maybe-emit-clear-values arg 'stack :int) … … 5645 5661 (cond ((and (check-arg-count form 2) 5646 5662 (eq (derive-type (%cadr form)) 'SYMBOL)) 5647 (emit 'new +lisp-structure-object+)5663 (emit-new +lisp-structure-object+) 5648 5664 (emit 'dup) 5649 5665 (compile-form (%cadr form) 'stack nil) 5650 (emit 'checkcast +lisp-symbol+)5666 (emit-checkcast +lisp-symbol+) 5651 5667 (compile-form (%caddr form) 'stack nil) 5652 5668 (maybe-emit-clear-values (%cadr form) (%caddr form)) … … 5665 5681 (cond ((and (<= 1 slot-count 6) 5666 5682 (eq (derive-type (%car args)) 'SYMBOL)) 5667 (emit 'new +lisp-structure-object+)5683 (emit-new +lisp-structure-object+) 5668 5684 (emit 'dup) 5669 5685 (compile-form (%car args) 'stack nil) 5670 (emit 'checkcast +lisp-symbol+)5686 (emit-checkcast +lisp-symbol+) 5671 5687 (dolist (slot-form slot-forms) 5672 5688 (compile-form slot-form 'stack nil)) … … 5681 5697 (defun p2-make-hash-table (form target representation) 5682 5698 (cond ((= (length form) 1) ; no args 5683 (emit 'new +lisp-eql-hash-table+)5699 (emit-new +lisp-eql-hash-table+) 5684 5700 (emit 'dup) 5685 5701 (emit-invokespecial-init +lisp-eql-hash-table+ nil) … … 5695 5711 (cond ((eq (derive-compiler-type arg) 'STREAM) 5696 5712 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 5697 (emit 'checkcast +lisp-stream+)5713 (emit-checkcast +lisp-stream+) 5698 5714 (emit-invokevirtual +lisp-stream+ "getElementType" 5699 5715 nil +lisp-object+) … … 5714 5730 (compile-form arg1 'stack :int) 5715 5731 (compile-form arg2 'stack nil) 5716 (emit 'checkcast +lisp-stream+)5732 (emit-checkcast +lisp-stream+) 5717 5733 (maybe-emit-clear-values arg1 arg2) 5718 5734 (emit 'swap) … … 5742 5758 (cond ((compiler-subtypep type1 'stream) 5743 5759 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 5744 (emit 'checkcast +lisp-stream+)5760 (emit-checkcast +lisp-stream+) 5745 5761 (emit-push-constant-int 1) 5746 5762 (emit-push-nil) … … 5756 5772 (cond ((and (compiler-subtypep type1 'stream) (null arg2)) 5757 5773 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 5758 (emit 'checkcast +lisp-stream+)5774 (emit-checkcast +lisp-stream+) 5759 5775 (emit-push-constant-int 0) 5760 5776 (emit-push-nil) … … 6305 6321 (compile-form arg1 'stack nil) 6306 6322 (compile-form arg2 'stack nil) 6307 (emit 'checkcast +lisp-abstract-vector+)6323 (emit-checkcast +lisp-abstract-vector+) 6308 6324 (maybe-emit-clear-values arg1 arg2) 6309 6325 (emit 'swap) … … 6347 6363 (cond ((>= 4 length 1) 6348 6364 (dolist (cons-head cons-heads) 6349 (emit 'new +lisp-cons+)6365 (emit-new +lisp-cons+) 6350 6366 (emit 'dup) 6351 6367 (compile-form cons-head 'stack nil)) … … 6638 6654 (zerop *safety*)) 6639 6655 (compile-form arg1 'stack nil) 6640 (emit 'checkcast +lisp-abstract-string+)6656 (emit-checkcast +lisp-abstract-string+) 6641 6657 (compile-form arg2 'stack :int) 6642 6658 (maybe-emit-clear-values arg1 arg2) … … 6649 6665 (fixnum-type-p type2)) 6650 6666 (compile-form arg1 'stack nil) 6651 (emit 'checkcast +lisp-abstract-string+)6667 (emit-checkcast +lisp-abstract-string+) 6652 6668 (compile-form arg2 'stack :int) 6653 6669 (maybe-emit-clear-values arg1 arg2) … … 6690 6706 +lisp-abstract-string+))) 6691 6707 (compile-form arg1 'stack nil) 6692 (emit 'checkcast class)6708 (emit-checkcast class) 6693 6709 (compile-form arg2 'stack :int) 6694 6710 (compile-form arg3 'stack :char) … … 6793 6809 (cond ((compiler-subtypep type1 'string) 6794 6810 (compile-form arg1 'stack nil) ; array 6795 (emit 'checkcast +lisp-abstract-string+)6811 (emit-checkcast +lisp-abstract-string+) 6796 6812 (compile-form arg2 'stack :int) ; index 6797 6813 (maybe-emit-clear-values arg1 arg2) … … 7175 7191 (emit-push-current-thread) 7176 7192 (compile-form (%cadr form) 'stack nil) 7177 (emit 'checkcast +lisp-symbol+)7193 (emit-checkcast +lisp-symbol+) 7178 7194 (compile-form (%caddr form) 'stack nil) 7179 7195 (maybe-emit-clear-values (%cadr form) (%caddr form)) … … 7327 7343 (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) 7328 7344 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 7329 (emit 'checkcast +lisp-symbol+)7345 (emit-checkcast +lisp-symbol+) 7330 7346 (emit-getfield +lisp-symbol+ "name" +lisp-simple-string+) 7331 7347 (emit-move-from-stack target representation)) … … 7339 7355 (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) 7340 7356 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 7341 (emit 'checkcast +lisp-symbol+)7357 (emit-checkcast +lisp-symbol+) 7342 7358 (emit-invokevirtual +lisp-symbol+ "getPackage" 7343 7359 nil +lisp-object+) … … 7353 7369 (when (eq (derive-compiler-type arg) 'SYMBOL) 7354 7370 (compile-forms-and-maybe-emit-clear-values arg 'stack nil) 7355 (emit 'checkcast +lisp-symbol+)7371 (emit-checkcast +lisp-symbol+) 7356 7372 (emit-push-current-thread) 7357 7373 (emit-invokevirtual +lisp-symbol+ "symbolValue" … … 7382 7398 (LABEL1 (gensym))) 7383 7399 (emit 'dup) 7384 (emit 'instanceof instanceof-class)7400 (emit-instanceof instanceof-class) 7385 7401 (emit 'ifne LABEL1) 7386 7402 (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) … … 7981 7997 ;; if we're the ultimate parent: create the closure array 7982 7998 (emit-push-constant-int (length *closure-variables*)) 7983 (emit 'anewarray +lisp-closure-binding+))7999 (emit-anewarray +lisp-closure-binding+)) 7984 8000 (progn 7985 8001 (aload 0) … … 8008 8024 (emit 'dup) ; array 8009 8025 (emit-push-constant-int i) 8010 (emit 'new +lisp-closure-binding+)8026 (emit-new +lisp-closure-binding+) 8011 8027 (emit 'dup) 8012 8028 (cond
Note: See TracChangeset
for help on using the changeset viewer.
