\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)
+ `(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) * :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
`(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))
(%array-data-vector array))
index)))))
+(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)
+ `(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))
(*))
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)
;;;
(declare (type (unsigned-byte 32) numx numy))
(unless (= numx numy)
(return nil))))))))
+
+;;; FIXME: it is probably worth doing something like this for
+;;; SIMPLE-BASE-STRINGs too, if only so that (MAKE-STRING 100000
+;;; :INITIAL-ELEMENT #\Space) doesn't surprise the user with its
+;;; performance characteristics. Getting it right is harder than with
+;;; bit-vectors, though, as one needs to be more careful with the loop
+;;; epilogue so as not to overwrite the convenient extra null byte
+;;; (for SB-ALIEN/C termination convention convenience).
+(deftransform fill ((sequence item) (simple-bit-vector bit) *
+ :policy (>= speed space))
+ (let ((value (if (constant-continuation-p item)
+ (if (= (continuation-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))))))
\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
'(and (= (double-float-low-bits x) (double-float-low-bits y))
(= (double-float-high-bits x) (double-float-high-bits y))))
+\f
+;;;; 32-bit operations
+#!-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)))
+
+(define-good-modular-fun logand)
+(define-good-modular-fun logior)
projects / sbcl.git / blobdiff