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.

diff --git a/NEWS b/NEWS
index ff56f09..48249b2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"