(or end length)
(sequence-bounding-indices-bad-error vector start end)))))
-(deftype eq-comparable-type ()
+(def!type eq-comparable-type ()
'(or fixnum (not number)))
;;; True if EQL comparisons involving type can be simplified to EQ.
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))
(vector t &key (:start t) (:end t))
*
:node node)
- (let ((type (lvar-type seq))
- (element-type (type-specifier (extract-upgraded-element-type seq))))
- (cond ((and (neq '* element-type) (policy node (> speed space)))
+ (let* ((type (lvar-type seq))
+ (element-ctype (array-type-upgraded-element-type type))
+ (element-type (type-specifier element-ctype))
+ (saetp (unless (eq *wild-type* element-ctype)
+ (find-saetp-by-ctype element-ctype))))
+ (cond ((eq *wild-type* element-ctype)
+ (delay-ir1-transform node :constraint)
+ `(vector-fill* seq item start end))
+ ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp))
+ (let* ((n-bits (sb!vm:saetp-n-bits saetp))
+ (basher-name (format nil "UB~D-BASH-FILL" n-bits))
+ (basher (or (find-symbol basher-name
+ (load-time-value (find-package :sb!kernel)))
+ (abort-ir1-transform
+ "Unknown fill basher, please report to sbcl-devel: ~A"
+ basher-name)))
+ (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)
+ #!+#.(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.
+ (bash-value
+ (if (constant-lvar-p item)
+ (let ((tmp (lvar-value item)))
+ (unless (ctypep tmp element-ctype)
+ (abort-ir1-transform "~S is not ~S" tmp element-type))
+ (let* ((bits
+ (ldb (byte n-bits 0)
+ (ecase kind
+ (:tagged
+ (ash tmp sb!vm:n-fixnum-tag-bits))
+ (:char
+ (char-code tmp))
+ (:bits
+ 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)))
+ #!+#.(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))
+ (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)
+ (end end)
+ :check-fill-pointer t)
+ (declare (type (simple-array ,element-type 1) data))
+ (declare (type index start end))
+ (declare (optimize (safety 0) (speed 3))
+ (muffle-conditions compiler-note))
+ (,basher ,bash-value data start (- end start))
+ seq)
+ `((declare (type ,element-type item))))))
+ ((policy node (> speed space))
(values
`(with-array-data ((data seq)
(start start)
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-(eval-when (:compile-toplevel)
-(defun valid-bit-bash-saetp-p (saetp)
- ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
- (and (not (eq t (sb!vm:saetp-specifier saetp)))
- ;; Disallowing (VECTOR NIL) also means that we won't transform
- ;; sequence functions into bit-bashing code and we let the
- ;; generic sequence functions signal errors if necessary.
- (not (zerop (sb!vm:saetp-n-bits saetp)))
- ;; Due to limitations with the current BIT-BASHing code, we can't
- ;; BIT-BASH reliably on arrays whose element types are larger
- ;; than the word size.
- (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
-) ; EVAL-WHEN
-
;;; FIXME: In the copy loops below, we code the loops in a strange
;;; fashion:
;;;
(unless (<= 0 start2 end2 len2)
(sequence-bounding-indices-bad-error seq2 start2 end2))))
,',(cond
- ((and saetp (valid-bit-bash-saetp-p saetp))
+ ((and saetp (sb!vm:valid-bit-bash-saetp-p saetp))
(let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
(bash-function (intern (format nil "UB~D-BASH-COPY"
n-element-bits)
;;; this transform to non-strings, but I chose to just do the case that
;;; should cover 95% of CONCATENATE performance complaints for now.
;;; -- JES, 2007-11-17
+;;;
+;;; Only handle the simple result type cases. If somebody does (CONCATENATE
+;;; '(STRING 6) ...) their code won't be optimized, but nobody does that in
+;;; practice.
(deftransform concatenate ((result-type &rest lvars)
- (symbol &rest sequence)
- *
- :policy (> speed space))
- (unless (constant-lvar-p result-type)
- (give-up-ir1-transform))
- (let* ((element-type (let ((type (lvar-value result-type)))
- ;; Only handle the simple result type cases. If
- ;; somebody does (CONCATENATE '(STRING 6) ...)
- ;; their code won't be optimized, but nobody does
- ;; that in practice.
- (case type
- ((string simple-string) 'character)
- ((base-string simple-base-string) 'base-char)
- (t (give-up-ir1-transform)))))
- (vars (loop for x in lvars collect (gensym)))
- (lvar-values (loop for lvar in lvars
- collect (when (constant-lvar-p lvar)
- (lvar-value lvar))))
- (lengths
- (loop for value in lvar-values
- for var in vars
- collect (if value
- (length value)
- `(sb!impl::string-dispatch ((simple-array * (*))
- sequence)
- ,var
- (declare (muffle-conditions compiler-note))
- (length ,var))))))
- `(apply
- (lambda ,vars
- (declare (ignorable ,@vars))
- (let* ((.length. (+ ,@lengths))
- (.pos. 0)
- (.string. (make-string .length. :element-type ',element-type)))
- (declare (type index .length. .pos.)
- (muffle-conditions compiler-note))
- ,@(loop for value in lvar-values
- for var in vars
- collect (if (stringp value)
- ;; Fold the array reads for constant arguments
- `(progn
- ,@(loop for c across value
- collect `(setf (aref .string.
- .pos.) ,c)
- collect `(incf .pos.)))
- `(sb!impl::string-dispatch
- (#!+sb-unicode
- (simple-array character (*))
- (simple-array base-char (*))
- t)
- ,var
- (replace .string. ,var :start1 .pos.)
- (incf .pos. (length ,var)))))
- .string.))
- lvars)))
+ ((constant-arg
+ (member string simple-string base-string simple-base-string))
+ &rest sequence)
+ * :node node)
+ (let ((vars (loop for x in lvars collect (gensym)))
+ (type (lvar-value result-type)))
+ (if (policy node (<= speed space))
+ ;; Out-of-line
+ `(lambda (.dummy. ,@vars)
+ (declare (ignore .dummy.))
+ ,(ecase type
+ ((string simple-string)
+ `(%concatenate-to-string ,@vars))
+ ((base-string simple-base-string)
+ `(%concatenate-to-base-string ,@vars))))
+ ;; Inline
+ (let* ((element-type (ecase type
+ ((string simple-string) 'character)
+ ((base-string simple-base-string) 'base-char)))
+ (lvar-values (loop for lvar in lvars
+ collect (when (constant-lvar-p lvar)
+ (lvar-value lvar))))
+ (lengths
+ (loop for value in lvar-values
+ for var in vars
+ collect (if value
+ (length value)
+ `(sb!impl::string-dispatch ((simple-array * (*))
+ sequence)
+ ,var
+ (declare (muffle-conditions compiler-note))
+ (length ,var))))))
+ `(apply
+ (lambda ,vars
+ (declare (ignorable ,@vars))
+ (let* ((.length. (+ ,@lengths))
+ (.pos. 0)
+ (.string. (make-string .length. :element-type ',element-type)))
+ (declare (type index .length. .pos.)
+ (muffle-conditions compiler-note))
+ ,@(loop for value in lvar-values
+ for var in vars
+ collect (if (stringp value)
+ ;; Fold the array reads for constant arguments
+ `(progn
+ ,@(loop for c across value
+ collect `(setf (aref .string.
+ .pos.) ,c)
+ collect `(incf .pos.)))
+ `(sb!impl::string-dispatch
+ (#!+sb-unicode
+ (simple-array character (*))
+ (simple-array base-char (*))
+ t)
+ ,var
+ (replace .string. ,var :start1 .pos.)
+ (incf .pos. (length ,var)))))
+ .string.))
+ lvars)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
'(%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