\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)))
;; to hand-expand it ourselves.)
(let ((element-type-specifier (type-specifier element-ctype)))
`(multiple-value-bind (array index)
- ;; FIXME: All this noise should move into a
- ;; %DATA-VECTOR-AND-INDEX function, and there should be
- ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the
- ;; function call away when the array is known to be simple,
- ;; and to specialize to
- ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is
- ;; known to have only one dimension.
- (if (array-header-p array)
- (%with-array-data array index nil)
- (let ((array array))
- (declare (type (simple-array ,element-type-specifier 1)
- array))
- (values array index)))
+ (%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array))
(data-vector-ref array index)))))
"Upgraded element type of array is not known at compile time."))
(let ((element-type-specifier (type-specifier element-ctype)))
`(multiple-value-bind (array index)
- ;; FIXME: All this noise should move into a
- ;; %DATA-VECTOR-AND-INDEX function, and there should be
- ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the
- ;; function call away when the array is known to be simple,
- ;; and to specialize to
- ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is
- ;; known to have only one dimension.
- (if (array-header-p array)
- (%with-array-data array index nil)
- (let ((array array))
- (declare (type (simple-array ,element-type-specifier 1)
- array))
- (values array index)))
- (data-vector-set (truly-the (simple-array ,element-type-specifier 1)
- array)
+ (%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)))))
+(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
new-value)))))
+(defoptimizer (%data-vector-and-index derive-type) ((array index))
+ (let ((atype (continuation-type array)))
+ (when (array-type-p atype)
+ (values-specifier-type
+ `(values (simple-array ,(type-specifier
+ (array-type-specialized-element-type atype))
+ (*))
+ index)))))
+
+(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)
+
+ '(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)
;;;
;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
(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