Changeset 13160
- Timestamp:
- 01/20/11 12:20:29 (13 years ago)
- Location:
- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r13159 r13160 1153 1153 (defvar *pass2-unsafe-p-special-treatment-functions* 1154 1154 '( 1155 coerce-to-function1156 cons1157 sys::backq-cons1158 find-class1159 list1160 sys::backq-list1161 list*1162 sys::backq-list*1163 load-time-value1164 1155 logand 1165 1156 logior 1166 1157 lognot 1167 1158 logxor 1168 max1169 min1170 mod1171 stream-element-type1172 truncate1173 1159 ) 1174 1160 "The functions named in the list bound to this variable -
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r13159 r13160 761 761 (emit-move-from-stack register (variable-representation variable))))))) 762 762 763 (defun emit-register-operand (register representation) 764 (push representation *operand-representations*) 765 (cond (*saved-operands* 766 (push register *saved-operands*)) 767 (t 768 (emit-push-register register representation)))) 769 763 770 (defun emit-thread-operand () 764 (push nil *operand-representations*) 765 (emit-push-current-thread) 766 (when *saved-operands* 767 (let ((register (allocate-register nil))) 768 (push register *saved-operands*) 769 (emit 'astore register)))) 771 (ensure-thread-var-initialized) 772 (emit-register-operand *thread* nil)) 770 773 771 774 (defun emit-load-externalized-object-operand (object) … … 3956 3959 (define-inlined-function p2-cons (form target representation) 3957 3960 ((check-arg-count form 2)) 3958 (emit-new +lisp-cons+)3959 (emit 'dup)3960 3961 (let* ((args (%cdr form)) 3961 3962 (arg1 (%car args)) 3962 (arg2 (%cadr args))) 3963 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 3964 arg2 'stack nil)) 3965 (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) 3966 (emit-move-from-stack target)) 3963 (arg2 (%cadr args)) 3964 (cons-register (when (some-nested-block #'node-opstack-unsafe-p 3965 (find-enclosed-blocks args)) 3966 (allocate-register nil)))) 3967 (emit-new +lisp-cons+) 3968 (if cons-register 3969 (astore cons-register) 3970 (emit 'dup)) 3971 (with-operand-accumulation 3972 ((when cons-register 3973 (emit-register-operand cons-register nil)) 3974 (compile-operand arg1 nil) 3975 (compile-operand arg2 nil) 3976 (maybe-emit-clear-values arg1 arg2))) 3977 (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) 3978 (when cons-register 3979 (emit-push-register cons-register nil)) 3980 (emit-move-from-stack target))) 3967 3981 3968 3982 (defun compile-progn (form target representation) … … 4712 4726 (fixnum-type-p type1) 4713 4727 (fixnum-type-p type2)) 4714 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int 4715 arg2 'stack :int) 4728 (with-operand-accumulation 4729 ((compile-operand arg1 :int) 4730 (compile-operand arg2 :int) 4731 (maybe-emit-clear-values arg1 arg2))) 4716 4732 (emit-invokestatic +lisp+ "mod" '(:int :int) :int) 4717 4733 (emit-move-from-stack target representation)) 4718 4734 ((fixnum-type-p type2) 4719 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 4720 arg2 'stack :int) 4735 (with-operand-accumulation 4736 ((compile-operand arg1 nil) 4737 (compile-operand arg2 :int) 4738 (maybe-emit-clear-values arg1 arg2))) 4721 4739 (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) 4722 4740 (fix-boxing representation nil) ; FIXME use derived result type 4723 4741 (emit-move-from-stack target representation)) 4724 4742 (t 4725 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 4726 arg2 'stack nil) 4743 (with-operand-accumulation 4744 ((compile-operand arg1 nil) 4745 (compile-operand arg2 nil) 4746 (maybe-emit-clear-values arg1 arg2))) 4727 4747 (emit-invokevirtual +lisp-object+ "MOD" 4728 4748 (lisp-object-arg-types 1) +lisp-object+) … … 4799 4819 (2 4800 4820 (let ((arg2 (second args))) 4801 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 4802 arg2 'stack :boolean) 4821 (with-operand-accumulation 4822 ((compile-operand arg1 nil) 4823 (compile-operand arg2 :boolean) 4824 (maybe-emit-clear-values arg1 arg2))) 4803 4825 (emit-invokestatic +lisp-class+ "findClass" 4804 4826 (list +lisp-object+ :boolean) +lisp-object+) … … 5529 5551 (butlast args 1) 5530 5552 args))) 5531 (cond ((>= 4 length 1) 5553 (cond ((and (not (some-nested-block #'node-opstack-unsafe-p 5554 (find-enclosed-blocks args))) 5555 (>= 4 length 1)) 5532 5556 (dolist (cons-head cons-heads) 5533 5557 (emit-new +lisp-cons+) … … 5629 5653 (args (%cdr form)) 5630 5654 (arg1 (%car args)) 5631 (arg2 (%cadr args))) 5655 (arg2 (%cadr args)) 5656 (*register* *register*)) 5632 5657 (when (null target) 5658 ;; compile for effect 5633 5659 (compile-forms-and-maybe-emit-clear-values arg1 nil nil 5634 5660 arg2 nil nil) … … 5640 5666 (type2 (derive-compiler-type arg2))) 5641 5667 (cond ((and (java-long-type-p type1) (java-long-type-p type2)) 5642 (let ((common-rep (if (and (fixnum-type-p type1) 5643 (fixnum-type-p type2)) 5644 :int :long)) 5645 (LABEL1 (gensym))) 5646 (compile-form arg1 'stack common-rep) 5668 (let* ((common-rep (if (and (fixnum-type-p type1) 5669 (fixnum-type-p type2)) 5670 :int :long)) 5671 (LABEL1 (gensym)) 5672 (LABEL2 (gensym)) 5673 (arg1-register (allocate-register common-rep)) 5674 (arg2-register (allocate-register common-rep))) 5675 (compile-form arg1 arg1-register common-rep) 5676 (compile-form arg2 'stack common-rep) 5647 5677 (emit-dup common-rep) 5648 (compile-form arg2 'stack common-rep) 5649 (emit-dup common-rep :past common-rep) 5678 (emit-move-from-stack arg2-register common-rep) 5679 (emit-push-register arg1-register common-rep) 5680 ;; note: we've now reversed the arguments on the stack! 5650 5681 (emit-numeric-comparison (if (eq op 'max) '<= '>=) 5651 5682 common-rep LABEL1) 5652 (emit-swap common-rep common-rep) 5683 (emit-push-register arg1-register common-rep) 5684 (emit 'goto LABEL2) 5653 5685 (label LABEL1) 5654 (emit-move-from-stack nil common-rep) 5686 (emit-push-register arg2-register common-rep) 5687 (label LABEL2) 5655 5688 (convert-representation common-rep representation) 5656 5689 (emit-move-from-stack target representation))) 5657 5690 (t 5658 (compile-form arg1 'stack nil) 5659 (emit-dup nil) 5660 (compile-form arg2 'stack nil) 5661 (emit-dup nil :past nil) 5662 (emit-invokevirtual +lisp-object+ 5663 (if (eq op 'max) 5664 "isLessThanOrEqualTo" 5691 (let* ((arg1-register (allocate-register nil)) 5692 (arg2-register (allocate-register nil))) 5693 (compile-form arg1 arg1-register nil) 5694 (compile-form arg2 'stack nil) 5695 (emit-dup nil) 5696 (astore arg2-register) 5697 (emit-push-register arg1-register nil) 5698 (emit-invokevirtual +lisp-object+ 5699 (if (eq op 'max) 5700 "isLessThanOrEqualTo" 5665 5701 "isGreaterThanOrEqualTo") 5666 (lisp-object-arg-types 1) :boolean) 5667 (let ((LABEL1 (gensym))) 5668 (emit 'ifeq LABEL1) 5669 (emit 'swap) 5670 (label LABEL1) 5671 (emit 'pop)) 5672 (fix-boxing representation nil) 5673 (emit-move-from-stack target representation)))))) 5702 (lisp-object-arg-types 1) :boolean) 5703 (let ((LABEL1 (gensym)) 5704 (LABEL2 (gensym))) 5705 (emit 'ifeq LABEL1) 5706 (emit-push-register arg1-register nil) 5707 (emit 'goto LABEL2) 5708 (label LABEL1) 5709 (emit-push-register arg2-register nil) 5710 (label LABEL2)) 5711 (fix-boxing representation nil) 5712 (emit-move-from-stack target representation))))))) 5674 5713 (t 5675 5714 (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form)) … … 5949 5988 (compile-function-call form target representation) 5950 5989 (return-from p2-truncate))) 5951 (compile-form arg1 'stack nil) 5952 (compile-form arg2 'stack nil) 5953 (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+) 5990 (with-operand-accumulation 5991 ((compile-operand arg1 nil) 5992 (compile-operand arg2 nil))) 5993 (maybe-emit-clear-values arg1 arg2) 5994 (emit-invokevirtual +lisp-object+ "truncate" 5995 (lisp-object-arg-types 1) +lisp-object+) 5954 5996 (fix-boxing representation nil) ; FIXME use derived result type 5955 5997 (emit-move-from-stack target representation))) … … 6287 6329 (compile-forms-and-maybe-emit-clear-values arg target representation))) 6288 6330 (2 6289 (emit-push-current-thread)6290 6331 (let ((arg1 (%car args)) 6291 6332 (arg2 (%cadr args))) 6292 6333 (cond ((and (eq arg1 t) 6293 6334 (eq arg2 t)) 6335 (emit-push-current-thread) 6294 6336 (emit-push-t) 6295 6337 (emit 'dup)) 6296 6338 ((and (eq arg1 nil) 6297 6339 (eq arg2 nil)) 6340 (emit-push-current-thread) 6298 6341 (emit-push-nil) 6299 6342 (emit 'dup)) 6300 6343 (t 6301 6344 (with-operand-accumulation 6302 ((compile-operand arg1 nil) 6345 ((emit-thread-operand) 6346 (compile-operand arg1 nil) 6303 6347 (compile-operand arg2 nil) 6304 6348 (maybe-emit-clear-values arg1 arg2))))))
Note: See TracChangeset
for help on using the changeset viewer.