0.8.20.2:

[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 5a1fa68..36d4227 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -36,6 +36,7 @@
 ;;;; character support
 
 ;;; In our implementation there are really only BASE-CHARs.
+#+nil
 (define-source-transform characterp (obj)
   `(base-char-p ,obj))
 \f
@@ -48,6 +49,8 @@
        (give-up-ir1-transform)
        `(etypecase string
          ((simple-array character (*)) (data-vector-ref string index))
+          #!+sb-unicode
+         ((simple-array base-char (*)) (data-vector-ref string index))
          ((simple-array nil (*)) (data-vector-ref string index))))))
 
 (deftransform hairy-data-vector-ref ((array index) (array t) *)
@@ -98,6 +101,9 @@
        `(etypecase string
          ((simple-array character (*))
           (data-vector-set string index new-value))
+          #!+sb-unicode
+         ((simple-array base-char (*))
+          (data-vector-set string index new-value))
          ((simple-array nil (*))
           (data-vector-set string index new-value))))))
 
@@ -228,7 +234,7 @@
                                          (length bit-array-2)
                                           (length result-bit-array))
                                  (error "Argument and/or result bit arrays are not the same length:~
-                        ~%  ~S~%  ~S  ~%  ~S"
+                         ~%  ~S~%  ~S  ~%  ~S"
                                         bit-array-1
                                        bit-array-2
                                        result-bit-array))))
@@ -278,7 +284,7 @@
         '((unless (= (length bit-array)
                      (length result-bit-array))
             (error "Argument and result bit arrays are not the same length:~
-                    ~%  ~S~%  ~S"
+                     ~%  ~S~%  ~S"
                    bit-array result-bit-array))))
     (let ((length (length result-bit-array)))
       (if (= length 0)
@@ -311,8 +317,9 @@
                    (end-1 (+ sb!vm:vector-data-offset
                              (floor (1- length) sb!vm:n-word-bits))))
                   ((= i end-1)
-                   (let* ((extra (mod length sb!vm:n-word-bits))
-                          (mask (1- (ash 1 extra)))
+                   (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+                          (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+                                     (- extra sb!vm:n-word-bits)))
                           (numx
                            (logand
                             (ash mask
@@ -329,8 +336,7 @@
                                     (:big-endian
                                      '(- sb!vm:n-word-bits extra))))
                             (%raw-bits y i))))
-                     (declare (type (mod #.sb!vm:n-word-bits)
-                                     extra)
+                     (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
                               (type sb!vm:word mask numx numy))
                      (= numx numy)))
                (declare (type index i end-1))
@@ -351,15 +357,16 @@
                        (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)))
+             (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+                   (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+                              (- extra sb!vm:n-word-bits)))
                    (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 (integer 1 #.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...
@@ -482,26 +489,39 @@
 
 \f
 ;;;; modular functions
-(define-good-modular-fun logand)
-(define-good-modular-fun logior)
+(define-good-modular-fun logand :unsigned)
+(define-good-modular-fun logior :unsigned)
 ;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
 
 (macrolet
-    ((def (name width)
+    ((def (name class width)
+       (let ((type (ecase class
+                     (:unsigned 'unsigned-byte)
+                     (:signed 'signed-byte))))
         `(progn
-           (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
+           (defknown ,name (integer (integer 0)) (,type ,width)
                      (foldable flushable movable))
-           (define-modular-fun-optimizer ash ((integer count) :width width)
+           (define-modular-fun-optimizer ash ((integer count) ,class :width width)
              (when (and (<= width ,width)
-                        (constant-lvar-p count) ;?
-                        (plusp (lvar-value count)))
-               (cut-to-width integer 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 ,class width)
                ',name))
-           (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
-  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-  (def sb!vm::ash-left-mod32 32)
-  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-  (def sb!vm::ash-left-mod64 64))
+            (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+                  `(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))
+  (progn
+    #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
+    (def sb!vm::ash-left-mod32 :unsigned 32))
+  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
+  (progn
+    #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61)
+    (def sb!vm::ash-left-mod64 :unsigned 64)))
 
 \f
 ;;;; word-wise logical operations