[Sbcl-commits] CVS: sbcl/src/assembly/mips assem-rtns.lisp,1.5,1.5.6.1 arith.lisp,1.6,1.6.4.1

[Cyrus H. <sl...@us...>]

Update of /cvsroot/sbcl/sbcl/src/assembly/mips
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28442/src/assembly/mips

Modified Files:
      Tag: lutex-branch
	assem-rtns.lisp arith.lisp 
Log Message:
0.9.12.26.lutex-branch.33
   * merging 0.9.12.26 changes onto the lutex branch


Index: assem-rtns.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/assembly/mips/assem-rtns.lisp,v
retrieving revision 1.5
retrieving revision 1.5.6.1
diff -u -d -r1.5 -r1.5.6.1
--- assem-rtns.lisp	14 Jul 2005 16:30:11 -0000	1.5
+++ assem-rtns.lisp	15 May 2006 17:07:52 -0000	1.5.6.1
@@ -31,36 +31,36 @@
   ;; Note, because of the way the return-multiple vop is written, we can
   ;; assume that we are never called with nvals == 1 and that a0 has already
   ;; been loaded.
-  (inst blez nvals default-a0-and-on)
+  (inst blez nvals DEFAULT-A0-AND-ON)
   (inst subu count nvals (fixnumize 2))
-  (inst blez count default-a2-and-on)
+  (inst blez count DEFAULT-A2-AND-ON)
   (inst lw a1 vals (* 1 n-word-bytes))
   (inst subu count (fixnumize 1))
-  (inst blez count default-a3-and-on)
+  (inst blez count DEFAULT-A3-AND-ON)
   (inst lw a2 vals (* 2 n-word-bytes))
   (inst subu count (fixnumize 1))
-  (inst blez count default-a4-and-on)
+  (inst blez count DEFAULT-A4-AND-ON)
   (inst lw a3 vals (* 3 n-word-bytes))
   (inst subu count (fixnumize 1))
-  (inst blez count default-a5-and-on)
+  (inst blez count DEFAULT-A5-AND-ON)
   (inst lw a4 vals (* 4 n-word-bytes))
   (inst subu count (fixnumize 1))
   (inst blez count done)
   (inst lw a5 vals (* 5 n-word-bytes))
 
   ;; Copy the remaining args to the top of the stack.
-  (inst addu vals vals (* 6 n-word-bytes))
-  (inst addu dst cfp-tn (* 6 n-word-bytes))
+  (inst addu vals (fixnumize register-arg-count))
+  (inst addu dst cfp-tn (fixnumize register-arg-count))
 
   LOOP
   (inst lw temp vals)
   (inst addu vals n-word-bytes)
-  (inst sw temp dst)
   (inst subu count (fixnumize 1))
-  (inst bne count zero-tn loop)
+  (inst sw temp dst)
+  (inst bne count LOOP)
   (inst addu dst n-word-bytes)
 
-  (inst b done)
+  (inst b DONE)
   (inst nop)
 
   DEFAULT-A0-AND-ON
@@ -102,7 +102,7 @@
      ;; These are needed by the blitting code.
      (:temp src any-reg nl1-offset)
      (:temp dst any-reg nl2-offset)
-     (:temp count any-reg cfunc-offset)
+     (:temp count any-reg nl3-offset)
      (:temp temp descriptor-reg l0-offset)
 
      ;; Needed for the jump
@@ -130,19 +130,19 @@
   (inst lw a5 args (* 5 n-word-bytes))
 
   ;; Calc SRC, DST, and COUNT
-  (inst addu count nargs (fixnumize (- register-arg-count)))
+  (inst subu count nargs (fixnumize register-arg-count))
   (inst blez count done)
-  (inst addu src args (* n-word-bytes register-arg-count))
-  (inst addu dst cfp-tn (* n-word-bytes register-arg-count))
+  (inst addu src args (fixnumize register-arg-count))
+  (inst addu dst cfp-tn (fixnumize register-arg-count))
 
   LOOP
   ;; Copy one arg.
   (inst lw temp src)
