;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
(deftransform hairy-data-vector-ref ((string index) (simple-string t))
- (let ((ctype (continuation-type string)))
+ (let ((ctype (lvar-type string)))
(if (array-type-p ctype)
;; the other transform will kick in, so that's OK
(give-up-ir1-transform)
((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)))
(deftransform data-vector-ref ((array index)
(simple-array t))
- (let ((array-type (continuation-type array)))
+ (let ((array-type (lvar-type array)))
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
(deftransform hairy-data-vector-set ((string index new-value)
(simple-string t t))
- (let ((ctype (continuation-type string)))
+ (let ((ctype (lvar-type string)))
(if (array-type-p ctype)
;; the other transform will kick in, so that's OK
(give-up-ir1-transform)
(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-set ((array index new-value)
(simple-array t t))
- (let ((array-type (continuation-type array)))
+ (let ((array-type (lvar-type array)))
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
new-value)))))
(defoptimizer (%data-vector-and-index derive-type) ((array index))
- (let ((atype (continuation-type array)))
+ (let ((atype (lvar-type array)))
(when (array-type-p atype)
(values-specifier-type
`(values (simple-array ,(type-specifier
(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
(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)
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))
'(- sb!vm:n-word-bits extra))))
(%raw-bits y i))))
(declare (type (integer 0 31) extra)
- (type (unsigned-byte 32) mask numx numy))
+ (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 ((sequence item) (simple-bit-vector bit) *
+ :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 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-continuation-p item)
- (if (= (continuation-value item) 0)
+ (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))))))
(deftransform fill ((sequence item) (simple-base-string base-char) *
:policy (>= speed space))
- (let ((value (if (constant-continuation-p item)
- (let* ((char (continuation-value item))
+ (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)))
`(let ((code (sb!xc:char-code item)))
(= (double-float-high-bits x) (double-float-high-bits y))))
\f
-;;;; 32-bit operations
-#!-(or ppc x86) ; on X86 it is a modular function
-(deftransform lognot ((x) ((unsigned-byte 32)) *
- :node node
- :result result)
- "32-bit implementation"
- (let ((dest (continuation-dest result)))
- (unless (and (combination-p dest)
- (eq (continuation-fun-name (combination-fun dest))
- 'logand))
- (give-up-ir1-transform))
- (unless (some (lambda (arg)
- (csubtypep (continuation-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
;;; the high order bit is bit 31 because shifting by 32 doesn't work
;;; too well.
(defun ub32-strength-reduce-constant-multiply (arg num)
- (declare (type (unsigned-byte 32) numb))
+ (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
(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))))
(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)))