X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=3efefa24a62364a9828743a7ef02a5ec2d9532d7;hb=e0090a168ad00c8a13c2848e5608d74bf5217e6b;hp=de9f0ff5596b937c05fd5f7c91ec4883f0bd4bff;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index de9f0ff..3efefa2 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -27,31 +27,30 @@ (args-to-fn (if take-car `(car ,v) v)))) (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes - (call `(funcall ,fn-sym . ,(args-to-fn))) + (call `(%funcall ,fn-sym . ,(args-to-fn))) (endtest `(or ,@(tests)))) - (ecase accumulate - (:nconc - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) - (:list - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (truly-the list (cdr ,map-result))) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,fn-sym ,fn) - (,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest (truly-the list ,n-first)) - ,call)))))))) + + `(let ((,fn-sym (%coerce-callable-to-fun ,fn))) + ,(ecase accumulate + (:nconc + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (cdr ,map-result)) + (setq ,temp (last (nconc ,temp ,call))))))) + (:list + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (truly-the list (cdr ,map-result))) + (rplacd ,temp (setq ,temp (list ,call))))))) + ((nil) + `(let ((,n-first ,(first arglists))) + (do-anonymous ,(do-clauses) + (,endtest (truly-the list ,n-first)) + ,call))))))))) (define-source-transform mapc (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil t)) @@ -285,62 +284,118 @@ (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))))) - -(macrolet ((def (name) - `(deftransform ,name ((e l &key (test #'eql)) * * - :node node) - (unless (constant-lvar-p l) - (give-up-ir1-transform)) - - (let ((val (lvar-value l))) - (unless (policy node - (or (= speed 3) - (and (>= speed space) - (<= (length val) 5)))) - (give-up-ir1-transform)) - - (labels ((frob (els) - (if els - `(if (funcall test e ',(car els)) - ',els - ,(frob (cdr els))) - nil))) - (frob val)))))) - (def member) - (def memq)) - -;;; 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)) + (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 + ;; not there at all. If it might be NIL, make up a form to that + ;; ensure it is a function. + (multiple-value-bind (key key-form) + (if key + (let ((key-type (lvar-type key)) + (null-type (specifier-type 'null))) + (cond ((csubtypep key-type null-type) + (values nil nil)) + ((csubtypep null-type key-type) + (values key '(if key + (%coerce-callable-to-fun key) + #'identity))) + (t + (values key '(%coerce-callable-to-fun key)))))) + (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 ((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)))) + (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) + (if tail + `(if (eq item ',(car tail)) + ',tail + ,(rec (cdr tail))) + nil))) + (rec (lvar-value list)))) + +;;; 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" @@ -362,7 +417,8 @@ (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))) @@ -403,205 +459,17 @@ (t (give-up-ir1-transform)))) -;;; FIXME: Why is this code commented out? (Why *was* it commented -;;; out? We inherited this situation from cmucl-2.4.8, with no -;;; explanation.) Should we just delete this code? -#| -;;; This is a frob whose job it is to make it easier to pass around -;;; the arguments to IR1 transforms. It bundles together the name of -;;; the argument (which should be referenced in any expansion), and -;;; the continuation for that argument (or NIL if unsupplied.) -(defstruct (arg (:constructor %make-arg (name cont)) - (:copier nil)) - (name nil :type symbol) - (cont nil :type (or continuation null))) -(defmacro make-arg (name) - `(%make-arg ',name ,name)) - -;;; If Arg is null or its CONT is null, then return Default, otherwise -;;; return Arg's NAME. -(defun default-arg (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (arg-name arg) - default)) - -;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's -;;; CONT must be a constant continuation whose value we return. If not, we -;;; give up. -(defun arg-constant-value (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (unless (constant-continuation-p cont) - (give-up-ir1-transform "Argument is not constant: ~S." - (arg-name arg))) - (continuation-value from-end)) - default)) - -;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If -;;; Arg is NIL or its CONT is NIL, then compare to the default. -(defun arg-eql (arg default x) - (declare (type (or arg null) x)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (and (constant-continuation-p cont) - (eql (continuation-value cont) x))) - (eql default x))) - -(defstruct (iterator (:copier nil)) - ;; The kind of iterator. - (kind nil (member :normal :result)) - ;; A list of LET* bindings to create the initial state. - (binds nil :type list) - ;; A list of declarations for Binds. - (decls nil :type list) - ;; A form that returns the current value. This may be set with SETF to set - ;; the current value. - (current (error "Must specify CURRENT.")) - ;; In a :NORMAL iterator, a form that tests whether there is a current value. - (done nil) - ;; In a :RESULT iterator, a form that truncates the result at the current - ;; position and returns it. - (result nil) - ;; A form that returns the initial total number of values. The result is - ;; undefined after NEXT has been evaluated. - (length (error "Must specify LENGTH.")) - ;; A form that advances the state to the next value. It is an error to call - ;; this when the iterator is Done. - (next (error "Must specify NEXT."))) - -;;; Type of an index var that can go negative (in the from-end case.) -(deftype neg-index () - `(integer -1 ,most-positive-fixnum)) - -;;; Return an ITERATOR structure describing how to iterate over an arbitrary -;;; sequence. Sequence is a variable bound to the sequence, and Type is the -;;; type of the sequence. If true, INDEX is a variable that should be bound to -;;; the index of the current element in the sequence. -;;; -;;; If we can't tell whether the sequence is a list or a vector, or whether -;;; the iteration is forward or backward, then GIVE-UP. -(defun make-sequence-iterator (sequence type &key start end from-end index) - (declare (symbol sequence) (type ctype type) - (type (or arg null) start end from-end) - (type (or symbol null) index)) - (let ((from-end (arg-constant-value from-end nil))) - (cond ((csubtypep type (specifier-type 'vector)) - (let* ((n-stop (gensym)) - (n-idx (or index (gensym))) - (start (default-arg 0 start)) - (end (default-arg `(length ,sequence) end))) - (make-iterator - :kind :normal - :binds `((,n-idx ,(if from-end `(1- ,end) ,start)) - (,n-stop ,(if from-end `(1- ,start) ,end))) - :decls `((type neg-index ,n-idx ,n-stop)) - :current `(aref ,sequence ,n-idx) - :done `(,(if from-end '<= '>=) ,n-idx ,n-stop) - :next `(setq ,n-idx - ,(if from-end `(1- ,n-idx) `(1+ ,n-idx))) - :length (if from-end - `(- ,n-idx ,n-stop) - `(- ,n-stop ,n-idx))))) - ((csubtypep type (specifier-type 'list)) - (let* ((n-stop (if (and end (not from-end)) (gensym) nil)) - (n-current (gensym)) - (start-p (not (arg-eql start 0 0))) - (end-p (not (arg-eql end nil nil))) - (start (default-arg start 0)) - (end (default-arg end nil))) - (make-iterator - :binds `((,n-current - ,(if from-end - (if (or start-p end-p) - `(nreverse (subseq ,sequence ,start - ,@(when end `(,end)))) - `(reverse ,sequence)) - (if start-p - `(nthcdr ,start ,sequence) - sequence))) - ,@(when n-stop - `((,n-stop (nthcdr (the index - (- ,end ,start)) - ,n-current)))) - ,@(when index - `((,index ,(if from-end `(1- ,end) start))))) - :kind :normal - :decls `((list ,n-current ,n-end) - ,@(when index `((type neg-index ,index)))) - :current `(car ,n-current) - :done `(eq ,n-current ,n-stop) - :length `(- ,(or end `(length ,sequence)) ,start) - :next `(progn - (setq ,n-current (cdr ,n-current)) - ,@(when index - `((setq ,n-idx - ,(if from-end - `(1- ,index) - `(1+ ,index))))))))) - (t - (give-up-ir1-transform - "can't tell whether sequence is a list or a vector"))))) - -;;; Make an iterator used for constructing result sequences. Name is a -;;; variable to be bound to the result sequence. Type is the type of result -;;; sequence to make. Length is an expression to be evaluated to get the -;;; maximum length of the result (not evaluated in list case.) -(defun make-result-sequence-iterator (name type length) - (declare (symbol name) (type ctype type)) - -;;; Define each NAME as a local macro that will call the value of the -;;; function arg with the given arguments. If the argument isn't known to be a -;;; function, give them an efficiency note and reference a coerced version. -(defmacro coerce-funs (specs &body body) - #!+sb-doc - "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*" - (collect ((binds) - (defs)) - (dolist (spec specs) - `(let ((body (progn ,@body)) - (n-fun (arg-name ,(second spec))) - (fun-cont (arg-cont ,(second spec)))) - (cond ((not fun-cont) - `(macrolet ((,',(first spec) (&rest args) - `(,',',(third spec) ,@args))) - ,body)) - ((not (csubtypep (continuation-type fun-cont) - (specifier-type 'function))) - (when (policy *compiler-error-context* - (> speed inhibit-warnings)) - (compiler-notify - "~S may not be a function, so must coerce at run-time." - n-fun)) - (once-only ((n-fun `(if (functionp ,n-fun) - ,n-fun - (symbol-function ,n-fun)))) - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))) - (t - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))))))) - -;;; Wrap code around the result of the body to define Name as a local macro -;;; that returns true when its arguments satisfy the test according to the Args -;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the -;;; transform. -(defmacro with-sequence-test ((name test test-not) &body body) - `(let ((not-p (arg-cont ,test-not))) - (when (and (arg-cont ,test) not-p) - (abort-ir1-transform "Both ~S and ~S were supplied." - (arg-name ,test) - (arg-name ,test-not))) - (coerce-funs ((,name (if not-p ,test-not ,test) eql)) - ,@body))) -|# - + ;;;; hairy sequence transforms ;;; FIXME: no hairy sequence transforms in SBCL? +;;; +;;; There used to be a bunch of commented out code about here, +;;; containing the (apparent) beginning of hairy sequence transform +;;; infrastructure. People interested in implementing better sequence +;;; transforms might want to look at it for inspiration, even though +;;; the actual code is ancient CMUCL -- and hence bitrotted. The code +;;; was deleted in 1.0.7.23. ;;;; string operations @@ -663,21 +531,10 @@ (def string/=* identity)) -;;;; string-only transforms for sequence functions -;;;; -;;;; Note: CMU CL had more of these, including transforms for -;;;; functions which cons. In SBCL, we've gotten rid of most of the -;;;; transforms for functions which cons, since our GC overhead is -;;;; sufficiently large that it doesn't seem worth it to try to -;;;; economize on function call overhead or on the overhead of runtime -;;;; type dispatch in AREF. The exception is CONCATENATE, since -;;;; a full call to CONCATENATE would have to look up the sequence -;;;; type, which can be really slow. - -;;; Moved here from generic/vm-tran.lisp to satisfy clisp -;;; -;;; FIXME: Add a comment telling whether this holds for all vectors -;;; or only for vectors based on simple arrays (non-adjustable, etc.). +;;;; transforms for sequence functions + +;;; Moved here from generic/vm-tran.lisp to satisfy clisp. Only applies +;;; to vectors based on simple arrays. (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) @@ -695,158 +552,408 @@ (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits))) ) ; EVAL-WHEN -;; FIXME: It turns out that this transform (for SIMPLE-BASE-STRINGS) -;; is critical for the performance of string streams. Make this -;; more explicit. +;;; FIXME: In the copy loops below, we code the loops in a strange +;;; fashion: +;;; +;;; (do ((i (+ src-offset length) (1- i))) +;;; ((<= i 0) ...) +;;; (... (aref foo (1- i)) ...)) +;;; +;;; rather than the more natural (and seemingly more efficient): +;;; +;;; (do ((i (1- (+ src-offset length)) (1- i))) +;;; ((< i 0) ...) +;;; (... (aref foo i) ...)) +;;; +;;; (more efficient because we don't have to do the index adjusting on +;;; every iteration of the loop) +;;; +;;; We do this to avoid a suboptimality in SBCL's backend. In the +;;; latter case, the backend thinks I is a FIXNUM (which it is), but +;;; when used as an array index, the backend thinks I is a +;;; POSITIVE-FIXNUM (which it is). However, since the backend thinks of +;;; these as distinct storage classes, it cannot coerce a move from a +;;; FIXNUM TN to a POSITIVE-FIXNUM TN. The practical effect of this +;;; deficiency is that we have two extra moves and increased register +;;; pressure, which can lead to some spectacularly bad register +;;; allocation. (sub-FIXME: the register allocation even with the +;;; strangely written loops is not always excellent, either...). Doing +;;; it the first way, above, means that I is always thought of as a +;;; POSITIVE-FIXNUM and there are no issues. +;;; +;;; Besides, the *-WITH-OFFSET machinery will fold those index +;;; adjustments in the first version into the array addressing at no +;;; performance penalty! + +;;; This transform is critical to the performance of string streams. If +;;; 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* - when (valid-bit-bash-saetp-p saetp) - collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (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")))) - `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) - (,sequence-type ,sequence-type &rest t) - ,sequence-type - :node node) - `(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)))) - (funcall (function ,',bash-function) - seq2 start2 - seq1 start1 - (min replace-len1 replace-len2)) - seq1))) + for sequence-type = `(simple-array ,(sb!vm:saetp-specifier saetp) (*)) + unless (= (sb!vm:saetp-typecode saetp) sb!vm::simple-array-nil-widetag) + collect (make-replace-transform saetp sequence-type sequence-type) into forms - finally (return `(progn ,@forms))))) - (define-replace-transforms)) - -(macrolet - ((define-subseq-transforms () - (loop for saetp across sb!vm:*specialized-array-element-type-properties* - when (valid-bit-bash-saetp-p saetp) - collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (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")))) - `(deftransform subseq ((seq start &optional end) - (,sequence-type t &optional t) - ,sequence-type :node node) - `(let* ((length (length seq)) - (end (if end (min end length) length))) - ,(unless (policy node (= safety 0)) - `(progn + 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-BASH-COPY inline. "simple" is +;;; defined as those cases where we are doing word-aligned copies from +;;; both the source and the destination and we are copying from the same +;;; offset from both the source and the destination. (The last +;;; condition is there so we can determine the direction to copy at +;;; compile time rather than runtime. Remember that UB-BASH-COPY +;;; acts like memmove, not memcpy.) These conditions may seem rather +;;; restrictive, but they do catch common cases, like allocating a (* 2 +;;; N)-size buffer and blitting in the old N-size buffer in. + +(defun frob-bash-transform (src src-offset + dst dst-offset + length n-elems-per-word) + (declare (ignore src dst length)) + (let ((n-bits-per-elem (truncate sb!vm:n-word-bits n-elems-per-word))) + (multiple-value-bind (src-word src-elt) + (truncate (lvar-value src-offset) n-elems-per-word) + (multiple-value-bind (dst-word dst-elt) + (truncate (lvar-value dst-offset) n-elems-per-word) + ;; Avoid non-word aligned copies. + (unless (and (zerop src-elt) (zerop dst-elt)) + (give-up-ir1-transform)) + ;; Avoid copies where we would have to insert code for + ;; determining the direction of copying. + (unless (= src-word dst-word) + (give-up-ir1-transform)) + ;; FIXME: The cross-compiler doesn't optimize TRUNCATE properly, + ;; so we have to do its work here. + `(let ((end (+ ,src-word ,(if (= n-elems-per-word 1) + 'length + `(truncate (the index length) ,n-elems-per-word))))) + (declare (type index end)) + ;; Handle any bits at the end. + (when (logtest length (1- ,n-elems-per-word)) + (let* ((extra (mod length ,n-elems-per-word)) + ;; FIXME: The shift amount on this ASH is + ;; *always* negative, but the backend doesn't + ;; have a NEGATIVE-FIXNUM primitive type, so we + ;; wind up with a pile of code that tests the + ;; sign of the shift count prior to shifting when + ;; all we need is a simple negate and shift + ;; right. Yuck. + (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) + (* (- extra ,n-elems-per-word) + ,n-bits-per-elem)))) + (setf (sb!kernel:%vector-raw-bits dst end) + (logior + (logandc2 (sb!kernel:%vector-raw-bits dst end) + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian `(* (- ,n-elems-per-word extra) + ,n-bits-per-elem))))) + (logand (sb!kernel:%vector-raw-bits src end) + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian `(* (- ,n-elems-per-word extra) + ,n-bits-per-elem))))))))) + ;; Copy from the end to save a register. + (do ((i end (1- i))) + ((<= i ,src-word)) + (setf (sb!kernel:%vector-raw-bits dst (1- i)) + (sb!kernel:%vector-raw-bits src (1- i))))))))) + +#.(loop for i = 1 then (* i 2) + collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i) + "SB!KERNEL") + ((src src-offset + dst dst-offset + length) + ((simple-unboxed-array (*)) + (constant-arg index) + (simple-unboxed-array (*)) + (constant-arg index) + index) + *) + (frob-bash-transform src src-offset + dst dst-offset length + ,(truncate sb!vm:n-word-bits i))) into forms + until (= i sb!vm:n-word-bits) + finally (return `(progn ,@forms))) + +;;; We expand copy loops inline in SUBSEQ and COPY-SEQ if we're copying +;;; arrays with elements of size >= the word size. We do this because +;;; we know the arrays cannot alias (one was just consed), therefore we +;;; can determine at compile time the direction to copy, and for +;;; word-sized elements, UB-BASH-COPY will do a bit of +;;; needless checking to figure out what's going on. The same +;;; considerations apply if we are copying elements larger than the word +;;; size, with the additional twist that doing it inline is likely to +;;; cons far less than calling REPLACE and letting generic code do the +;;; work. +;;; +;;; However, we do not do this for elements whose size is < than the +;;; word size because we don't want to deal with any alignment issues +;;; inline. The UB*-BASH-COPY transforms might fix things up later +;;; anyway. + +(defun maybe-expand-copy-loop-inline (src src-offset dst dst-offset length + element-type) + (let ((saetp (find-saetp element-type))) + (aver saetp) + (if (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits) + (expand-aref-copy-loop src src-offset dst dst-offset length) + `(locally (declare (optimize (safety 0))) + (replace ,dst ,src :start1 ,dst-offset :start2 ,src-offset :end1 ,length))))) + +(defun expand-aref-copy-loop (src src-offset dst dst-offset length) + (if (eql src-offset dst-offset) + `(do ((i (+ ,src-offset ,length) (1- i))) + ((<= i ,src-offset)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref ,dst (1- i)) (aref ,src (1- i)))) + ;; KLUDGE: The compiler is not able to derive that (+ offset + ;; length) must be a fixnum, but arrives at (unsigned-byte 29). + ;; We, however, know it must be so, as by this point the bounds + ;; have already been checked. + `(do ((i (truly-the fixnum (+ ,src-offset ,length)) (1- i)) + (j (+ ,dst-offset ,length) (1- j))) + ((<= i ,src-offset)) + (declare (optimize (insert-array-bounds-checks 0)) + (type (integer 0 #.sb!xc:array-dimension-limit) j i)) + (setf (aref ,dst (1- j)) (aref ,src (1- i)))))) + +;;; SUBSEQ, COPY-SEQ + +(deftransform subseq ((seq start &optional end) + (vector t &optional t) + * + :node node) + (let ((type (lvar-type seq))) + (cond + ((and (array-type-p type) + (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (let ((element-type (type-specifier (array-type-specialized-element-type type)))) + `(let* ((length (length seq)) + (end (or end length))) + ,(unless (policy node (zerop insert-array-bounds-checks)) + '(progn (unless (<= 0 start end length) - (sb!impl::signal-bounding-indices-bad-error seq start end)))) - (let* ((size (- end start)) - (result (make-array size :element-type ',',(sb!vm:saetp-specifier saetp)))) - (funcall (function ,',bash-function) - seq start result 0 size) - result)))) - into forms - finally (return `(progn ,@forms))))) - (define-subseq-transforms)) - -(macrolet - ((define-copy-seq-transforms () - (loop for saetp across sb!vm:*specialized-array-element-type-properties* - when (valid-bit-bash-saetp-p saetp) - collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (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")))) - `(deftransform copy-seq ((seq) (,sequence-type) - ,sequence-type) - `(let* ((length (length seq)) - (result (make-array length :element-type ',',(sb!vm:saetp-specifier saetp)))) - (funcall (function ,',bash-function) - seq 0 result 0 length) - result))) - into forms - finally (return `(progn ,@forms))))) - (define-copy-seq-transforms)) - -;;; FIXME: this would be a valid transform for certain excluded cases: -;;; * :TEST 'CHAR= or :TEST #'CHAR= -;;; * :TEST 'EQL or :TEST #'EQL -;;; * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity) -(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2) - (simple-string simple-string &rest t) + (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) + (lvar-value start) + 'start) + 'result 0 'size element-type) + result)))) + (t + '(vector-subseq* seq start end))))) + +(deftransform subseq ((seq start &optional end) + (list t &optional t)) + `(list-subseq* seq start end)) + +(deftransform subseq ((seq start &optional end) + ((and sequence (not vector) (not list)) t &optional t)) + '(sb!sequence: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) + (give-up-ir1-transform)) + (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) + `(let* ((length (length seq)) + (result (make-array length :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) + result)))) + +;;; FIXME: it really should be possible to take advantage of the +;;; macros used in code/seq.lisp here to avoid duplication of code, +;;; and enable even funkier transformations. +(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2 + (test #'eql) + (key #'identity) + from-end) + (vector vector &rest t) * + :node node :policy (> speed (max space safety))) - `(block search - (let ((end1 (or end1 (length pattern))) - (end2 (or end2 (length text)))) - (do ((index2 start2 (1+ index2))) - ((>= index2 end2) nil) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((>= index1 end1) t) - (when (= index2 end2) - (return-from search nil)) - (when (char/= (char pattern index1) (char 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))))) + "open code" + (let ((from-end (when (lvar-p from-end) + (unless (constant-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)) + (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) + `(block search + (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))) ;;;; CONS accessor DERIVE-TYPE optimizers @@ -900,7 +1007,7 @@ (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))) @@ -963,13 +1070,12 @@ 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 @@ -977,10 +1083,10 @@ ;; 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 @@ -991,7 +1097,7 @@ 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 @@ -1057,7 +1163,7 @@ "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.