-  (inst addu src src n-word-bytes)
+  (inst addu src n-word-bytes)
+  (inst subu count (fixnumize 1))
   (inst sw temp dst)
-  (inst addu count (fixnumize -1))
-  (inst bgtz count loop)
-  (inst addu dst dst n-word-bytes)
+  (inst bgtz count LOOP)
+  (inst addu dst n-word-bytes)
 
   DONE
   ;; We are done.  Do the jump.
@@ -168,27 +168,25 @@
   (declare (ignore start count))
 
   (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst beq block zero-tn error)
+    (inst beq block error)
     (inst nop))
 
   (load-symbol-value cur-uwp *current-unwind-protect-block*)
   (loadw target-uwp block unwind-block-current-uwp-slot)
-  (inst bne cur-uwp target-uwp do-uwp)
+  (inst bne cur-uwp target-uwp DO-UWP)
   (inst nop)
 
   (move cur-uwp block)
 
   DO-EXIT
-
   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
   (loadw code-tn cur-uwp unwind-block-current-code-slot)
   (loadw lra cur-uwp unwind-block-entry-pc-slot)
   (lisp-return lra lip :frob-code nil)
 
   DO-UWP
-
   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
-  (inst b do-exit)
+  (inst b DO-EXIT)
   (store-symbol-value next-uwp *current-unwind-protect-block*))
 
 (define-assembly-routine
@@ -205,18 +203,16 @@
   (load-symbol-value catch *current-catch-block*)
 
   LOOP
-
   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst beq catch zero-tn error)
+    (inst beq catch error)
     (inst nop))
 
   (loadw tag catch catch-block-tag-slot)
-  (inst beq tag target exit)
+  (inst beq tag target EXIT)
   (inst nop)
-  (inst b loop)
+  (inst b LOOP)
   (loadw catch catch catch-block-previous-catch-slot)
 
   EXIT
