\f
;;;; 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)))
+ (if (array-type-p ctype)
+ ;; the other transform will kick in, so that's OK
+ (give-up-ir1-transform)
+ `(typecase 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) * :important t)
"avoid runtime dispatch on array element type"
(let ((element-ctype (extract-upgraded-element-type array)))
index
new-value)))))
+(deftransform hairy-data-vector-set ((string index new-value)
+ (simple-string t t))
+ (let ((ctype (continuation-type string)))
+ (if (array-type-p ctype)
+ ;; the other transform will kick in, so that's OK
+ (give-up-ir1-transform)
+ `(typecase string
+ ((simple-array character (*))
+ (data-vector-set string index new-value))
+ ((simple-array nil (*))
+ (data-vector-set string index new-value))))))
+
(deftransform data-vector-set ((array index new-value)
(simple-array t t))
(let ((array-type (continuation-type array)))
(*))
index)))))
-(deftransform %data-vector-and-index ((array index)
- (simple-array t)
- *
- :important t)
+(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
+ ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
+ ;; returns T or NIL, it will delete the irrelevant branch. However,
+ ;; user code might have got here with a variable named CL:ARRAY, and
+ ;; quite often compiler code with a variable named SB!INT:INDEX, so
+ ;; this can generate code deletion notes for innocuous user code:
+ ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
+ ;; -- CSR, 2003-04-01
;; We do this solely for the -OR-GIVE-UP side effect, since we want
;; to know that the type can be figured out in the end before we
;; proceed, but we don't care yet what the type will turn out to be.
- (upgraded-element-type-specifier-or-give-up array)
+ (upgraded-element-type-specifier-or-give-up %array)
- '(if (array-header-p array)
- (values (%array-data-vector array) index)
- (values array index)))
+ '(if (array-header-p %array)
+ (values (%array-data-vector %array) %index)
+ (values %array %index)))
;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
;;;
(type index index end-1))
(setf (%raw-bits result-bit-array index)
(32bit-logical-not (%raw-bits bit-array index))))))))
+
+(deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
+ `(and (= (length x) (length y))
+ (let ((length (length x)))
+ (or (= length 0)
+ (do* ((i sb!vm:vector-data-offset (+ i 1))
+ (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)))
+ (numx
+ (logand
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian
+ '(- sb!vm:n-word-bits extra))))
+ (%raw-bits x i)))
+ (numy
+ (logand
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (: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))
+ (= 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))
+ (unless (= numx numy)
+ (return nil))))))))
\f
;;;; %BYTE-BLT
(memmove (sap+ (sapify dst) dst-start)
(sap+ (sapify src) src-start)
(- dst-end dst-start)))
- nil))
+ (values)))
\f
;;;; transforms for EQL of floating point values