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 d5937ba..4bb3a9f 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -340,6 +340,55 @@
                  (declare (type (unsigned-byte 32) numx numy))
                  (unless (= numx numy)
                    (return nil))))))))
+
+(deftransform fill ((sequence item) (simple-bit-vector bit) *
+                   :policy (>= speed space))
+  (let ((value (if (constant-continuation-p item)
+                  (if (= (continuation-value item) 0)
+                      0
+                      #.(1- (ash 1 32)))
+                  `(if (= item 0) 0 #.(1- (ash 1 32))))))
+    `(let ((length (length sequence))
+          (value ,value))
+       (if (= length 0)
+          sequence
+          (do ((index sb!vm:vector-data-offset (1+ index))
+               (end-1 (+ sb!vm:vector-data-offset
+                         ;; bit-vectors of length 1-32 need precisely
+                         ;; one (SETF %RAW-BITS), done here in the
+                         ;; epilogue. - CSR, 2002-04-24
+                         (truncate (truly-the index (1- length))
+                                   sb!vm:n-word-bits))))
+              ((= index end-1)
+               (setf (%raw-bits sequence index) value)
+               sequence)
+            (declare (optimize (speed 3) (safety 0))
+                     (type index index end-1))
+            (setf (%raw-bits sequence index) value))))))
+
+(deftransform fill ((sequence item) (simple-base-string base-char) *
+                   :policy (>= speed space))
+  (let ((value (if (constant-continuation-p item)
+                  (let* ((char (continuation-value item))
+                         (code (sb!xc:char-code char)))
+                    (logior code (ash code 8) (ash code 16) (ash code 24)))
+                  `(let ((code (sb!xc:char-code item)))
+                    (logior code (ash code 8) (ash code 16) (ash code 24))))))
+    `(let ((length (length sequence))
+          (value ,value))
+      (multiple-value-bind (times rem)
+         (truncate length 4)
+       (do ((index sb!vm:vector-data-offset (1+ index))
+            (end (+ times sb!vm:vector-data-offset)))
+           ((= index end)
+            (let ((place (* times 4)))
+              (declare (fixnum place))
+              (dotimes (j rem sequence)
+                (declare (index j))
+                (setf (schar sequence (the index (+ place j))) item))))
+         (declare (optimize (speed 3) (safety 0))
+                  (type index index))
+         (setf (%raw-bits sequence index) value))))))
 \f
 ;;;; %BYTE-BLT
 
@@ -409,3 +458,53 @@
     (setf (node-derived-type node)
           (values-specifier-type '(values (unsigned-byte 32) &optional)))
     '(32bit-logical-not x)))
+
+(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)))