-
   (inst j (make-fixup 'unwind :assembly-routine))
   (move target catch t))

Index: arith.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/assembly/mips/arith.lisp,v
retrieving revision 1.6
retrieving revision 1.6.4.1
diff -u -d -r1.6 -r1.6.4.1
--- arith.lisp	16 Aug 2005 15:20:40 -0000	1.6
+++ arith.lisp	15 May 2006 17:07:52 -0000	1.6.4.1
@@ -1,3 +1,14 @@
+;;;; stuff to handle simple cases for generic arithmetic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
 (in-package "SB!VM")
 
 
@@ -25,39 +36,37 @@
                           (:temp temp1 non-descriptor-reg nl1-offset)
                           (:temp temp2 non-descriptor-reg nl2-offset)
                           (:temp pa-flag non-descriptor-reg nl4-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
   (inst or temp x y)
   (inst and temp fixnum-tag-mask)
-  (inst beq temp DO-ADD)
+  (inst bne temp DO-STATIC-FUN)
+  (inst addu temp x y)
+  ;; check for overflow
+  (inst xor temp1 temp x)
+  (inst xor temp2 temp y)
+  (inst and temp1 temp2)
+  (inst bltz temp1 DO-OVERFLOW)
   (inst sra temp1 x n-fixnum-tag-bits)
+  (inst move res temp)
+  (lisp-return lra lip :offset 2)
 
-  ;; DO-STATIC-FUN
-  (inst lw lip null-tn (static-fun-offset 'two-arg-+))
-  (inst li nargs (fixnumize 2))
-  (move ocfp cfp-tn)
-  (inst j lip)
-  (move cfp-tn csp-tn t)
-
-  DO-ADD
+  DO-OVERFLOW
+  ;; We did overflow, so do the bignum version
   (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)
+  (lisp-return lra lip :offset 2)
 
-  DONE)
+  DO-STATIC-FUN
+  (inst lw lip null-tn (static-fun-offset 'two-arg-+))
+  (inst li nargs (fixnumize 2))
+  (move ocfp cfp-tn)
+  (inst j lip)
+  (move cfp-tn csp-tn t))
 
 
 (define-assembly-routine (generic--
@@ -75,39 +84,37 @@
                           (:temp temp1 non-descriptor-reg nl1-offset)
                           (:temp temp2 non-descriptor-reg nl2-offset)
                           (:temp pa-flag non-descriptor-reg nl4-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
   (inst or temp x y)
   (inst and temp fixnum-tag-mask)
-  (inst beq temp DO-SUB)
+  (inst bne temp DO-STATIC-FUN)
+  (inst subu temp x y)
+  ;; check for overflow
+  (inst xor temp1 x y)
+  (inst xor temp2 x temp)
+  (inst and temp1 temp2)
+  (inst bltz temp1 DO-OVERFLOW)
   (inst sra temp1 x n-fixnum-tag-bits)
+  (inst move res temp)
+  (lisp-return lra lip :offset 2)
 
-  ;; DO-STATIC-FUN
-  (inst lw lip null-tn (static-fun-offset 'two-arg--))
-  (inst li nargs (fixnumize 2))
-  (move ocfp cfp-tn)
-  (inst j lip)
-  (move cfp-tn csp-tn t)
-
-  DO-SUB
+  DO-OVERFLOW
+  ;; We did overflow, so do the bignum version
   (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)
+  (lisp-return lra lip :offset 2)
 
-  DONE)
+  DO-STATIC-FUN
+  (inst lw lip null-tn (static-fun-offset 'two-arg--))
+  (inst li nargs (fixnumize 2))
+  (move ocfp cfp-tn)
+  (inst j lip)
+  (move cfp-tn csp-tn t))
 
 
 
@@ -129,6 +136,7 @@
                           (:temp lo non-descriptor-reg nl1-offset)
                           (:temp hi non-descriptor-reg nl2-offset)
                           (:temp pa-flag non-descriptor-reg nl4-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
@@ -145,10 +153,13 @@
   ;; 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 beq temp hi DONE)
+  (inst bne temp hi DO-BIGNUM)
+  (inst srl lo res n-fixnum-tag-bits)
+  (lisp-return lra lip :offset 2)
+
+  DO-BIGNUM
   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
   ;; fixnum tag.
-  (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 n-fixnum-tag-bits)
@@ -165,8 +176,8 @@
   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
     (inst or res alloc-tn other-pointer-lowtag)
     (storew temp res 0 other-pointer-lowtag))
-  (inst b DONE)
   (storew lo res bignum-digits-offset other-pointer-lowtag)
+  (lisp-return lra lip :offset 2)
 
   TWO-WORDS
   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
@@ -174,17 +185,16 @@
     (storew temp res 0 other-pointer-lowtag))
 
   (storew lo res bignum-digits-offset other-pointer-lowtag)
-  (inst b DONE)
   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+  (lisp-return lra lip :offset 2)
 
   DO-STATIC-FUN
   (inst lw lip null-tn (static-fun-offset 'two-arg-*))
   (inst li nargs (fixnumize 2))
   (move ocfp cfp-tn)
   (inst j lip)
-  (move cfp-tn csp-tn t)
+  (move cfp-tn csp-tn t))
 
-  DONE)
 
 (macrolet
     ((frob (name note cost type sc signed-p)
@@ -297,27 +307,28 @@
                                   (:res res descriptor-reg a0-offset)
 
                                   (:temp temp non-descriptor-reg nl0-offset)
+                                  (:temp lra descriptor-reg lra-offset)
                                   (:temp lip interior-reg lip-offset)
                                   (:temp nargs any-reg nargs-offset)
                                   (:temp ocfp any-reg ocfp-offset))
           (inst or temp x y)
           (inst and temp fixnum-tag-mask)
-          (inst beq temp DO-COMPARE)
+          (inst bne temp DO-STATIC-FUN)
           ,cmp
 
-          ;; DO-STATIC-FUN
-          (inst lw lip null-tn (static-fun-offset ',static-fn))
-          (inst li nargs (fixnumize 2))
-          (move ocfp cfp-tn)
-          (inst j lip)
-          (move cfp-tn csp-tn t)
-
-          DO-COMPARE
           (inst ,(if not-p 'beq 'bne) temp DONE)
           (move res null-tn t)
           (load-symbol res t)
 
-          DONE)))
+          DONE
+          (lisp-return lra lip :offset 2)
+
+          DO-STATIC-FUN
+          (inst lw lip null-tn (static-fun-offset ',static-fn))
+          (inst li nargs (fixnumize 2))
+          (move ocfp cfp-tn)
+          (inst j lip)
+          (move cfp-tn csp-tn t))))
 
   (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
   (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
@@ -337,30 +348,31 @@
                           (:res res descriptor-reg a0-offset)
 
                           (:temp temp non-descriptor-reg nl0-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
   (inst beq x y RETURN-T)
   (inst or temp x y)
   (inst and temp fixnum-tag-mask)
-  (inst beq temp RETURN)
+  (inst bne temp DO-STATIC-FUN)
   (inst nop)
 
-  ;; DO-STATIC-FUN
-  (inst lw lip null-tn (static-fun-offset 'eql))
-  (inst li nargs (fixnumize 2))
-  (move ocfp cfp-tn)
-  (inst j lip)
-  (move cfp-tn csp-tn t)
-
-  RETURN
   (inst bne x y DONE)
   (move res null-tn t)
 
   RETURN-T
   (load-symbol res t)
 
-  DONE)
+  DONE
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst lw lip null-tn (static-fun-offset 'eql))
+  (inst li nargs (fixnumize 2))
+  (move ocfp cfp-tn)
+  (inst j lip)
+  (move cfp-tn csp-tn t))
 
 
 (define-assembly-routine (generic-=
@@ -375,27 +387,28 @@
                           (:res res descriptor-reg a0-offset)
 
                           (:temp temp non-descriptor-reg nl0-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
   (inst or temp x y)
   (inst and temp fixnum-tag-mask)
-  (inst beq temp RETURN)
+  (inst bne temp DO-STATIC-FUN)
   (inst nop)
 
-  ;; DO-STATIC-FUN
-  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
-  (inst li nargs (fixnumize 2))
-  (move ocfp cfp-tn)
-  (inst j lip)
-  (move cfp-tn csp-tn t)
-
-  RETURN
   (inst bne x y DONE)
   (move res null-tn t)
   (load-symbol res t)
 
-  DONE)
+  DONE
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
+  (inst li nargs (fixnumize 2))
+  (move ocfp cfp-tn)
+  (inst j lip)
+  (move cfp-tn csp-tn t))
 
 
 (define-assembly-routine (generic-/=
@@ -410,24 +423,25 @@
                           (:res res descriptor-reg a0-offset)
 
                           (:temp temp non-descriptor-reg nl0-offset)
+                          (:temp lra descriptor-reg lra-offset)
                           (:temp lip interior-reg lip-offset)
                           (:temp nargs any-reg nargs-offset)
                           (:temp ocfp any-reg ocfp-offset))
   (inst or temp x y)
   (inst and temp fixnum-tag-mask)
-  (inst beq temp RETURN)
+  (inst bne temp DO-STATIC-FUN)
   (inst nop)
 
-  ;; DO-STATIC-FUN
-  (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
-  (inst li nargs (fixnumize 2))
-  (move ocfp cfp-tn)
-  (inst j lip)
-  (move cfp-tn csp-tn t)
-
-  RETURN
   (inst beq x y DONE)
   (move res null-tn t)
   (load-symbol res t)
 
-  DONE)
+  DONE
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
+  (inst li nargs (fixnumize 2))
+  (move ocfp cfp-tn)
+  (inst j lip)
+  (move cfp-tn csp-tn t))