X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=4bb3a9f9fe8db40bedba9a7f4822ff91e1484c2c;hb=5c139b13882a2632a27a7f8fd81c8f1ab62b10a0;hp=d5937ba6703bba673de145bdf331f7e477feabf8;hpb=98743008038a932dc6b53560d121df69c40e40ad;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index d5937ba..4bb3a9f 100644
--- 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))))))
 
 ;;;; %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)
+
+;;; 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)))