(deftransform %check-vector-sequence-bounds ((vector start end)
(vector * *) *
:node node)
- (if (policy node (< safety speed))
+ (if (policy node (= 0 insert-array-bounds-checks))
'(or end (length vector))
'(let ((length (length vector)))
- (if (<= 0 start (or end length) length)
- (or end length)
- (sb!impl::signal-bounding-indices-bad-error vector start end)))))
-
-
-(deftransform member ((item list &key key test test-not) * * :node node)
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sb!impl::signal-bounding-indices-bad-error vector start end)))))
+
+(defun specialized-list-seek-function-name (function-name key-functions)
+ (or (find-symbol (with-output-to-string (s)
+ ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
+ ;; this ever so slightly faster then FORMAT, this
+ ;; way we are also proof against *PRINT-CASE*
+ ;; frobbing and such.
+ (write-char #\% s)
+ (write-string (symbol-name function-name) s)
+ (dolist (f key-functions)
+ (write-char #\- s)
+ (write-string (symbol-name f) s)))
+ (load-time-value (find-package "SB!KERNEL")))
+ (bug "Unknown list item seek transform: name=~S, key-functions=~S"
+ function-name key-functions)))
+
+(defun transform-list-item-seek (name list key test test-not node)
;; Key can legally be NIL, but if it's NIL for sure we pretend it's
;; not there at all. If it might be NIL, make up a form to that
;; ensure it is a function.
#'identity)))
(t
(values key '(%coerce-callable-to-fun key))))))
- (multiple-value-bind (out-of-line funs test-expr)
- (cond ((and (not key) (not test) (not test-not))
- (values '%member
- '()
- '(eql item car)))
- ((and key (not test) (not test-not))
- (values '%member-key
- '(key)
- '(eql item (%funcall key car))))
- ((and key test)
- (values '%member-key-test
- '(key test)
- '(%funcall test item (%funcall key car))))
- ((and key test-not)
- (values '%member-key-test-not
- '(key test-not)
- '(not (%funcall test-not item (%funcall key car)))))
- (test
- (values '%member-test
- '(test)
- '(%funcall test item car)))
- (test-not
- (values '%member-test-not
- '(test-not)
- '(not (%funcall test item car))))
- (t
- (bug "never")))
+ (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
+ (test-not 'test-not)))))
+ (target-expr (if key '(%funcall key target) 'target))
+ (test-expr (cond (test `(%funcall test item ,target-expr))
+ (test-not `(not (%funcall test-not item ,target-expr)))
+ (t `(eql item ,target-expr)))))
(labels ((open-code (tail)
(when tail
- `(if (let ((car ',(car tail)))
- ,test-expr)
- ',tail
+ `(if (let ((this ',(car tail)))
+ ,(ecase name
+ (assoc
+ `(and this (let ((target (car this)))
+ ,test-expr)))
+ (member
+ `(let ((target this))
+ ,test-expr))))
+ ',(ecase name
+ (assoc (car tail))
+ (member tail))
,(open-code (cdr tail)))))
(ensure-fun (fun)
(if (eq 'key fun)
key-form
`(%coerce-callable-to-fun ,fun))))
- (if (and (constant-lvar-p list) (policy node (>= speed space)))
- `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
- ,(open-code (lvar-value list)))
- `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))
+ (let* ((cp (constant-lvar-p list))
+ (c-list (when cp (lvar-value list))))
+ (cond ((and cp c-list (policy node (>= speed space)))
+ `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+ ,(open-code c-list)))
+ ((and cp (not c-list))
+ ;; constant nil list -- nothing to find!
+ nil)
+ (t
+ ;; specialized out-of-line version
+ `(,(specialized-list-seek-function-name name funs)
+ item list ,@(mapcar #'ensure-fun funs)))))))))
+
+(deftransform member ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek 'member list key test test-not node))
+
+(deftransform assoc ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek 'assoc list key test test-not node))
(deftransform memq ((item list) (t (constant-arg list)))
(labels ((rec (tail)
nil)))
(rec (lvar-value list))))
-;;; FIXME: We have rewritten the original code that used DOLIST to this
-;;; more natural MACROLET. However, the original code suggested that when
-;;; this was done, a few bytes could be saved by a call to a shared
-;;; function. This remains to be done.
-(macrolet ((def (fun eq-fun)
- `(deftransform ,fun ((item list &key test) (t list &rest t) *)
- "convert to EQ test"
- ;; FIXME: The scope of this transformation could be
- ;; widened somewhat, letting it work whenever the test is
- ;; 'EQL and we know from the type of ITEM that it #'EQ
- ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
- ;; and SYMBOL.)
- ;; If TEST is EQ, apply transform, else
- ;; if test is not EQL, then give up on transform, else
- ;; if ITEM is not a NUMBER or is a FIXNUM, apply
- ;; transform, else give up on transform.
- (cond (test
- (unless (lvar-fun-is test '(eq))
- (give-up-ir1-transform)))
- ((types-equal-or-intersect (lvar-type item)
- (specifier-type 'number))
- (give-up-ir1-transform "Item might be a number.")))
- `(,',eq-fun item list))))
- (def delete delq)
- (def assoc assq)
- (def member memq))
+;;; A similar transform used to apply to MEMBER and ASSOC, but since
+;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform
+;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be
+;;; almost as fast as MEMQ.
+(deftransform delete ((item list &key test) (t list &rest t) *)
+ "convert to EQ test"
+ ;; FIXME: The scope of this transformation could be
+ ;; widened somewhat, letting it work whenever the test is
+ ;; 'EQL and we know from the type of ITEM that it #'EQ
+ ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
+ ;; and SYMBOL.)
+ ;; If TEST is EQ, apply transform, else
+ ;; if test is not EQL, then give up on transform, else
+ ;; if ITEM is not a NUMBER or is a FIXNUM, apply
+ ;; transform, else give up on transform.
+ (cond (test
+ (unless (lvar-fun-is test '(eq))
+ (give-up-ir1-transform)))
+ ((types-equal-or-intersect (lvar-type item)
+ (specifier-type 'number))
+ (give-up-ir1-transform "Item might be a number.")))
+ `(delq item list))
(deftransform delete-if ((pred list) (t list))
"open code"
(values
`(with-array-data ((data seq)
(start start)
- (end end))
+ (end end)
+ :check-fill-pointer t)
(declare (type (simple-array ,element-type 1) data))
(declare (type fixnum start end))
(do ((i start (1+ i)))
;;; you tweak it, make sure that you compare the disassembly, if not the
;;; performance of, the functions implementing string streams
;;; (e.g. SB!IMPL::STRING-OUCH).
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-replace-transform (saetp sequence-type1 sequence-type2)
+ `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
+ (,sequence-type1 ,sequence-type2 &rest t)
+ ,sequence-type1
+ :node node)
+ ,(cond
+ ((and saetp (valid-bit-bash-saetp-p saetp)) nil)
+ ;; If the sequence types are different, SEQ1 and SEQ2 must
+ ;; be distinct arrays, and we can open code the copy loop.
+ ((not (eql sequence-type1 sequence-type2)) nil)
+ ;; If we're not bit-bashing, only allow cases where we
+ ;; can determine the order of copying up front. (There
+ ;; are actually more cases we can handle if we know the
+ ;; amount that we're copying, but this handles the
+ ;; common cases.)
+ (t '(unless (= (constant-value-or-lose start1 0)
+ (constant-value-or-lose start2 0))
+ (give-up-ir1-transform))))
+ `(let* ((len1 (length seq1))
+ (len2 (length seq2))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ (replace-len1 (- end1 start1))
+ (replace-len2 (- end2 start2)))
+ ,(unless (policy node (= safety 0))
+ `(progn
+ (unless (<= 0 start1 end1 len1)
+ (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
+ (unless (<= 0 start2 end2 len2)
+ (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
+ ,',(cond
+ ((and saetp (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)
+ (find-package "SB!KERNEL"))))
+ `(funcall (function ,bash-function) seq2 start2
+ seq1 start1 (min replace-len1 replace-len2))))
+ (t
+ ;; We can expand the loop inline here because we
+ ;; would have given up the transform (see above)
+ ;; if we didn't have constant matching start
+ ;; indices.
+ '(do ((i start1 (1+ i))
+ (j start2 (1+ j))
+ (end (+ start1
+ (min replace-len1 replace-len2))))
+ ((>= i end))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref seq1 i) (aref seq2 j)))))
+ seq1))))
+
(macrolet
((define-replace-transforms ()
(loop for saetp across sb!vm:*specialized-array-element-type-properties*
for sequence-type = `(simple-array ,(sb!vm:saetp-specifier saetp) (*))
unless (= (sb!vm:saetp-typecode saetp) sb!vm::simple-array-nil-widetag)
- collect
- `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
- (,sequence-type ,sequence-type &rest t)
- ,sequence-type
- :node node)
- ,(cond
- ((valid-bit-bash-saetp-p saetp) nil)
- ;; If we're not bit-bashing, only allow cases where we
- ;; can determine the order of copying up front. (There
- ;; are actually more cases we can handle if we know the
- ;; amount that we're copying, but this handles the
- ;; common cases.)
- (t '(unless (= (constant-value-or-lose start1 0)
- (constant-value-or-lose start2 0))
- (give-up-ir1-transform))))
- `(let* ((len1 (length seq1))
- (len2 (length seq2))
- (end1 (or end1 len1))
- (end2 (or end2 len2))
- (replace-len1 (- end1 start1))
- (replace-len2 (- end2 start2)))
- ,(unless (policy node (= safety 0))
- `(progn
- (unless (<= 0 start1 end1 len1)
- (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
- (unless (<= 0 start2 end2 len2)
- (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
- ,',(cond
- ((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)
- (find-package "SB!KERNEL"))))
- `(funcall (function ,bash-function) seq2 start2
- seq1 start1 (min replace-len1 replace-len2))))
- (t
- ;; We can expand the loop inline here because we
- ;; would have given up the transform (see above)
- ;; if we didn't have constant matching start
- ;; indices.
- '(do ((i start1 (1+ i))
- (end (+ start1
- (min replace-len1 replace-len2))))
- ((>= i end))
- (declare (optimize (insert-array-bounds-checks 0)))
- (setf (aref seq1 i) (aref seq2 i)))))
- seq1))
+ collect (make-replace-transform saetp sequence-type sequence-type)
into forms
- finally (return `(progn ,@forms)))))
- (define-replace-transforms))
+ finally (return `(progn ,@forms))))
+ (define-one-transform (sequence-type1 sequence-type2)
+ (make-replace-transform nil sequence-type1 sequence-type2)))
+ (define-replace-transforms)
+ (define-one-transform simple-base-string (simple-array character (*)))
+ (define-one-transform (simple-array character (*)) simple-base-string))
;;; Expand simple cases of UB<SIZE>-BASH-COPY inline. "simple" is
;;; defined as those cases where we are doing word-aligned copies from
'result 0 'size element-type)
result)))))
+(deftransform subseq ((seq start &optional end)
+ (list t &optional t))
+ `(list-subseq* seq start end))
+
(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
(let ((array-type (lvar-type seq)))
(unless (array-type-p array-type)
from-end)
(vector vector &rest t)
*
+ :node node
:policy (> speed (max space safety)))
"open code"
(let ((from-end (when (lvar-p from-end)
(give-up-ir1-transform ":FROM-END is not constant."))
(lvar-value from-end)))
(keyp (lvar-p key))
- (testp (lvar-p test)))
+ (testp (lvar-p test))
+ (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
`(block search
- (let ((end1 (or end1 (length pattern)))
- (end2 (or end2 (length text)))
- ,@(when keyp
- '((key (coerce key 'function))))
- ,@(when testp
- '((test (coerce test 'function)))))
- (declare (type index start1 start2 end1 end2))
- (do (,(if from-end
- '(index2 (- end2 (- end1 start1)) (1- index2))
- '(index2 start2 (1+ index2))))
- (,(if from-end
- '(< index2 start2)
- '(>= index2 end2))
- nil)
- ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
- ;; terminates is hits -1 when :FROM-END is true and :START2
- ;; is 0.
- (declare (type fixnum index2))
- (when (do ((index1 start1 (1+ index1))
- (index2 index2 (1+ index2)))
- ((>= index1 end1) t)
- (declare (type index index1 index2))
- ,@(unless from-end
- '((when (= index2 end2)
- (return-from search nil))))
- (unless (,@(if testp
- '(funcall test)
- '(eql))
- ,(if keyp
- '(funcall key (aref pattern index1))
- '(aref pattern index1))
- ,(if keyp
- '(funcall key (aref text index2))
- '(aref text index2)))
- (return nil)))
- (return index2)))))))
-
-;;; FIXME: It seems as though it should be possible to make a DEFUN
-;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
-;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
-;;; at least once DYNAMIC-EXTENT works.
-;;;
-;;; FIXME: currently KLUDGEed because of bug 188
-;;;
-;;; FIXME: disabled for sb-unicode: probably want it back
-#!-sb-unicode
-(deftransform concatenate ((rtype &rest sequences)
- (t &rest (or simple-base-string
- (simple-array nil (*))))
- simple-base-string
- :policy (< safety 3))
- (loop for rest-seqs on sequences
- for n-seq = (gensym "N-SEQ")
- for n-length = (gensym "N-LENGTH")
- for start = 0 then next-start
- for next-start = (gensym "NEXT-START")
- collect n-seq into args
- collect `(,n-length (length ,n-seq)) into lets
- collect n-length into all-lengths
- collect next-start into starts
- collect `(if (and (typep ,n-seq '(simple-array nil (*)))
- (> ,n-length 0))
- (error 'nil-array-accessed-error)
- (#.(let* ((i (position 'character sb!kernel::*specialized-array-element-types*))
- (saetp (aref sb!vm:*specialized-array-element-type-properties* i))
- (n-bits (sb!vm:saetp-n-bits saetp)))
- (intern (format nil "UB~D-BASH-COPY" n-bits)
- "SB!KERNEL"))
- ,n-seq 0 res ,start ,n-length))
- into forms
- collect `(setq ,next-start (+ ,start ,n-length)) into forms
- finally
- (return
- `(lambda (rtype ,@args)
- (declare (ignore rtype))
- (let* (,@lets
- (res (make-string (the index (+ ,@all-lengths))
- :element-type 'base-char)))
- (declare (type index ,@all-lengths))
- (let (,@(mapcar (lambda (name) `(,name 0)) starts))
- (declare (type index ,@starts))
- ,@forms)
- res)))))
+ (flet ((oops (vector start end)
+ (bounding-index-error vector start end)))
+ (let* ((len1 (length pattern))
+ (len2 (length text))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ ,@(when keyp
+ '((key (coerce key 'function))))
+ ,@(when testp
+ '((test (coerce test 'function)))))
+ (declare (type index start1 start2 end1 end2))
+ ,@(when check-bounds-p
+ `((unless (<= start1 end1 len1)
+ (oops pattern start1 end1))
+ (unless (<= start2 end2 len2)
+ (oops pattern start2 end2))))
+ (do (,(if from-end
+ '(index2 (- end2 (- end1 start1)) (1- index2))
+ '(index2 start2 (1+ index2))))
+ (,(if from-end
+ '(< index2 start2)
+ '(>= index2 end2))
+ nil)
+ ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+ ;; terminates is hits -1 when :FROM-END is true and :START2
+ ;; is 0.
+ (declare (type fixnum index2))
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((>= index1 end1) t)
+ (declare (type index index1 index2)
+ (optimize (insert-array-bounds-checks 0)))
+ ,@(unless from-end
+ '((when (= index2 end2)
+ (return-from search nil))))
+ (unless (,@(if testp
+ '(funcall test)
+ '(eql))
+ ,(if keyp
+ '(funcall key (aref pattern index1))
+ '(aref pattern index1))
+ ,(if keyp
+ '(funcall key (aref text index2))
+ '(aref text index2)))
+ (return nil)))
+ (return index2))))))))
+
+
+;;; Open-code CONCATENATE for strings. It would be possible to extend
+;;; 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
+(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)))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
end-arg
element
done-p-expr)
- (with-unique-names (offset block index n-sequence sequence n-end end)
- `(let ((,n-sequence ,sequence-arg)
- (,n-end ,end-arg))
+ (with-unique-names (offset block index n-sequence sequence end)
+ `(let* ((,n-sequence ,sequence-arg))
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
(,start ,start)
- (,end (%check-vector-sequence-bounds
- ,n-sequence ,start ,n-end)))
+ (,end ,end-arg)
+ :check-fill-pointer t)
(block ,block
(macrolet ((maybe-return ()
;; WITH-ARRAY-DATA has already performed bounds
;; in the inner loop.
'(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0)))
(aref ,sequence ,index))))
- (when ,done-p-expr
- (return-from ,block
- (values ,element
- (- ,index ,offset)))))))
+ (when ,done-p-expr
+ (return-from ,block
+ (values ,element
+ (- ,index ,offset)))))))
(if ,from-end
(loop for ,index
;; (If we aren't fastidious about declaring that
from (1- ,end) downto ,start do
(maybe-return))
(loop for ,index of-type index from ,start below ,end do
- (maybe-return))))
+ (maybe-return))))
(values nil nil))))))
(def!macro %find-position-vector-macro (item sequence
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
- from-end start end key test))
+ from-end start end key test))
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.