0.8.12:

[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 8280a8d..baf07fc 100644 (file)
--- 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
@@ -439,28 +437,25 @@
        (= (double-float-high-bits x) (double-float-high-bits y))))
 
 \f
-;;;; 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
+
+(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 32)
+                        (constant-lvar-p count) ;?
+                        (plusp (lvar-value count)))
+               (cut-to-width integer width)
+               ',name))
+           (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
+  #!-alpha (def sb!vm::ash-left-mod32 32)
+  #!+alpha (def sb!vm::ash-left-mod64 64))
 \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
@@ -474,13 +469,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 +485,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 +496,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)))