0.8.3.45.modular6:

	Implement 64-bit modular arithmetic for alpha.
	... can't simplify BIGNUM-LOGNOT or 32BIT-LOGICAL-FOO here,
		because modular arithmetic is 64-bit, duh :-)
	... it would be nice to compile (logand ... (1- (ash 1 32)))
		more efficiently than we currently do; currently we
		load up a 32-bit quantity into a register, followed
		by an and instruction; however, we should be able
		simply to do mskll reg, 4, reg.
	I think this works.  Simple testing shows that it seems to work.
	But see also CSR sbcl-devel 2003-09-12, because there are a number
	of nasty surprises lurking in the depths of this backend.

diff --git a/NEWS b/NEWS
index 1a5dc69..9add302 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2031,7 +2031,9 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3:
     simple-base-strings and simple-bit-vectors is improved.
   * optimization: the optimization of 32-bit logical and arithmetic
     functions introduced in version 0.8.3 on the x86 has been
-    implemented on the mips, ppc and sparc platforms.
+    implemented on the mips, ppc and sparc platforms; an
+    implementation of the same facility, but for 64-bit arithmetic,
+    has been added for the alpha.
   * microoptimization: the compiler is better able to make use of the
     x86 LEA instruction for multiplication by constants.
   * bug fix: in some situations compiler did not report usage of

diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index 1da0e8c..35d0b52 100644 (file)
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -101,58 +101,77 @@
   (:info y)
   (:arg-types tagged-num (:constant integer)))
 
-(defmacro define-binop (translate cost untagged-cost op
-                                 tagged-type untagged-type)
+(defmacro define-binop (translate cost untagged-cost op 
+                       tagged-type untagged-type
+                       &optional arg-swap restore-fixnum-mask)
   `(progn
      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
                  fast-fixnum-binop)
-       (:args (x :target r :scs (any-reg))
-             (y :target r :scs (any-reg)))
+       ,@(when restore-fixnum-mask
+          `((:temporary (:sc non-descriptor-reg) temp)))
+       (:args (x ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))
+             (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg)))
        (:translate ,translate)
        (:generator ,(1+ cost)
-        (inst ,op x y r)))
+        ,(if arg-swap
+             `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r))
+             `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r)))
+        ,@(when restore-fixnum-mask
+            `((inst bic temp #.(ash lowtag-mask -1) r)))))
      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
                  fast-signed-binop)
        (:args (x :target r :scs (signed-reg))
              (y :target r :scs (signed-reg)))
        (:translate ,translate)
        (:generator ,(1+ untagged-cost)
-        (inst ,op x y r)))
+        ,(if arg-swap
+             `(inst ,op y x r)
+             `(inst ,op x y r))))
      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
                  fast-unsigned-binop)
        (:args (x :target r :scs (unsigned-reg))
              (y :target r :scs (unsigned-reg)))
        (:translate ,translate)
        (:generator ,(1+ untagged-cost)
-        (inst ,op x y r)))
-     ,@(when tagged-type
+        ,(if arg-swap
+             `(inst ,op y x r)
+             `(inst ,op x y r))))
+     ,@(when (and tagged-type (not arg-swap))
         `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
                        fast-fixnum-c-binop)
-                      (:arg-types tagged-num (:constant ,tagged-type))
+            (:arg-types tagged-num (:constant ,tagged-type))
+            ,@(when restore-fixnum-mask
+                `((:temporary (:sc non-descriptor-reg) temp)))
             (:translate ,translate)
             (:generator ,cost
-                        (inst ,op x (fixnumize y) r)))))
-     ,@(when untagged-type
+               (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r))
+               ,@(when restore-fixnum-mask
+                   `((inst bic temp #.(ash lowtag-mask -1) r)))))))
+     ,@(when (and untagged-type (not arg-swap))
         `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
                        fast-signed-c-binop)
-                      (:arg-types signed-num (:constant ,untagged-type))
+            (:arg-types signed-num (:constant ,untagged-type))
             (:translate ,translate)
             (:generator ,untagged-cost
-                        (inst ,op x y r)))
+               (inst ,op x y r)))
           (define-vop (,(symbolicate "FAST-" translate
                                      "-C/UNSIGNED=>UNSIGNED")
                        fast-unsigned-c-binop)
-                      (:arg-types unsigned-num (:constant ,untagged-type))
+            (:arg-types unsigned-num (:constant ,untagged-type))
             (:translate ,translate)
             (:generator ,untagged-cost
-                        (inst ,op x y r)))))))
+               (inst ,op x y r)))))))
 
 (define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
 (define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
-(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
-(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
 (define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logandc1 1 3 bic (unsigned-byte 6) (unsigned-byte 8) t)
+(define-binop logandc2 1 3 bic (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logorc1 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) t t)
+(define-binop logorc2 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) nil t)
 (define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logeqv 1 3 eqv (unsigned-byte 6) (unsigned-byte 8) nil t)
 \f
 ;;;; shifting
 
@@ -284,6 +303,45 @@
   (:generator 3
     (inst mulq x y r)))
 \f
+;;;; Modular functions:
+(define-modular-fun lognot-mod64 (x) lognot 64)
+(define-vop (lognot-mod64/unsigned=>unsigned)
+  (:translate lognot-mod64)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst not x res)))
+
+(macrolet
+    ((define-modular-backend (fun &optional constantp)
+       (let ((mfun-name (symbolicate fun '-mod64))
+             (modvop (symbolicate 'fast- fun '-mod64/unsigned=>unsigned))
+             (modcvop (symbolicate 'fast- fun 'mod64-c/unsigned=>unsigned))
+             (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+             (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+         `(progn
+            (define-modular-fun ,mfun-name (x y) ,fun 64)
+            (define-vop (,modvop ,vop)
+              (:translate ,mfun-name))
+            ,@(when constantp
+                `((define-vop (,modcvop ,cvop)
+                    (:translate ,mfun-name))))))))
+  (define-modular-backend + t)
+  (define-modular-backend logxor t)
+  (define-modular-backend logeqv t)
+  (define-modular-backend logandc1)
+  (define-modular-backend logandc2 t)
+  (define-modular-backend logorc1)
+  (define-modular-backend logorc2 t))
+
+(define-source-transform lognand (x y)
+  `(lognot (logand ,x ,y)))
+(define-source-transform lognor (x y)
+  `(lognot (logior ,x ,y)))
+\f
 ;;;; binary conditional VOPs
 
 (define-vop (fast-conditional)
@@ -776,3 +834,4 @@
 (define-static-fun two-arg-and (x y) :translate logand)
 (define-static-fun two-arg-ior (x y) :translate logior)
 (define-static-fun two-arg-xor (x y) :translate logxor)
+(define-static-fun two-arg-eqv (x y) :translate logeqv)

diff --git a/src/compiler/alpha/parms.lisp b/src/compiler/alpha/parms.lisp
index 1b2326b..b13e2de 100644 (file)
--- a/src/compiler/alpha/parms.lisp
+++ b/src/compiler/alpha/parms.lisp
@@ -234,5 +234,6 @@
     sb!kernel:two-arg-and
     sb!kernel:two-arg-ior
     sb!kernel:two-arg-xor
+    sb!kernel:two-arg-eqv
     sb!kernel:two-arg-gcd
     sb!kernel:two-arg-lcm))

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 5ac2bea..82627cf 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -440,7 +440,7 @@
 
 \f
 ;;;; 32-bit operations
-#!-(or ppc sparc x86 mips) ; on X86 it is a modular function
+#!-(or ppc sparc x86 mips alpha) ; on X86 it is a modular function
 (deftransform lognot ((x) ((unsigned-byte 32)) *
                       :node node
                       :result result)

diff --git a/version.lisp-expr b/version.lisp-expr
index 24d81c5..1c40ac4 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.8.3.45.modular5"
+"0.8.3.45.modular6"