X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=1d93ebafc282f4f0c6400c147afeb489a4301110;hb=f8893c7c658bf9d9e0757c63e47af2fdea810f04;hp=8280a8debc894f277baeb51cfc5b9454d0d21649;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 8280a8d..1d93eba 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -439,28 +439,32 @@
 	(= (double-float-high-bits x) (double-float-high-bits y))))
 
 
-;;;; 32-bit operations
-#!-x86 ; on X86 it is a modular function
-(deftransform lognot ((x) ((unsigned-byte 32)) *
-                      :node node
-                      :result result)
-  "32-bit implementation"
-  (let ((dest (lvar-dest result)))
-    (unless (and (combination-p dest)
-                 (eq (lvar-fun-name (combination-fun dest))
-                     'logand))
-      (give-up-ir1-transform))
-    (unless (some (lambda (arg)
-                    (csubtypep (lvar-type arg)
-                               (specifier-type '(unsigned-byte 32))))
-                  (combination-args dest))
-      (give-up-ir1-transform))
-    (setf (node-derived-type node)
-          (values-specifier-type '(values (unsigned-byte 32) &optional)))
-    '(32bit-logical-not x)))
-
+;;;; modular functions
 (define-good-modular-fun logand)
 (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)))
+
 
 ;;; 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
@@ -474,13 +478,11 @@
   (declare (type (unsigned-byte 32) num))
   (let ((adds 0) (shifts 0)
 	(result nil) first-one)
-    (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
-	     (add (next-factor)
+    (labels ((add (next-factor)
 	       (setf result
-		     (tub32
-		      (if result
-			  (progn (incf adds) `(+ ,result ,(tub32 next-factor)))
-			  next-factor)))))
+		     (if result
+                         (progn (incf adds) `(+ ,result ,next-factor))
+                         next-factor))))
       (declare (inline add))
       (dotimes (bitpos 32)
 	(if first-one
@@ -492,8 +494,8 @@
 		       (progn
 			 (incf adds)
 			 (incf shifts 2)
-			 `(- ,(tub32 `(ash ,arg ,bitpos))
-			     ,(tub32 `(ash ,arg ,first-one))))))
+			 `(- (ash ,arg ,bitpos)
+			     (ash ,arg ,first-one)))))
 	      (setf first-one nil))
 	    (when (logbitp bitpos num)
 	      (setf first-one bitpos))))
@@ -503,8 +505,12 @@
 	      (t
 	       (incf shifts 2)
 	       (incf adds)
-	       (add `(- ,(tub32 `(ash ,arg 31)) 
-			,(tub32 `(ash ,arg ,first-one))))))
+	       (add `(- (ash ,arg 31)
+			(ash ,arg ,first-one)))))
 	(incf shifts)
 	(add `(ash ,arg 31))))
-    (values result adds shifts)))
+    (values (if (plusp adds)
+                `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
+                result)
+            adds
+            shifts)))