From: Thiemo S. <th...@ne...> - 2005-05-29 17:52:53
|
Hello All, this patch fixes an apparent copy&paste error which left generic-/= calling two-arg-= instead of two-arg-/=. It also improves the mips version with fastpaths for fixnum calculations in generic-+ and generic--; and minor improvements in the other generic functions. Thiemo Index: src/assembly/alpha/arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/alpha/arith.lisp,v retrieving revision 1.7 diff -u -p -r1.7 arith.lisp --- src/assembly/alpha/arith.lisp 26 Sep 2003 17:19:14 -0000 1.7 +++ src/assembly/alpha/arith.lisp 29 May 2005 17:38:14 -0000 @@ -408,7 +408,7 @@ (lisp-return lra lip :offset 2) DO-STATIC-FN - (inst ldl lip (static-fun-offset 'two-arg-=) null-tn) + (inst ldl lip (static-fun-offset 'two-arg-/=) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) Index: src/assembly/mips/arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/mips/arith.lisp,v retrieving revision 1.1 diff -u -p -r1.1 arith.lisp --- src/assembly/mips/arith.lisp 1 Sep 2002 22:34:18 -0000 1.1 +++ src/assembly/mips/arith.lisp 29 May 2005 17:38:14 -0000 @@ -13,28 +13,42 @@ (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - (inst b DO-STATIC-FUN) - (inst nop) - #+nil - (progn - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FUN) - (inst nop) - (inst add res x y) - (lisp-return lra lip :offset 2)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp DO-ADD) + (inst sra temp1 x n-fixnum-tag-bits) - DO-STATIC-FUN + ;; DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset 'two-arg-+)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) - (inst move cfp-tn csp-tn)) + (inst move cfp-tn csp-tn) + + DO-ADD + (inst sra temp2 y n-fixnum-tag-bits) + (inst addu temp temp1 temp2) + ;; check for overflow + (inst sra temp1 temp (- n-word-bits n-lowtag-bits)) + (inst beq temp1 RETURN) + (inst nor temp1 temp1) + (inst beq temp1 RETURN) + (inst nop) + (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset)) + (storew temp res bignum-digits-offset other-pointer-lowtag)) + (inst b DONE) + (inst nop) + + RETURN + (inst sll res temp n-fixnum-tag-bits) + + DONE) (define-assembly-routine (generic-- @@ -49,28 +63,42 @@ (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - (inst b DO-STATIC-FUN) - (inst nop) - #+nil - (progn - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FUN) - (inst nop) - (inst sub res x y) - (lisp-return lra lip :offset 2)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp DO-SUB) + (inst sra temp1 x n-fixnum-tag-bits) - DO-STATIC-FUN + ;; DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset 'two-arg--)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) - (inst move cfp-tn csp-tn)) + (inst move cfp-tn csp-tn) + + DO-SUB + (inst sra temp2 y n-fixnum-tag-bits) + (inst subu temp temp1 temp2) + ;; check for overflow + (inst sra temp1 temp (- n-word-bits n-lowtag-bits)) + (inst beq temp1 RETURN) + (inst nor temp1 temp1) + (inst beq temp1 RETURN) + (inst nop) + (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset)) + (storew temp res bignum-digits-offset other-pointer-lowtag)) + (inst b DONE) + (inst nop) + + RETURN + (inst sll res temp n-fixnum-tag-bits) + + DONE) (define-assembly-routine (generic-* @@ -89,38 +117,32 @@ (:temp hi non-descriptor-reg nl2-offset) (:temp pa-flag non-descriptor-reg nl4-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) + (inst or temp x y) + (inst and temp fixnum-tag-mask) (inst bne temp DO-STATIC-FUN) - (inst nop) - ;; Remove the tag from one arg so that the result will have the correct ;; fixnum tag. - (inst sra temp x 2) + (inst sra temp x n-fixnum-tag-bits) (inst mult temp y) (inst mflo res) (inst mfhi hi) ;; Check to see if the result will fit in a fixnum. (I.e. the high word ;; is just 32 copies of the sign bit of the low word). (inst sra temp res 31) - (inst xor temp hi) - (inst beq temp DONE) + (inst beq temp hi DONE) ;; Shift the double word hi:res down two bits into hi:low to get rid of the ;; fixnum tag. - (inst srl lo res 2) - (inst sll temp hi 30) + (inst srl lo res n-fixnum-tag-bits) + (inst sll temp hi (- n-word-bits n-fixnum-tag-bits)) (inst or lo temp) - (inst sra hi 2) + (inst sra hi n-fixnum-tag-bits) ;; Do we need one word or two? Assume two. (inst sra temp lo 31) - (inst xor temp hi) - (inst bne temp two-words) + (inst bne temp hi TWO-WORDS) ;; Assume a two word header. (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) @@ -134,8 +156,8 @@ (storew lo res bignum-digits-offset other-pointer-lowtag) ;; Out of here - (lisp-return lra lip :offset 2) - + (inst b DONE) + (inst nop) TWO-WORDS (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset))) @@ -146,8 +168,8 @@ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) ;; Out of here - (lisp-return lra lip :offset 2) - + (inst b DONE) + (inst nop) DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset 'two-arg-*)) @@ -163,7 +185,7 @@ ;;;; Comparison routines. (macrolet - ((define-cond-assem-rtn (name translate static-fn cmp not-p) + ((define-cond-assem-rtn (name translate static-fn cmp) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) @@ -179,13 +201,12 @@ (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) + (inst or temp x y) + (inst and temp fixnum-tag-mask) (inst beq temp DO-COMPARE) ,cmp - - DO-STATIC-FN + + ;; DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset ',static-fn)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) @@ -193,13 +214,14 @@ (inst move cfp-tn csp-tn) DO-COMPARE - (inst ,(if not-p 'bne 'beq) temp done) + (inst beq temp DONE) (inst move res null-tn) (load-symbol res t) + DONE))) - (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil) - (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil)) + (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y)) + (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x))) (define-assembly-routine (generic-eql @@ -215,29 +237,30 @@ (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst beq x y RETURN-T) - (inst and temp x 3) - (inst beq temp RETURN-NIL) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp RETURN) (inst nop) - RETURN-NIL - (inst move res null-tn) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN + ;; DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset 'eql)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) + RETURN + (inst bne x y DONE) + (inst move res null-tn) + RETURN-T - (load-symbol res t)) + (load-symbol res t) + + DONE) + (define-assembly-routine (generic-= (:cost 10) @@ -252,28 +275,27 @@ (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp RETURN) (inst nop) - (inst beq x y RETURN-T) - - (inst move res null-tn) - (lisp-return lra lip :offset 2) - DO-STATIC-FN + ;; DO-STATIC-FUN (inst lw lip null-tn (static-fun-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) - RETURN-T - (load-symbol res t)) + RETURN + (inst bne x y DONE) + (inst move res null-tn) + (load-symbol res t) + + DONE) + (define-assembly-routine (generic-/= (:cost 10) @@ -288,25 +310,23 @@ (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp RETURN) (inst nop) - (inst beq x y RETURN-NIL) - (load-symbol res t) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst lw lip null-tn (static-fun-offset 'two-arg-=)) + ;; DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg-/=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) - RETURN-NIL - (inst move res null-tn)) + RETURN + (inst beq x y DONE) + (inst move res null-tn) + (load-symbol res t) + + DONE) Index: src/assembly/ppc/arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/ppc/arith.lisp,v retrieving revision 1.3 diff -u -p -r1.3 arith.lisp --- src/assembly/ppc/arith.lisp 4 May 2005 10:35:49 -0000 1.3 +++ src/assembly/ppc/arith.lisp 29 May 2005 17:38:14 -0000 @@ -422,7 +422,7 @@ (lisp-return lra lip :offset 2) DO-STATIC-FN - (inst lwz lip null-tn (static-fun-offset 'two-arg-=)) + (inst lwz lip null-tn (static-fun-offset 'two-arg-/=)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst j lip 0) Index: src/assembly/sparc/arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/sparc/arith.lisp,v retrieving revision 1.2 diff -u -p -r1.2 arith.lisp --- src/assembly/sparc/arith.lisp 9 Apr 2002 09:29:04 -0000 1.2 +++ src/assembly/sparc/arith.lisp 29 May 2005 17:38:14 -0000 @@ -552,7 +552,7 @@ (lisp-return lra :offset 2) DO-STATIC-FN - (inst ld code-tn null-tn (static-fun-offset 'two-arg-=)) + (inst ld code-tn null-tn (static-fun-offset 'two-arg-/=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn |