X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=5be78b7d913eec00a1f1e3b4ca71062c6f512161;hb=75b52379bdc2269961af6a1308eca63610f38ac3;hp=1d93ebafc282f4f0c6400c147afeb489a4301110;hpb=1e9966d5f24709d227e20911b4e1ddd27c87a00e;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 1d93eba..5be78b7 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -50,7 +50,7 @@
 	  ((simple-array character (*)) (data-vector-ref string index))
 	  ((simple-array nil (*)) (data-vector-ref string index))))))
 
-(deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
+(deftransform hairy-data-vector-ref ((array index) (array t) *)
   "avoid runtime dispatch on array element type"
   (let ((element-ctype (extract-upgraded-element-type array))
 	(declared-element-ctype (extract-declared-element-type array)))
@@ -103,8 +103,7 @@
 
 (deftransform hairy-data-vector-set ((array index new-value)
 				     (array t t)
-				     *
-				     :important t)
+				     *)
   "avoid runtime dispatch on array element type"
   (let ((element-ctype (extract-upgraded-element-type array))
 	(declared-element-ctype (extract-declared-element-type array)))
@@ -153,8 +152,7 @@
 
 (deftransform %data-vector-and-index ((%array %index)
 				      (simple-array t)
-				      *
-				      :important t)
+				      *)
   ;; KLUDGE: why the percent signs?  Well, ARRAY and INDEX are
   ;; respectively exported from the CL and SB!INT packages, which
   ;; means that they're visible to all sorts of things.  If the
@@ -260,16 +258,16 @@
 			  (setf (%raw-bits result-bit-array index)
 				(,',wordfun (%raw-bits bit-array-1 index)
 					    (%raw-bits bit-array-2 index))))))))))
