0.8.13.67:

	Implement modular ASH for non-constant positive shifts
	... make sure that we only apply the transform when we know
		the shift count won't be misinterpreted...
	... and also that we don't do the more expensive non-constant
		shift for constant counts;
	... punt on some of the cleverness for hppa; all other platforms
		should be optimal.
	... one test for something which went wrong in an earlier version.

diff --git a/NEWS b/NEWS
index efef0e0..e0ab0cb 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -35,6 +35,9 @@ changes in sbcl-0.8.14 relative to sbcl-0.8.13:
     applying the more sophisticated binary GCD.  (thanks to Juho
     Snellman)
   * optimization: COUNT on bitvectors now operates word-at-a-time.
+  * optimization: ASH with a positive, but not necessarily constant,
+    (leftwards) shift, when in a modular context, is compiled to a
+    hardware shift.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** FORMAT variable parameters ("~V<char>") are defaulted properly
        if the corresponding argument is NIL.

diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index b39ba7b..e8c0586 100644 (file)
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -271,6 +271,28 @@
       ((> count 0) (inst sll number (min 63 count) result))
       (t (bug "identity ASH not transformed away")))))
 
+(macrolet ((def (name sc-type type result-type cost)
+             `(define-vop (,name)
+                (:note "inline ASH")
+                (:translate ash)
+                (:args (number :scs (,sc-type))
+                       (amount :scs (signed-reg unsigned-reg immediate)))
+                (:arg-types ,type positive-fixnum)
+                (:results (result :scs (,result-type)))
+                (:result-types ,type)
+                (:policy :fast-safe)
+                (:generator ,cost
+                   (sc-case amount
+                     ((signed-reg unsigned-reg)
+                      (inst sll number amount result))
+                     (immediate
+                      (let ((amount (tn-value amount)))
+                        (aver (> amount 0))
+                        (inst sll number amount result))))))))
+  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+
 (define-vop (signed-byte-64-len)
   (:translate integer-length)
   (:note "inline (signed-byte 64) integer-length")
@@ -381,6 +403,13 @@
 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
             fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod64))
+(define-vop (fast-ash-left-mod64/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod64 ((integer count)
+                             ((unsigned-byte 64) (unsigned-byte 6)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
 
 (macrolet
     ((define-modular-backend (fun &optional constantp)

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index e3de20d..5be78b7 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -490,11 +490,14 @@
     ((def (name width)
         `(progn
            (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
-                     (foldable flushable movable))
+                     (foldable flushable movable))        
            (define-modular-fun-optimizer ash ((integer count) :width width)
              (when (and (<= width ,width)
-                        (constant-lvar-p count) ;?
-                        (plusp (lvar-value count)))
+                        (or (and (constant-lvar-p count)
+                                 (plusp (lvar-value count)))
+                            (csubtypep (lvar-type count)
+                                       (specifier-type '(and unsigned-byte
+                                                         fixnum)))))
                (cut-to-width integer width)
                ',name))
            (setf (gethash ',name *modular-versions*) `(ash ,',width)))))

diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp
index dafcd2a..78b3f53 100644 (file)
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@ -295,6 +295,9 @@
           ;; Count=0?  Shouldn't happen, but it's easy:
           (move number result)))))
 
+;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
+;;; use in modular ASH (and because they're useful anyway).  -- CSR,
+;;; 2004-08-16
 
 (define-vop (signed-byte-32-len)
   (:translate integer-length)
@@ -591,6 +594,15 @@
 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
             fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+            ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
+            ;; implemented, use it here.  -- CSR, 2004-08-16
+             fast-ash/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+                             ((unsigned-byte 32) (unsigned-byte 5)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
 (define-modular-fun lognot-mod32 (x) lognot 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)

diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp
index 61d6c29..9ae3a64 100644 (file)
--- a/src/compiler/mips/arith.lisp
+++ b/src/compiler/mips/arith.lisp
@@ -295,6 +295,28 @@
       ((> count 0) (inst sll result number (min count 31)))
       (t (bug "identity ASH not transformed away")))))
 
+(macrolet ((def (name sc-type type result-type cost)
+             `(define-vop (,name)
+                (:note "inline ASH")
+                (:translate ash)
+                (:args (number :scs (,sc-type))
+                       (amount :scs (signed-reg unsigned-reg immediate)))
+                (:arg-types ,type positive-fixnum)
+                (:results (result :scs (,result-type)))
+                (:result-types ,type)
+                (:policy :fast-safe)
+                (:generator ,cost
+                   (sc-case amount
+                     ((signed-reg unsigned-reg)
+                      (inst sll result number amount))
+                     (immediate
+                      (let ((amount (tn-value amount)))
+                        (aver (> amount 0))
+                        (inst sll result number amount))))))))
+  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+
 (define-vop (signed-byte-32-len)
   (:translate integer-length)
   (:note "inline (signed-byte 32) integer-length")
@@ -660,6 +682,14 @@
             fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
 
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+                             ((unsigned-byte 32) (unsigned-byte 5)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
+
 ;;; logical operations
 (define-modular-fun lognot-mod32 (x) lognot 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)

diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index df34914..369b0e8 100644 (file)
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -475,6 +475,14 @@
             fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
 
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+                             ((unsigned-byte 32) (unsigned-byte 5)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
+
 (macrolet 
     ((define-modular-backend (fun &optional constantp)
        (let ((mfun-name (symbolicate fun '-mod32))

diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp
index f1f8536..1f40039 100644 (file)
--- a/src/compiler/sparc/arith.lisp
+++ b/src/compiler/sparc/arith.lisp
@@ -482,7 +482,7 @@
 ;; Some special cases where we know we want a left shift.  Just do the
 ;; shift, instead of checking for the sign of the shift.
 (macrolet
-    ((frob (name sc-type type result-type cost)
+    ((def (name sc-type type result-type cost)
        `(define-vop (,name)
         (:note "inline ASH")
         (:translate ash)
@@ -503,9 +503,9 @@
            (let ((amount (tn-value amount)))
              (aver (>= amount 0))
              (inst sll result number amount))))))))
-  (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
-  (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
-  (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
 
 \f
 (define-vop (signed-byte-32-len)
@@ -689,6 +689,14 @@
 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
             fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
+
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+                             ((unsigned-byte 32) (unsigned-byte 5)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 \f
 ;;;; Binary conditional VOPs:
 

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 9e8e07e..ade7689 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -1212,6 +1212,14 @@
              fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
 
+(define-vop (fast-ash-left-mod32/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod32 ((integer count)
+                             ((unsigned-byte 32) (unsigned-byte 5)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
+
 (in-package "SB!C")
 
 (defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 0799a59..cadd0b0 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1431,3 +1431,12 @@
                   (declare (type (integer 3 6) y)
                            (type (integer -6 -3) x))
                   (+ (logxor x y) most-positive-fixnum)))))
+
+;;; check that modular ash gives the right answer, to protect against
+;;; possible misunderstandings about the hardware shift instruction.
+(assert (zerop (funcall
+               (compile nil '(lambda (x y)
+                              (declare (optimize speed)
+                                       (type (unsigned-byte 32) x y))
+                              (logand #xffffffff (ash x y))))
+               1 257)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 9893852..cea48f3 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.13.66"
+"0.8.13.67"