function-name key-functions variant)))
(defun transform-list-item-seek (name item list key test test-not node)
+ (when (and test test-not)
+ (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name))
;; If TEST is EQL, drop it.
(when (and test (lvar-fun-is test '(eql)))
(setf test nil))
(kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
((member element-type '(character base-char)) :char)
((eq element-type 'single-float) :single-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((eq element-type 'double-float) :double-float)
- (t :bits)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((equal element-type '(complex single-float))
+ :complex-single-float)
+ (t
+ (aver (integer-type-p element-ctype))
+ :bits)))
;; BASH-VALUE is a word that we can repeatedly smash
;; on the array: for less-than-word sized elements it
;; contains multiple copies of the fill item.
tmp)
(:single-float
(single-float-bits tmp))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(:double-float
(logior (ash (double-float-high-bits tmp) 32)
- (double-float-low-bits tmp))))))
+ (double-float-low-bits tmp)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ (logior (ash (single-float-bits (imagpart tmp)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart tmp))))))))
(res bits))
(loop for i of-type sb!vm:word from n-bits by n-bits
until (= i sb!vm:n-word-bits)
do (setf res (ldb (byte sb!vm:n-word-bits 0)
(logior res (ash bits i)))))
res))
- `(let* ((bits (ldb (byte ,n-bits 0)
- ,(ecase kind
- (:tagged
- `(ash item ,sb!vm:n-fixnum-tag-bits))
- (:char
- `(char-code item))
- (:bits
- `item)
- (:single-float
- `(single-float-bits item))
- (:double-float
- `(logior (ash (double-float-high-bits item) 32)
- (double-float-low-bits item))))))
- (res bits))
- (declare (type sb!vm:word res))
- ,@(unless (= sb!vm:n-word-bits n-bits)
- `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
- until (= i sb!vm:n-word-bits)
- do (setf res
- (ldb (byte ,sb!vm:n-word-bits 0)
- (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
- res))))
+ (progn
+ (delay-ir1-transform node :constraint)
+ `(let* ((bits (ldb (byte ,n-bits 0)
+ ,(ecase kind
+ (:tagged
+ `(ash item ,sb!vm:n-fixnum-tag-bits))
+ (:char
+ `(char-code item))
+ (:bits
+ `item)
+ (:single-float
+ `(single-float-bits item))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:double-float
+ `(logior (ash (double-float-high-bits item) 32)
+ (double-float-low-bits item)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ `(logior (ash (single-float-bits (imagpart item)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart item))))))))
+ (res bits))
+ (declare (type sb!vm:word res))
+ ,@(unless (= sb!vm:n-word-bits n-bits)
+ `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res
+ (ldb (byte ,sb!vm:n-word-bits 0)
+ (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
+ res)))))
(values
`(with-array-data ((data seq)
(start start)
'(%find-position-vector-macro item sequence
from-end start end key test))
+(deftransform %find-position ((item sequence from-end start end key test)
+ (character string t t t function function)
+ *
+ :policy (> speed space))
+ (if (eq '* (upgraded-element-type-specifier sequence))
+ (let ((form
+ `(sb!impl::string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (simple-array nil (*)))
+ sequence
+ (%find-position item sequence from-end start end key test))))
+ (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string))
+ form
+ ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from
+ ;; %FIND-POSITION.
+ `(with-array-data ((sequence sequence :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (multiple-value-bind (elt index) ,form
+ (values elt (when (fixnump index) (- index offset)))))))
+ ;; The type is known exactly, other transforms will take care of it.
+ (give-up-ir1-transform)))
+
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.
(define-source-transform effective-find-position-test (test test-not)
projects / sbcl.git / blobdiff