- (def bit-and 32bit-logical-and)
- (def bit-ior 32bit-logical-or)
- (def bit-xor 32bit-logical-xor)
- (def bit-eqv 32bit-logical-eqv)
- (def bit-nand 32bit-logical-nand)
- (def bit-nor 32bit-logical-nor)
- (def bit-andc1 32bit-logical-andc1)
- (def bit-andc2 32bit-logical-andc2)
- (def bit-orc1 32bit-logical-orc1)
- (def bit-orc2 32bit-logical-orc2))
+ (def bit-and word-logical-and)
+ (def bit-ior word-logical-or)
+ (def bit-xor word-logical-xor)
+ (def bit-eqv word-logical-eqv)
+ (def bit-nand word-logical-nand)
+ (def bit-nor word-logical-nor)
+ (def bit-andc1 word-logical-andc1)
+ (def bit-andc2 word-logical-andc2)
+ (def bit-orc1 word-logical-orc1)
+ (def bit-orc2 word-logical-orc2))
 
 (deftransform bit-not
 	      ((bit-array result-bit-array)
@@ -284,26 +282,26 @@
 		    bit-array result-bit-array))))
     (let ((length (length result-bit-array)))
       (if (= length 0)
-	  ;; We avoid doing anything to 0-length bit-vectors, or
-	  ;; rather, the memory that follows them. Other
-	  ;; divisible-by-32 cases are handled by the (1- length),
-	  ;; below.  CSR, 2002-04-24
+	  ;; We avoid doing anything to 0-length bit-vectors, or rather,
+	  ;; the memory that follows them. Other divisible-by
+	  ;; n-word-bits cases are handled by the (1- length), below.
+	  ;; CSR, 2002-04-24
 	  result-bit-array
 	  (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
+			 ;; bit-vectors of length 1 to n-word-bits 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 result-bit-array index)
-		     (32bit-logical-not (%raw-bits bit-array index)))
+		     (word-logical-not (%raw-bits bit-array index)))
 	       result-bit-array)
 	    (declare (optimize (speed 3) (safety 0))
 		     (type index index end-1))
 	    (setf (%raw-bits result-bit-array index)
-		  (32bit-logical-not (%raw-bits bit-array index))))))))
+		  (word-logical-not (%raw-bits bit-array index))))))))
 
 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
   `(and (= (length x) (length y))
@@ -331,32 +329,73 @@
 				     (:big-endian
 				      '(- sb!vm:n-word-bits extra))))
 			     (%raw-bits y i))))
-		      (declare (type (integer 0 31) extra)
-			       (type (unsigned-byte 32) mask numx numy))
+		      (declare (type (mod #.sb!vm:n-word-bits)
+                                     extra)
+			       (type sb!vm:word mask numx numy))
 		      (= numx numy)))
 		(declare (type index i end-1))
 		(let ((numx (%raw-bits x i))
 		      (numy (%raw-bits y i)))
-		  (declare (type (unsigned-byte 32) numx numy))
+		  (declare (type sb!vm:word numx numy))
 		  (unless (= numx numy)
 		    (return nil))))))))
 
+(deftransform count ((item sequence) (bit simple-bit-vector) *
+                     :policy (>= speed space))
+  `(let ((length (length sequence)))
+    (if (zerop length)
+        0
+        (do ((index sb!vm:vector-data-offset (1+ index))
+             (count 0)
+             (end-1 (+ sb!vm:vector-data-offset
+                       (truncate (truly-the index (1- length))
+                                 sb!vm:n-word-bits))))
+            ((= index end-1)
+             (let* ((extra (mod length sb!vm:n-word-bits))
+		    (mask (1- (ash 1 extra)))
+		    (bits (logand (ash mask
+				       ,(ecase sb!c:*backend-byte-order*
+					       (:little-endian 0)
+					       (:big-endian
+						'(- sb!vm:n-word-bits extra))))
+				  (%raw-bits sequence index))))
+               (declare (type (mod #.sb!vm:n-word-bits) extra))
+               (declare (type sb!vm:word mask bits))
+               ;; could consider LOGNOT for the zero case instead of
+               ;; doing the subtraction...
+               (incf count ,(if (constant-lvar-p item)
+                                (if (zerop (lvar-value item))
+                                    '(- extra (logcount bits))
+                                    '(logcount bits))
+                                '(if (zerop item)
+                                     (- extra (logcount bits))
+                                     (logcount bits))))))
+          (declare (type index index count end-1)
+		   (optimize (speed 3) (safety 0)))
+          (incf count ,(if (constant-lvar-p item)
+                           (if (zerop (lvar-value item))
+                               '(- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
+                               '(logcount (%raw-bits sequence index)))
+                           '(if (zerop item)
+                             (- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
+                             (logcount (%raw-bits sequence index)))))))))
+
 (deftransform fill ((sequence item) (simple-bit-vector bit) *
 		    :policy (>= speed space))
   (let ((value (if (constant-lvar-p item)
 		   (if (= (lvar-value item) 0)
 		       0
-		       #.(1- (ash 1 32)))
-		   `(if (= item 0) 0 #.(1- (ash 1 32))))))
+		       #.(1- (ash 1 sb!vm:n-word-bits)))
+		   `(if (= item 0) 0 #.(1- (ash 1 sb!vm:n-word-bits))))))
     `(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
+			  ;; bit-vectors of length 1 to n-word-bits 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)
@@ -370,18 +409,21 @@
 		    :policy (>= speed space))
   (let ((value (if (constant-lvar-p item)
 		   (let* ((char (lvar-value item))
-			  (code (sb!xc:char-code char)))
-		     (logior code (ash code 8) (ash code 16) (ash code 24)))
+			  (code (sb!xc:char-code char))
+                          (accum 0))
+                     (dotimes (i sb!vm:n-word-bytes accum)
+                       (setf accum (logior accum (ash code (* 8 i))))))
 		   `(let ((code (sb!xc:char-code item)))
-		     (logior code (ash code 8) (ash code 16) (ash code 24))))))
+                     (logior ,@(loop for i from 0 below sb!vm:n-word-bytes
+                                     collect `(ash code ,(* 8 i))))))))
     `(let ((length (length sequence))
 	   (value ,value))
       (multiple-value-bind (times rem)
-	  (truncate length 4)
+	  (truncate length sb!vm:n-word-bytes)
 	(do ((index sb!vm:vector-data-offset (1+ index))
 	     (end (+ times sb!vm:vector-data-offset)))
 	    ((= index end)
-	     (let ((place (* times 4)))
+	     (let ((place (* times sb!vm:n-word-bytes)))
 	       (declare (fixnum place))
 	       (dotimes (j rem sequence)
 		 (declare (index j))
@@ -444,26 +486,67 @@
 (define-good-modular-fun logior)
 ;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
 
-#!-alpha
-(progn
-  (defknown sb!vm::ash-left-mod32 (integer (integer 0)) (unsigned-byte 32)
-            (foldable flushable movable))
-  (define-modular-fun-optimizer ash ((integer count) :width width)
-    (when (and (<= width 32)
-               (constant-lvar-p count)  ; ?
-               (plusp (lvar-value count)))
-      (cut-to-width integer width)
-      'sb!vm::ash-left-mod32)))
-#!+alpha
-(progn
-  (defknown sb!vm::ash-left-mod64 (integer (integer 0)) (unsigned-byte 64)
-            (foldable flushable movable))
-  (define-modular-fun-optimizer ash ((integer count) :width width)
-    (when (and (<= width 64)
-               (constant-lvar-p count)  ; ?
-               (plusp (lvar-value count)))
-      (cut-to-width integer width)
-      'sb!vm::ash-left-mod64)))
+(macrolet
+    ((def (name width)
+	 `(progn
+	    (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
+		      (foldable flushable movable))	   
+	    (define-modular-fun-optimizer ash ((integer count) :width width)
+	      (when (and (<= width ,width)
+			 (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)))))
+  ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
+  ;; don't have a true Alpha64 port yet, we'll have to stick to
+  ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
+  #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
+  (def sb!vm::ash-left-mod32 32)
+  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
+  (def sb!vm::ash-left-mod64 64))
+
+
+;;;; word-wise logical operations
+
+;;; These transforms assume the presence of modular arithmetic to
+;;; generate efficient code.
+
+(define-source-transform word-logical-not (x)
+  `(logand (lognot (the sb!vm:word ,x)) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-and ((x y))
+  '(logand x y))
+
+(deftransform word-logical-nand ((x y))
+  '(logand (lognand x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-or ((x y))
+  '(logior x y))
+
+(deftransform word-logical-nor ((x y))
+  '(logand (lognor x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-xor ((x y))
+  '(logxor x y))
+
+(deftransform word-logical-eqv ((x y))
+  '(logand (logeqv x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-orc1 ((x y))
+  '(logand (logorc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-orc2 ((x y))
+  '(logand (logorc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-andc1 ((x y))
+  '(logand (logandc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
+
+(deftransform word-logical-andc2 ((x y))
+  '(logand (logandc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 
 
 ;;; There are two different ways the multiplier can be recoded. The