(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)))))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sequence-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
(values key '(%coerce-callable-to-fun key))))))
(let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
(test-not 'test-not)))))
- (out-of-line (or (find-symbol (format nil "%~A~{-~A~}" name funs)
- (load-time-value (find-package "SB!KERNEL")))
- (bug "Unknown list item seek transform: name=~S, funs=~S"
- name funs)))
(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)))
;; constant nil list -- nothing to find!
nil)
(t
- `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))))
+ ;; 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))
(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)
+ (sequence-bounding-indices-bad-error seq1 start1 end1))
+ (unless (<= 0 start2 end2 len2)
+ (sequence-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
,(unless (policy node (= safety 0))
'(progn
(unless (<= 0 start end length)
- (sb!impl::signal-bounding-indices-bad-error seq start end))))
+ (sequence-bounding-indices-bad-error seq start end))))
(let* ((size (- end start))
(result (make-array size :element-type ',element-type)))
,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
'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)
+ (sequence-bounding-indices-bad-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
(declare (type index index))
(dolist (i sequence
(if (and end (> end index))
- (sb!impl::signal-bounding-indices-bad-error
+ (sequence-bounding-indices-bad-error
sequence start end)
(values find position)))
(let ((key-i (funcall key i)))
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.
projects / sbcl.git / blobdiff