X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=de9f0ff5596b937c05fd5f7c91ec4883f0bd4bff;hb=a682f4c392bc874a6a898632889319ebdd8821fc;hp=bfea7221c7e159c72fd2925fd298b614e187e7e9;hpb=12348c1417becbbd24dd3f109ed4040dbdde62dd;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index bfea722..de9f0ff 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -15,42 +15,43 @@ (defun mapfoo-transform (fn arglists accumulate take-car) (collect ((do-clauses) - (args-to-fn) - (tests)) + (args-to-fn) + (tests)) (let ((n-first (gensym))) (dolist (a (if accumulate - arglists - `(,n-first ,@(rest arglists)))) - (let ((v (gensym))) - (do-clauses `(,v ,a (cdr ,v))) - (tests `(endp ,v)) - (args-to-fn (if take-car `(car ,v) v)))) + arglists + `(,n-first ,@(rest arglists)))) + (let ((v (gensym))) + (do-clauses `(,v ,a (cdr ,v))) + (tests `(endp ,v)) + (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))) - (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 (cdr ,map-result)) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,fn-sym ,fn) - (,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest ,n-first) ,call)))))))) + (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)))))))) (define-source-transform mapc (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil t)) @@ -75,50 +76,99 @@ ;;; MAP is %MAP plus a check to make sure that any length specified in ;;; the result type matches the actual result. We also wrap it in a ;;; TRULY-THE for the most specific type we can determine. -(deftransform map ((result-type-arg fun &rest seqs) * * :node node) - (let* ((seq-names (make-gensym-list (length seqs))) - (bare `(%map result-type-arg fun ,@seq-names)) - (constant-result-type-arg-p (constant-continuation-p result-type-arg)) - ;; what we know about the type of the result. (Note that the - ;; "result type" argument is not necessarily the type of the - ;; result, since NIL means the result has NULL type.) - (result-type (if (not constant-result-type-arg-p) - 'consed-sequence - (let ((result-type-arg-value - (continuation-value result-type-arg))) - (if (null result-type-arg-value) - 'null - result-type-arg-value))))) +(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node) + (let* ((seq-names (make-gensym-list (1+ (length seqs)))) + (bare `(%map result-type-arg fun ,@seq-names)) + (constant-result-type-arg-p (constant-lvar-p result-type-arg)) + ;; what we know about the type of the result. (Note that the + ;; "result type" argument is not necessarily the type of the + ;; result, since NIL means the result has NULL type.) + (result-type (if (not constant-result-type-arg-p) + 'consed-sequence + (let ((result-type-arg-value + (lvar-value result-type-arg))) + (if (null result-type-arg-value) + 'null + result-type-arg-value))))) `(lambda (result-type-arg fun ,@seq-names) (truly-the ,result-type - ,(cond ((policy node (< safety 3)) - ;; ANSI requires the length-related type check only - ;; when the SAFETY quality is 3... in other cases, we - ;; skip it, because it could be expensive. - bare) - ((not constant-result-type-arg-p) - `(sequence-of-checked-length-given-type ,bare - result-type-arg)) - (t - (let ((result-ctype (ir1-transform-specifier-type - result-type))) - (if (array-type-p result-ctype) - (let ((dims (array-type-dimensions result-ctype))) - (unless (and (listp dims) (= (length dims) 1)) - (give-up-ir1-transform "invalid sequence type")) - (let ((dim (first dims))) - (if (eq dim '*) - bare - `(vector-of-checked-length-given-length ,bare - ,dim)))) - ;; FIXME: this is wrong, as not all subtypes of - ;; VECTOR are ARRAY-TYPEs [consider, for - ;; example, (OR (VECTOR T 3) (VECTOR T - ;; 4))]. However, it's difficult to see what we - ;; should put here... maybe we should - ;; GIVE-UP-IR1-TRANSFORM if the type is a - ;; subtype of VECTOR but not an ARRAY-TYPE? - bare)))))))) + ,(cond ((policy node (< safety 3)) + ;; ANSI requires the length-related type check only + ;; when the SAFETY quality is 3... in other cases, we + ;; skip it, because it could be expensive. + bare) + ((not constant-result-type-arg-p) + `(sequence-of-checked-length-given-type ,bare + result-type-arg)) + (t + (let ((result-ctype (ir1-transform-specifier-type + result-type))) + (if (array-type-p result-ctype) + (let ((dims (array-type-dimensions result-ctype))) + (unless (and (listp dims) (= (length dims) 1)) + (give-up-ir1-transform "invalid sequence type")) + (let ((dim (first dims))) + (if (eq dim '*) + bare + `(vector-of-checked-length-given-length ,bare + ,dim)))) + ;; FIXME: this is wrong, as not all subtypes of + ;; VECTOR are ARRAY-TYPEs [consider, for + ;; example, (OR (VECTOR T 3) (VECTOR T + ;; 4))]. However, it's difficult to see what we + ;; should put here... maybe we should + ;; GIVE-UP-IR1-TRANSFORM if the type is a + ;; subtype of VECTOR but not an ARRAY-TYPE? + bare)))))))) + +;;; Return a DO loop, mapping a function FUN to elements of +;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables, +;;; bound to sequences, INTO - a variable, which is used in +;;; MAP-INTO. RESULT and BODY are forms, which can use variables +;;; FUNCALL-RESULT, containing the result of application of FUN, and +;;; INDEX, containing the current position in sequences. +(defun build-sequence-iterator (seqs seq-names &key result into body) + (declare (type list seqs seq-names) + (type symbol into)) + (collect ((bindings) + (declarations) + (vector-lengths) + (tests) + (places)) + (let ((found-vector-p nil)) + (flet ((process-vector (length) + (unless found-vector-p + (setq found-vector-p t) + (bindings `(index 0 (1+ index))) + (declarations `(type index index))) + (vector-lengths length))) + (loop for seq of-type lvar in seqs + for seq-name in seq-names + for type = (lvar-type seq) + do (cond ((csubtypep type (specifier-type 'list)) + (with-unique-names (index) + (bindings `(,index ,seq-name (cdr ,index))) + (declarations `(type list ,index)) + (places `(car ,index)) + (tests `(endp ,index)))) + ((csubtypep type (specifier-type 'vector)) + (process-vector `(length ,seq-name)) + (places `(locally (declare (optimize (insert-array-bounds-checks 0))) + (aref ,seq-name index)))) + (t + (give-up-ir1-transform + "can't determine sequence argument type")))) + (when into + (process-vector `(array-dimension ,into 0)))) + (when found-vector-p + (bindings `(length (min ,@(vector-lengths)))) + (tests `(>= index length))) + `(do (,@(bindings)) + ((or ,@(tests)) ,result) + (declare ,@(declarations)) + (let ((funcall-result (funcall fun ,@(places)))) + (declare (ignorable funcall-result)) + ,body))))) ;;; Try to compile %MAP efficiently when we can determine sequence ;;; argument types at compile time. @@ -132,104 +182,90 @@ ;;; handle that case more efficiently, but it's left as an exercise to ;;; the reader, because the code is complicated enough already and I ;;; don't happen to need that functionality right now. -- WHN 20000410 -(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space)) +(deftransform %map ((result-type fun seq &rest seqs) * * + :policy (>= speed space)) "open code" - (unless seqs (abort-ir1-transform "no sequence args")) - (unless (constant-continuation-p result-type) + (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) - (labels (;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true - (fn-1subtypep (fn x y) - (multiple-value-bind (subtype-p valid-p) (funcall fn x y) - (if valid-p - subtype-p - (give-up-ir1-transform - "can't analyze sequence type relationship")))) - (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)) - (1csubtypep (x y) (fn-1subtypep #'csubtypep x y)) - (seq-supertype (seq) - (let ((ctype (continuation-type seq))) - (cond ((1csubtypep ctype (specifier-type 'vector)) 'vector) - ((1csubtypep ctype (specifier-type 'list)) 'list) - (t - (give-up-ir1-transform - "can't determine sequence argument type")))))) - (let* ((result-type-value (continuation-value result-type)) - (result-supertype (cond ((null result-type-value) 'null) - ((1subtypep result-type-value 'vector) - 'vector) - ((1subtypep result-type-value 'list) - 'list) - (t - (give-up-ir1-transform - "can't determine result type")))) - (seq-supertypes (mapcar #'seq-supertype seqs))) - (cond ((and result-type-value (= 1 (length seqs))) - ;; The consing arity-1 cases can be implemented - ;; reasonably efficiently as function calls, and the cost - ;; of consing should be significantly larger than - ;; function call overhead, so we always compile these - ;; cases as full calls regardless of speed-versus-space - ;; optimization policy. - (cond ((subtypep 'list result-type-value) - '(apply #'%map-to-list-arity-1 fun seqs)) - (;; (This one can be inefficient due to COERCE, but - ;; the current open-coded implementation has the - ;; same problem.) - (subtypep result-type-value 'vector) - `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs) - ',result-type-value)) - (t (bug "impossible (?) sequence type")))) - (t - (let* ((seq-args (make-gensym-list (length seqs))) - (index-bindingoids - (mapcar (lambda (seq-arg seq-supertype) - (let ((i (gensym "I"))) - (ecase seq-supertype - (vector `(,i 0 (1+ ,i))) - (list `(,i ,seq-arg (rest ,i)))))) - seq-args seq-supertypes)) - (indices (mapcar #'first index-bindingoids)) - (index-decls (mapcar (lambda (index seq-supertype) - `(type ,(ecase seq-supertype - (vector 'index) - (list 'list)) - ,index)) - indices seq-supertypes)) - (tests (mapcar (lambda (seq-arg seq-supertype index) - (ecase seq-supertype - (vector `(>= ,index (length ,seq-arg))) - (list `(endp ,index)))) - seq-args seq-supertypes indices)) - (values (mapcar (lambda (seq-arg seq-supertype index) - (ecase seq-supertype - (vector `(aref ,seq-arg ,index)) - (list `(first ,index)))) - seq-args seq-supertypes indices))) - (multiple-value-bind (push-dacc final-result) - (ecase result-supertype - (null (values nil nil)) - (list (values `(push dacc acc) `(nreverse acc))) - (vector (values `(push dacc acc) - `(coerce (nreverse acc) - ',result-type-value)))) - ;; (We use the same idiom, of returning a LAMBDA from - ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for - ;; FUNCALL and ALIEN-FUNCALL, and for the same - ;; reason: we need to get the runtime values of each - ;; of the &REST vars.) - `(lambda (result-type fun ,@seq-args) - (declare (ignore result-type)) - (do ((really-fun (%coerce-callable-to-fun fun)) - ,@index-bindingoids - (acc nil)) - ((or ,@tests) - ,final-result) - (declare ,@index-decls) - (declare (type list acc)) - (declare (ignorable acc)) - (let ((dacc (funcall really-fun ,@values))) - (declare (ignorable dacc)) - ,push-dacc)))))))))) + (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true + (fn-1subtypep (fn x y) + (multiple-value-bind (subtype-p valid-p) (funcall fn x y) + (if valid-p + subtype-p + (give-up-ir1-transform + "can't analyze sequence type relationship")))) + (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) + (let* ((result-type-value (lvar-value result-type)) + (result-supertype (cond ((null result-type-value) 'null) + ((1subtypep result-type-value 'vector) + 'vector) + ((1subtypep result-type-value 'list) + 'list) + (t + (give-up-ir1-transform + "result type unsuitable"))))) + (cond ((and result-type-value (null seqs)) + ;; The consing arity-1 cases can be implemented + ;; reasonably efficiently as function calls, and the cost + ;; of consing should be significantly larger than + ;; function call overhead, so we always compile these + ;; cases as full calls regardless of speed-versus-space + ;; optimization policy. + (cond ((subtypep result-type-value 'list) + '(%map-to-list-arity-1 fun seq)) + ( ;; (This one can be inefficient due to COERCE, but + ;; the current open-coded implementation has the + ;; same problem.) + (subtypep result-type-value 'vector) + `(coerce (%map-to-simple-vector-arity-1 fun seq) + ',result-type-value)) + (t (bug "impossible (?) sequence type")))) + (t + (let* ((seqs (cons seq seqs)) + (seq-args (make-gensym-list (length seqs)))) + (multiple-value-bind (push-dacc result) + (ecase result-supertype + (null (values nil nil)) + (list (values `(push funcall-result acc) + `(nreverse acc))) + (vector (values `(push funcall-result acc) + `(coerce (nreverse acc) + ',result-type-value)))) + ;; (We use the same idiom, of returning a LAMBDA from + ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for + ;; FUNCALL and ALIEN-FUNCALL, and for the same + ;; reason: we need to get the runtime values of each + ;; of the &REST vars.) + `(lambda (result-type fun ,@seq-args) + (declare (ignore result-type)) + (let ((fun (%coerce-callable-to-fun fun)) + (acc nil)) + (declare (type list acc)) + (declare (ignorable acc)) + ,(build-sequence-iterator + seqs seq-args + :result result + :body push-dacc)))))))))) + +;;; MAP-INTO +(deftransform map-into ((result fun &rest seqs) + (vector * &rest *) + *) + "open code" + (let ((seqs-names (mapcar (lambda (x) + (declare (ignore x)) + (gensym)) + seqs))) + `(lambda (result fun ,@seqs-names) + ,(build-sequence-iterator + seqs seqs-names + :result '(when (array-has-fill-pointer-p result) + (setf (fill-pointer result) index)) + :into 'result + :body '(locally (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref result index) funcall-result))) + result))) + ;;; FIXME: once the confusion over doing transforms with known-complex ;;; arrays is over, we should also transform the calls to (AND (ARRAY @@ -247,22 +283,22 @@ '(setf (car (nthcdr i s)) v)) (deftransform %check-vector-sequence-bounds ((vector start end) - (vector * *) * - :node node) + (vector * *) * + :node node) (if (policy node (< safety speed)) '(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) + (sb!impl::signal-bounding-indices-bad-error vector start end))))) (macrolet ((def (name) `(deftransform ,name ((e l &key (test #'eql)) * * - :node node) - (unless (constant-continuation-p l) + :node node) + (unless (constant-lvar-p l) (give-up-ir1-transform)) - (let ((val (continuation-value l))) + (let ((val (lvar-value l))) (unless (policy node (or (= speed 3) (and (>= speed space) @@ -296,9 +332,9 @@ ;; if ITEM is not a NUMBER or is a FIXNUM, apply ;; transform, else give up on transform. (cond (test - (unless (continuation-fun-is test '(eq)) + (unless (lvar-fun-is test '(eq)) (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-type item) + ((types-equal-or-intersect (lvar-type item) (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,',eq-fun item list)))) @@ -309,63 +345,63 @@ (deftransform delete-if ((pred list) (t list)) "open code" '(do ((x list (cdr x)) - (splice '())) + (splice '())) ((endp x) list) (cond ((funcall pred (car x)) - (if (null splice) - (setq list (cdr x)) - (rplacd splice (cdr x)))) - (T (setq splice x))))) + (if (null splice) + (setq list (cdr x)) + (rplacd splice (cdr x)))) + (t (setq splice x))))) (deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) - * - :policy (> speed space)) + (vector t &key (:start t) (:end index)) + * + :policy (> speed space)) "open code" (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - (values + (values `(with-array-data ((data seq) - (start start) - (end end)) + (start start) + (end end)) (declare (type (simple-array ,element-type 1) data)) (declare (type fixnum start end)) (do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - ;; WITH-ARRAY-DATA did our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF... - (declare (optimize (safety 0))) - (setf (aref data i) item))) + ((= i end) seq) + (declare (type index i)) + ;; WITH-ARRAY-DATA did our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF... + (declare (optimize (safety 0))) + (setf (aref data i) item))) ;; ... though we still need to check that the new element can fit ;; into the vector in safe code. -- CSR, 2002-07-05 `((declare (type ,element-type item)))))) ;;;; utilities -;;; Return true if CONT's only use is a non-NOTINLINE reference to a +;;; Return true if LVAR's only use is a non-NOTINLINE reference to a ;;; global function with one of the specified NAMES. -(defun continuation-fun-is (cont names) - (declare (type continuation cont) (list names)) - (let ((use (continuation-use cont))) +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) (and (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-source-name leaf) names - :test #'equal)))))))) - -;;; If CONT is a constant continuation, the return the constant value. -;;; If it is null, then return default, otherwise quietly give up the -;;; IR1 transform. + (let ((leaf (ref-leaf use))) + (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (not (null (member (leaf-source-name leaf) names + :test #'equal)))))))) + +;;; If LVAR is a constant lvar, the return the constant value. If it +;;; is null, then return default, otherwise quietly give up the IR1 +;;; transform. ;;; ;;; ### Probably should take an ARG and flame using the NAME. -(defun constant-value-or-lose (cont &optional default) - (declare (type (or continuation null) cont)) - (cond ((not cont) default) - ((constant-continuation-p cont) - (continuation-value cont)) - (t - (give-up-ir1-transform)))) +(defun constant-value-or-lose (lvar &optional default) + (declare (type (or lvar null) lvar)) + (cond ((not lvar) default) + ((constant-lvar-p lvar) + (lvar-value lvar)) + (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 @@ -376,7 +412,7 @@ ;;; 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)) + (:copier nil)) (name nil :type symbol) (cont nil :type (or continuation null))) (defmacro make-arg (name) @@ -397,10 +433,10 @@ (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)) + (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 @@ -409,8 +445,8 @@ (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))) + (and (constant-continuation-p cont) + (eql (continuation-value cont) x))) (eql default x))) (defstruct (iterator (:copier nil)) @@ -448,65 +484,65 @@ ;;; 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)) + (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"))))) + (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 @@ -522,32 +558,32 @@ #!+sb-doc "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*" (collect ((binds) - (defs)) + (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-note - "~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))))))) + (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 @@ -557,8 +593,8 @@ `(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))) + (arg-name ,test) + (arg-name ,test-not))) (coerce-funs ((,name (if not-p ,test-not ,test) eql)) ,@body))) |# @@ -587,17 +623,19 @@ ;;; Return a form that tests the free variables STRING1 and STRING2 ;;; for the ordering relationship specified by LESSP and EQUALP. The ;;; start and end are also gotten from the environment. Both strings -;;; must be SIMPLE-STRINGs. +;;; must be SIMPLE-BASE-STRINGs. (macrolet ((def (name lessp equalp) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-string simple-string t t t t) *) + (simple-base-string simple-base-string t t t t) *) `(let* ((end1 (if (not end1) (length string1) end1)) (end2 (if (not end2) (length string2) end2)) (index (sb!impl::%sp-string-compare string1 start1 end1 string2 start2 end2))) (if index - (cond ((= index ,(if ',lessp 'end1 'end2)) index) - ((= index ,(if ',lessp 'end2 'end1)) nil) + (cond ((= index end1) + ,(if ',lessp 'index nil)) + ((= (+ index (- start2 start1)) end2) + ,(if ',lessp nil 'index)) ((,(if ',lessp 'char< 'char>) (schar string1 index) (schar string2 @@ -605,7 +643,7 @@ (+ index (truly-the fixnum (- start2 - start1)))))) + start1)))))) index) (t nil)) ,(if ',equalp 'end1 nil)))))) @@ -616,7 +654,7 @@ (macrolet ((def (name result-fun) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-string simple-string t t t t) *) + (simple-base-string simple-base-string t t t t) *) `(,',result-fun (sb!impl::%sp-string-compare string1 start1 (or end1 (length string1)) @@ -635,10 +673,6 @@ ;;;; 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. -;;;; -;;;; FIXME: It would be nicer for these transforms to work for any -;;;; calls when all arguments are vectors with the same element type, -;;;; rather than restricting them to STRINGs only. ;;; Moved here from generic/vm-tran.lisp to satisfy clisp ;;; @@ -647,36 +681,125 @@ (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) -(deftransform replace ((string1 string2 &key (start1 0) (start2 0) - end1 end2) - (simple-string simple-string &rest t) - * - ;; FIXME: consider replacing this policy test - ;; with some tests for the STARTx and ENDx - ;; indices being valid, conditional on high - ;; SAFETY code. - ;; - ;; FIXME: It turns out that this transform is - ;; critical for the performance of string - ;; streams. Make this more explicit. - :policy (< (max safety space) 3)) - `(locally - (declare (optimize (safety 0))) - (bit-bash-copy string2 - (the index - (+ (the index (* start2 sb!vm:n-byte-bits)) - ,vector-data-bit-offset)) - string1 - (the index - (+ (the index (* start1 sb!vm:n-byte-bits)) - ,vector-data-bit-offset)) - (the index - (* (min (the index (- (or end1 (length string1)) - start1)) - (the index (- (or end2 (length string2)) - start2))) - sb!vm:n-byte-bits))) - string1)) +(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: It turns out that this transform (for SIMPLE-BASE-STRINGS) +;; is critical for the performance of string streams. Make this +;; more explicit. +(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))) + 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 + (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) + * + :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 @@ -684,55 +807,64 @@ ;;; 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 simple-string) - simple-string - :policy (< safety 3)) - (collect ((lets) - (forms) - (all-lengths) - (args)) - (dolist (seq sequences) - (declare (ignorable seq)) - (let ((n-seq (gensym)) - (n-length (gensym))) - (args n-seq) - (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits)))) - (all-lengths n-length) - (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset - res start - ,n-length)) - (forms `(setq start (opaque-identity (+ start ,n-length)))))) - `(lambda (rtype ,@(args)) - (declare (ignore rtype)) - ;; KLUDGE - (flet ((opaque-identity (x) x)) - (declare (notinline opaque-identity)) - (let* (,@(lets) - (res (make-string (truncate (the index (+ ,@(all-lengths))) - sb!vm:n-byte-bits))) - (start ,vector-data-bit-offset)) - (declare (type index start ,@(all-lengths))) - ,@(forms) - res))))) + (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))))) ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (continuation-type cons)) - (null-type (specifier-type 'null))) + (let ((type (lvar-type cons)) + (null-type (specifier-type 'null))) (cond ((eq type null-type) - null-type) - ((cons-type-p type) - (cons-type-car-type type))))) + null-type) + ((cons-type-p type) + (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (continuation-type cons)) - (null-type (specifier-type 'null))) + (let ((type (lvar-type cons)) + (null-type (specifier-type 'null))) (cond ((eq type null-type) - null-type) - ((cons-type-p type) - (cons-type-cdr-type type))))) + null-type) + ((cons-type-p type) + (cons-type-cdr-type type))))) ;;;; FIND, POSITION, and their -IF and -IF-NOT variants @@ -740,135 +872,131 @@ ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline ;;; expansion, so we factor out the condition into this function. (defun check-inlineability-of-find-position-if (sequence from-end) - (let ((ctype (continuation-type sequence))) + (let ((ctype (lvar-type sequence))) (cond ((csubtypep ctype (specifier-type 'vector)) - ;; It's not worth trying to inline vector code unless we - ;; know a fair amount about it at compile time. - (upgraded-element-type-specifier-or-give-up sequence) - (unless (constant-continuation-p from-end) - (give-up-ir1-transform - "FROM-END argument value not known at compile time"))) - ((csubtypep ctype (specifier-type 'list)) - ;; Inlining on lists is generally worthwhile. - ) - (t - (give-up-ir1-transform - "sequence type not known at compile time"))))) + ;; It's not worth trying to inline vector code unless we + ;; know a fair amount about it at compile time. + (upgraded-element-type-specifier-or-give-up sequence) + (unless (constant-lvar-p from-end) + (give-up-ir1-transform + "FROM-END argument value not known at compile time"))) + ((csubtypep ctype (specifier-type 'list)) + ;; Inlining on lists is generally worthwhile. + ) + (t + (give-up-ir1-transform + "sequence type not known at compile time"))))) ;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data (macrolet ((def (name condition) - `(deftransform ,name ((predicate sequence from-end start end key) - (function list t t t function) - * - :policy (> speed space) - :important t) - "expand inline" - `(let ((index 0) - (find nil) - (position nil)) - (declare (type index index)) - (dolist (i sequence - (if (and end (> end index)) - (sb!impl::signal-bounding-indices-bad-error - sequence start end) - (values find position))) - (let ((key-i (funcall key i))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (,',condition (funcall predicate key-i) - ;; This hack of dealing with non-NIL - ;; FROM-END for list data by iterating - ;; forward through the list and keeping - ;; track of the last time we found a match - ;; might be more screwy than what the user - ;; expects, but it seems to be allowed by - ;; the ANSI standard. (And if the user is - ;; screwy enough to ask for FROM-END - ;; behavior on list data, turnabout is - ;; fair play.) - ;; - ;; It's also not enormously efficient, - ;; calling PREDICATE and KEY more often - ;; than necessary; but all the - ;; alternatives seem to have their own - ;; efficiency problems. - (if from-end - (setf find i - position index) - (return (values i index)))))) - (incf index)))))) + `(deftransform ,name ((predicate sequence from-end start end key) + (function list t t t function) + * + :policy (> speed space)) + "expand inline" + `(let ((index 0) + (find nil) + (position nil)) + (declare (type index index)) + (dolist (i sequence + (if (and end (> end index)) + (sb!impl::signal-bounding-indices-bad-error + sequence start end) + (values find position))) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (,',condition (funcall predicate key-i) + ;; This hack of dealing with non-NIL + ;; FROM-END for list data by iterating + ;; forward through the list and keeping + ;; track of the last time we found a match + ;; might be more screwy than what the user + ;; expects, but it seems to be allowed by + ;; the ANSI standard. (And if the user is + ;; screwy enough to ask for FROM-END + ;; behavior on list data, turnabout is + ;; fair play.) + ;; + ;; It's also not enormously efficient, + ;; calling PREDICATE and KEY more often + ;; than necessary; but all the + ;; alternatives seem to have their own + ;; efficiency problems. + (if from-end + (setf find i + position index) + (return (values i index)))))) + (incf index)))))) (def %find-position-if when) (def %find-position-if-not unless)) - + ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF ;;; without loss of efficiency. (I.e., the optimizer should be able ;;; to straighten everything out.) (deftransform %find-position ((item sequence from-end start end key test) - (t list t t t t t) - * - :policy (> speed space) - :important t) + (t list t t t t t) + * + :policy (> speed space)) "expand inline" '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test))) - ;; The order of arguments for asymmetric tests - ;; (e.g. #'<, as opposed to order-independent - ;; tests like #'=) is specified in the spec - ;; section 17.2.1 -- the O/Zi stuff there. - (lambda (i) - (funcall test-fun item i))) - sequence - from-end - start - end - (%coerce-callable-to-fun key))) + ;; The order of arguments for asymmetric tests + ;; (e.g. #'<, as opposed to order-independent + ;; tests like #'=) is specified in the spec + ;; section 17.2.1 -- the O/Zi stuff there. + (lambda (i) + (funcall test-fun item i))) + sequence + from-end + start + end + (%coerce-callable-to-fun key))) ;;; The inline expansions for the VECTOR case are saved as macros so ;;; that we can share them between the DEFTRANSFORMs and the default ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.) (defun %find-position-or-find-position-if-vector-expansion (sequence-arg - from-end - start - end-arg - element - done-p-expr) - (let ((offset (gensym "OFFSET")) - (block (gensym "BLOCK")) - (index (gensym "INDEX")) - (n-sequence (gensym "N-SEQUENCE-")) - (sequence (gensym "SEQUENCE")) - (n-end (gensym "N-END-")) - (end (gensym "END-"))) + from-end + start + 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)) + (,n-end ,end-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) - (,start ,start) - (,end (%check-vector-sequence-bounds - ,n-sequence ,start ,n-end))) + (,start ,start) + (,end (%check-vector-sequence-bounds + ,n-sequence ,start ,n-end))) (block ,block - (macrolet ((maybe-return () - '(let ((,element (aref ,sequence ,index))) - (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 - ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) - ;; can send us off into never-never land, since - ;; INDEX is initialized to -1.) - of-type index-or-minus-1 - from (1- ,end) downto ,start do - (maybe-return)) - (loop for ,index of-type index from ,start below ,end do - (maybe-return)))) - (values nil nil)))))) + (macrolet ((maybe-return () + ;; WITH-ARRAY-DATA has already performed bounds + ;; checking, so we can safely elide the checks + ;; 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))))))) + (if ,from-end + (loop for ,index + ;; (If we aren't fastidious about declaring that + ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) + ;; can send us off into never-never land, since + ;; INDEX is initialized to -1.) + of-type index-or-minus-1 + from (1- ,end) downto ,start do + (maybe-return)) + (loop for ,index of-type index from ,start below ,end do + (maybe-return)))) + (values nil nil)))))) (def!macro %find-position-vector-macro (item sequence - from-end start end key test) - (let ((element (gensym "ELEMENT"))) + from-end start end key test) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end @@ -881,8 +1009,8 @@ `(funcall ,test ,item (funcall ,key ,element))))) (def!macro %find-position-if-vector-macro (predicate sequence - from-end start end key) - (let ((element (gensym "ELEMENT"))) + from-end start end key) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end @@ -892,8 +1020,8 @@ `(funcall ,predicate (funcall ,key ,element))))) (def!macro %find-position-if-not-vector-macro (predicate sequence - from-end start end key) - (let ((element (gensym "ELEMENT"))) + from-end start end key) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end @@ -905,40 +1033,37 @@ ;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for ;;; VECTOR data (deftransform %find-position-if ((predicate sequence from-end start end key) - (function vector t t t function) - * - :policy (> speed space) - :important t) + (function vector t t t function) + * + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-vector-macro predicate sequence - from-end start end key)) + from-end start end key)) (deftransform %find-position-if-not ((predicate sequence from-end start end key) - (function vector t t t function) - * - :policy (> speed space) - :important t) + (function vector t t t function) + * + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-not-vector-macro predicate sequence from-end start end key)) (deftransform %find-position ((item sequence from-end start end key test) - (t vector t t t function function) - * - :policy (> speed space) - :important t) + (t vector t t t function function) + * + :policy (> speed space)) "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. (define-source-transform effective-find-position-test (test test-not) (once-only ((test test) - (test-not test-not)) + (test-not test-not)) `(cond ((and ,test ,test-not) (error "can't specify both :TEST and :TEST-NOT")) @@ -952,33 +1077,35 @@ (define-source-transform effective-find-position-key (key) (once-only ((key key)) `(if ,key - (%coerce-callable-to-fun ,key) - #'identity))) + (%coerce-callable-to-fun ,key) + #'identity))) (macrolet ((define-find-position (fun-name values-index) - `(deftransform ,fun-name ((item sequence &key - from-end (start 0) end - key test test-not)) - '(nth-value ,values-index - (%find-position item sequence - from-end start - end - (effective-find-position-key key) - (effective-find-position-test - test test-not)))))) + `(deftransform ,fun-name ((item sequence &key + from-end (start 0) end + key test test-not) + (t (or list vector) &rest t)) + '(nth-value ,values-index + (%find-position item sequence + from-end start + end + (effective-find-position-key key) + (effective-find-position-test + test test-not)))))) (define-find-position find 0) (define-find-position position 1)) (macrolet ((define-find-position-if (fun-name values-index) - `(deftransform ,fun-name ((predicate sequence &key - from-end (start 0) - end key)) - '(nth-value - ,values-index - (%find-position-if (%coerce-callable-to-fun predicate) - sequence from-end - start end - (effective-find-position-key key)))))) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key) + (t (or list vector) &rest t)) + '(nth-value + ,values-index + (%find-position-if (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) (define-find-position-if find-if 0) (define-find-position-if position-if 1)) @@ -1000,17 +1127,18 @@ ;;; perhaps it's worth optimizing the -if-not versions in the same ;;; way as the others? ;;; -;;; FIXME: Maybe remove uses of these deprecated functions (and -;;; definitely of :TEST-NOT) within the implementation of SBCL. +;;; FIXME: Maybe remove uses of these deprecated functions within the +;;; implementation of SBCL. (macrolet ((define-find-position-if-not (fun-name values-index) - `(deftransform ,fun-name ((predicate sequence &key - from-end (start 0) - end key)) - '(nth-value - ,values-index - (%find-position-if-not (%coerce-callable-to-fun predicate) - sequence from-end - start end - (effective-find-position-key key)))))) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key) + (t (or list vector) &rest t)) + '(nth-value + ,values-index + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) (define-find-position-if-not find-if-not 0) (define-find-position-if-not position-if-not 1))