\f
;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
-(deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
+(deftransform hairy-data-vector-ref ((string index) (simple-string t))
+ (let ((ctype (lvar-type string)))
+ (if (array-type-p ctype)
+ ;; the other transform will kick in, so that's OK
+ (give-up-ir1-transform)
+ `(etypecase string
+ ((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) *)
"avoid runtime dispatch on array element type"
- (let ((element-ctype (extract-upgraded-element-type array)))
+ (let ((element-ctype (extract-upgraded-element-type array))
+ (declared-element-ctype (extract-declared-element-type array)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
`(multiple-value-bind (array index)
(%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array))
- (data-vector-ref array index)))))
+ ,(let ((bare-form '(data-vector-ref array index)))
+ (if (type= element-ctype declared-element-ctype)
+ bare-form
+ `(the ,(type-specifier declared-element-ctype)
+ ,bare-form)))))))
(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)))
(%array-data-vector array))
index)))))
+(deftransform hairy-data-vector-set ((string index new-value)
+ (simple-string t t))
+ (let ((ctype (lvar-type string)))
+ (if (array-type-p ctype)
+ ;; the other transform will kick in, so that's OK
+ (give-up-ir1-transform)
+ `(etypecase string
+ ((simple-array character (*))
+ (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)))
+ (let ((element-ctype (extract-upgraded-element-type array))
+ (declared-element-ctype (extract-declared-element-type array)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
(%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array)
(type ,element-type-specifier new-value))
- (data-vector-set array
- index
- new-value)))))
+ ,(if (type= element-ctype declared-element-ctype)
+ '(data-vector-set array index new-value)
+ `(truly-the ,(type-specifier declared-element-ctype)
+ (data-vector-set array index
+ (the ,(type-specifier declared-element-ctype)
+ new-value))))))))
(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
(declare (type (unsigned-byte 32) numx numy))
(unless (= numx numy)
(return nil))))))))
+
+(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))))))
+ `(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
+ (truncate (truly-the index (1- length))
+ sb!vm:n-word-bits))))
+ ((= index end-1)
+ (setf (%raw-bits sequence index) value)
+ sequence)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end-1))
+ (setf (%raw-bits sequence index) value))))))
+
+(deftransform fill ((sequence item) (simple-base-string base-char) *
+ :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)))
+ `(let ((code (sb!xc:char-code item)))
+ (logior code (ash code 8) (ash code 16) (ash code 24))))))
+ `(let ((length (length sequence))
+ (value ,value))
+ (multiple-value-bind (times rem)
+ (truncate length 4)
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end (+ times sb!vm:vector-data-offset)))
+ ((= index end)
+ (let ((place (* times 4)))
+ (declare (fixnum place))
+ (dotimes (j rem sequence)
+ (declare (index j))
+ (setf (schar sequence (the index (+ place j))) item))))
+ (declare (optimize (speed 3) (safety 0))
+ (type index index))
+ (setf (%raw-bits sequence index) value))))))
\f
;;;; %BYTE-BLT
'(and (= (double-float-low-bits x) (double-float-low-bits y))
(= (double-float-high-bits x) (double-float-high-bits y))))
+\f
+;;;; 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
+;;; in Y and to sum the results. But if there is a string of bits that
+;;; are all set, you can add X shifted by one more then the bit
+;;; position of the first set bit and subtract X shifted by the bit
+;;; position of the last set bit. We can't use this second method when
+;;; 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) num))
+ (let ((adds 0) (shifts 0)
+ (result nil) first-one)
+ (labels ((add (next-factor)
+ (setf result
+ (if result
+ (progn (incf adds) `(+ ,result ,next-factor))
+ next-factor))))
+ (declare (inline add))
+ (dotimes (bitpos 32)
+ (if first-one
+ (when (not (logbitp bitpos num))
+ (add (if (= (1+ first-one) bitpos)
+ ;; There is only a single bit in the string.
+ (progn (incf shifts) `(ash ,arg ,first-one))
+ ;; There are at least two.
+ (progn
+ (incf adds)
+ (incf shifts 2)
+ `(- (ash ,arg ,bitpos)
+ (ash ,arg ,first-one)))))
+ (setf first-one nil))
+ (when (logbitp bitpos num)
+ (setf first-one bitpos))))
+ (when first-one
+ (cond ((= first-one 31))
+ ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
+ (t
+ (incf shifts 2)
+ (incf adds)
+ (add `(- (ash ,arg 31)
+ (ash ,arg ,first-one)))))
+ (incf shifts)
+ (add `(ash ,arg 31))))
+ (values (if (plusp adds)
+ `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
+ result)
+ adds
+ shifts)))
projects / sbcl.git / blobdiff