From af260d6fe0473cead85f2994bde61189ed58d3f2 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 3 Jun 2005 10:17:25 +0000 Subject: [PATCH] 0.9.1.23: Merge THS "Fix generic-/= for alpha, mips, ppc, sparc" patch (sbcl-devel 2005-05-29) ... actually it's mostly a mips optimization, because I don't think generic-/= can ever be emitted with the source transforms we have at the moment. --- NEWS | 2 + src/assembly/alpha/arith.lisp | 2 +- src/assembly/mips/arith.lisp | 202 ++++++++++++++++++++++------------------- src/assembly/ppc/arith.lisp | 2 +- src/assembly/sparc/arith.lisp | 2 +- version.lisp-expr | 2 +- 6 files changed, 117 insertions(+), 95 deletions(-) diff --git a/NEWS b/NEWS index ff56f09..48249b2 100644 --- a/NEWS +++ b/NEWS @@ -14,6 +14,8 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: Sascha Wilde) * bug fix: more cleanups to the floating point exception handling on x86-64 (thanks to James Knight) + * optimization: improved the MIPS versions of generic (in the + generic sense) arithmetic routines. (thanks to Thiemo Seufer) * contrib improvement: it's harder to cause SOCKET-CLOSE to close() the wrong file descriptor; implementation of SOCKET-OPEN-P. (thanks to Tony Martinez) diff --git a/src/assembly/alpha/arith.lisp b/src/assembly/alpha/arith.lisp index fad4209..80094f2 100644 --- a/src/assembly/alpha/arith.lisp +++ b/src/assembly/alpha/arith.lisp @@ -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) diff --git a/src/assembly/mips/arith.lisp b/src/assembly/mips/arith.lisp index 1b9d039..c36fcdd 100644 --- a/src/assembly/mips/arith.lisp +++ b/src/assembly/mips/arith.lisp @@ -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) diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp index c19a901..13e998a 100644 --- a/src/assembly/ppc/arith.lisp +++ b/src/assembly/ppc/arith.lisp @@ -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) diff --git a/src/assembly/sparc/arith.lisp b/src/assembly/sparc/arith.lisp index 05d3b8c..a299846 100644 --- a/src/assembly/sparc/arith.lisp +++ b/src/assembly/sparc/arith.lisp @@ -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 diff --git a/version.lisp-expr b/version.lisp-expr index 2fb497b..3559603 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.22" +"0.9.1.23" -- 1.7.10.4