;;;; character support
;;; In our implementation there are really only BASE-CHARs.
+#+nil
(define-source-transform characterp (obj)
`(base-char-p ,obj))
\f
(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) * :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)))
`(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))))))
(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)))
(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
(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))))
(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)
'((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)
- ;; 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))
(: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)
: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))
(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))
+
+\f
+;;;; 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))))
\f
;;; There are two different ways the multiplier can be recoded. The