0.8.3.44:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index f6b32a1..4bb3a9f 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -383,7 +383,7 @@
            ((= index end)
             (let ((place (* times 4)))
               (declare (fixnum place))
-              (dotimes (j rem)
+              (dotimes (j rem sequence)
                 (declare (index j))
                 (setf (schar sequence (the index (+ place j))) item))))
          (declare (optimize (speed 3) (safety 0))
@@ -461,3 +461,50 @@
 
 (define-good-modular-fun logand)
 (define-good-modular-fun logior)
+\f
+;;; There are two different ways the multiplier can be recoded. The
+;;; more obvious is to shift X by the correct amount for each bit set
+;;; in Y and to sum the results. But if there is a string of bits that
+;;; are all set, you can add X shifted by one more then the bit
+;;; position of the first set bit and subtract X shifted by the bit
+;;; position of the last set bit. We can't use this second method when
+;;; the high order bit is bit 31 because shifting by 32 doesn't work
+;;; too well.
+(defun ub32-strength-reduce-constant-multiply (arg num)
+  (declare (type (unsigned-byte 32) numb))
+  (let ((adds 0) (shifts 0)
+       (result nil) first-one)
+    (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
+            (add (next-factor)
+              (setf result
+                    (tub32
+                     (if result
+                         (progn (incf adds) `(+ ,result ,(tub32 next-factor)))
+                         next-factor)))))
+      (declare (inline add))
+      (dotimes (bitpos 32)
+       (if first-one
+           (when (not (logbitp bitpos num))
+             (add (if (= (1+ first-one) bitpos)
+                      ;; There is only a single bit in the string.
+                      (progn (incf shifts) `(ash ,arg ,first-one))
+                      ;; There are at least two.
+                      (progn
+                        (incf adds)
+                        (incf shifts 2)
+                        `(- ,(tub32 `(ash ,arg ,bitpos))
+                            ,(tub32 `(ash ,arg ,first-one))))))
+             (setf first-one nil))
+           (when (logbitp bitpos num)
+             (setf first-one bitpos))))
+      (when first-one
+       (cond ((= first-one 31))
+             ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
+             (t
+              (incf shifts 2)
+              (incf adds)
+              (add `(- ,(tub32 `(ash ,arg 31)) 
+                       ,(tub32 `(ash ,arg ,first-one))))))
+       (incf shifts)
+       (add `(ash ,arg 31))))
+    (values result adds shifts)))