X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=40040ab2576fb9d897a0a3f31b471ee59ead02a5;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=0e50c0fa1eed3b839392f8444fe9a97d93fecae3;hpb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 0e50c0f..40040ab 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -15,38 +15,42 @@ (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)))) - - (let ((call `(funcall ,fn . ,(args-to-fn))) - (endtest `(or ,@(tests)))) - (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 (cdr ,map-result)) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest ,n-first) ,call)))))))) + 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)))) + + `(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)) @@ -71,50 +75,118 @@ ;;; 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 fast) + (declare (type list seqs seq-names) + (type symbol into)) + (collect ((bindings) + (declarations) + (vector-lengths) + (tests) + (places) + (around)) + (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)))) + ((or (csubtypep type (specifier-type '(simple-array * 1))) + (and (not fast) + (csubtypep type (specifier-type 'vector)))) + (process-vector `(length ,seq-name)) + (places `(locally (declare (optimize (insert-array-bounds-checks 0))) + (aref ,seq-name index)))) + ((csubtypep type (specifier-type 'vector)) + (let ((data (gensym "DATA")) + (start (gensym "START")) + (end (gensym "END"))) + (around `(with-array-data ((,data ,seq-name) + (,start) + (,end (length ,seq-name))))) + (process-vector `(- ,end ,start)) + (places `(locally (declare (optimize (insert-array-bounds-checks 0))) + (aref ,data (truly-the index (+ index ,start))))))) + (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))) + (let ((body `(do (,@(bindings)) + ((or ,@(tests)) ,result) + (declare ,@(declarations)) + (let ((funcall-result (funcall fun ,@(places)))) + (declare (ignorable funcall-result)) + ,body)))) + (if (around) + (reduce (lambda (wrap body) (append wrap (list body))) + (around) + :from-end t + :initial-value body) + body))))) ;;; Try to compile %MAP efficiently when we can determine sequence ;;; argument types at compile time. @@ -128,427 +200,511 @@ ;;; 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) * * + :node node :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 + :fast (policy node (> speed space)))))))))))) + +;;; MAP-INTO +(deftransform map-into ((result fun &rest seqs) + (vector * &rest *) + * :node node) + "open code" + (let ((seqs-names (mapcar (lambda (x) + (declare (ignore x)) + (gensym)) + seqs))) + `(lambda (result fun ,@seqs-names) + ,(if (and (policy node (> speed space)) + (not (csubtypep (lvar-type result) + (specifier-type '(simple-array * 1))))) + (let ((data (gensym "DATA")) + (start (gensym "START")) + (end (gensym "END"))) + `(with-array-data ((,data result) + (,start) + (,end)) + (declare (ignore ,end)) + ,(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 ,data (truly-the index (+ index ,start))) + funcall-result)) + :fast t))) + (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 +;;; * (*)) (NOT (SIMPLE-ARRAY * (*)))) objects. (deftransform elt ((s i) ((simple-array * (*)) *) *) '(aref s i)) -(deftransform elt ((s i) (list *) *) +(deftransform elt ((s i) (list *) * :policy (< safety 3)) '(nth i s)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) *) - '(%aset s i v)) + '(setf (aref s i) v)) -(deftransform %setelt ((s i v) (list * *)) +(deftransform %setelt ((s i v) (list * *) * :policy (< safety 3)) '(setf (car (nthcdr i s)) v)) -(macrolet ((def (name) - `(deftransform ,name ((e l &key (test #'eql)) * * - :node node) - (unless (constant-continuation-p l) - (give-up-ir1-transform)) - - (let ((val (continuation-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 (continuation-fun-is test '(eq)) - (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-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)) +(deftransform %check-vector-sequence-bounds ((vector start end) + (vector * *) * + :node node) + (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) + (sequence-bounding-indices-bad-error vector start end))))) + +(def!type eq-comparable-type () + '(or fixnum (not number))) + +;;; True if EQL comparisons involving type can be simplified to EQ. +(defun eq-comparable-type-p (type) + (csubtypep type (specifier-type 'eq-comparable-type))) + +(defun specialized-list-seek-function-name (function-name key-functions &optional variant) + (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)) + (when variant + (write-char #\- s) + (write-string (symbol-name variant) s))) + (load-time-value (find-package "SB!KERNEL"))) + (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S" + function-name key-functions variant))) + +(defparameter *list-open-code-limit* 128) + +(defun transform-list-item-seek (name item list key test test-not node) + (when (and test test-not) + (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name)) + ;; If TEST is EQL, drop it. + (when (and test (lvar-fun-is test '(eql))) + (setf test nil)) + ;; Ditto for KEY IDENTITY. + (when (and key (lvar-fun-is key '(identity))) + (setf key nil)) + ;; 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 + ;; ensures it is a function. + (multiple-value-bind (key key-form) + (when 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 (ensure-lvar-fun-form key 'key)))))) + (let* ((c-test (cond ((and test (lvar-fun-is test '(eq))) + (setf test nil) + 'eq) + ((and (not test) (not test-not)) + (when (eq-comparable-type-p (lvar-type item)) + 'eq)))) + (funs (delete nil (list (when key (list key 'key)) + (when test (list test 'test)) + (when test-not (list 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))) + (c-test `(,c-test item ,target-expr)) + (t `(eql item ,target-expr))))) + (labels ((open-code (tail) + (when tail + `(if (let ((this ',(car tail))) + ,(ecase name + ((assoc rassoc) + (let ((cxx (if (eq name 'assoc) 'car 'cdr))) + `(and this (let ((target (,cxx this))) + ,test-expr)))) + (member + `(let ((target this)) + ,test-expr)))) + ',(ecase name + ((assoc rassoc) (car tail)) + (member tail)) + ,(open-code (cdr tail))))) + (ensure-fun (args) + (if (eq 'key (second args)) + key-form + (apply #'ensure-lvar-fun-form args)))) + (let* ((cp (constant-lvar-p list)) + (c-list (when cp (lvar-value list)))) + (cond ((and cp c-list (member name '(assoc rassoc member)) + (policy node (>= speed space)) + (not (nthcdr *list-open-code-limit* c-list))) + `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs) + ,(open-code c-list))) + ((and cp (not c-list)) + ;; constant nil list + (if (eq name 'adjoin) + '(list item) + nil)) + (t + ;; specialized out-of-line version + `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test) + item list ,@(mapcar #'ensure-fun funs))))))))) + +(defun transform-list-pred-seek (name pred list key node) + ;; If KEY is IDENTITY, drop it. + (when (and key (lvar-fun-is key '(identity))) + (setf key nil)) + ;; 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 + ;; ensures it is a function. + (multiple-value-bind (key key-form) + (when 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 (ensure-lvar-fun-form key 'key)))))) + (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target))) + (pred-expr (ensure-lvar-fun-form pred 'pred))) + (when (member name '(member-if-not assoc-if-not rassoc-if-not)) + (setf test-expr `(not ,test-expr))) + (labels ((open-code (tail) + (when tail + `(if (let ((this ',(car tail))) + ,(ecase name + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr))) + `(and this (let ((target (,cxx this))) + ,test-expr)))) + ((member-if member-if-not) + `(let ((target this)) + ,test-expr)))) + ',(ecase name + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (car tail)) + ((member-if member-if-not) + tail)) + ,(open-code (cdr tail)))))) + (let* ((cp (constant-lvar-p list)) + (c-list (when cp (lvar-value list)))) + (cond ((and cp c-list (policy node (>= speed space)) + (not (nthcdr *list-open-code-limit* c-list))) + `(let ((pred ,pred-expr) + ,@(when key `((key ,key-form)))) + ,(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 (when key '(key))) + ,pred-expr list ,@(when key (list key-form)))))))))) + +(macrolet ((def (name &optional if/if-not) + (let ((basic (symbolicate "%" name)) + (basic-eq (symbolicate "%" name "-EQ")) + (basic-key (symbolicate "%" name "-KEY")) + (basic-key-eq (symbolicate "%" name "-KEY-EQ"))) + `(progn + (deftransform ,name ((item list &key key test test-not) * * :node node) + (transform-list-item-seek ',name item list key test test-not node)) + (deftransform ,basic ((item list) (eq-comparable-type t)) + `(,',basic-eq item list)) + (deftransform ,basic-key ((item list) (eq-comparable-type t)) + `(,',basic-key-eq item list)) + ,@(when if/if-not + (let ((if-name (symbolicate name "-IF")) + (if-not-name (symbolicate name "-IF-NOT"))) + `((deftransform ,if-name ((pred list &key key) * * :node node) + (transform-list-pred-seek ',if-name pred list key node)) + (deftransform ,if-not-name ((pred list &key key) * * :node node) + (transform-list-pred-seek ',if-not-name pred list key node))))))))) + (def adjoin) + (def assoc t) + (def member t) + (def rassoc t)) + +(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" + (let ((type (lvar-type item))) + (unless (or (and test (lvar-fun-is test '(eq))) + (and (eq-comparable-type-p type) + (or (not test) (lvar-fun-is test '(eql))))) + (give-up-ir1-transform))) + `(delq item list)) (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))))) - -(deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) - * - :policy (> speed space)) - "open code" - (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - (values - `(with-array-data ((data seq) - (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))) - ;; ... 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 -;;; 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))) - (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. -;;; -;;; ### 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)))) - -;;; 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-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))))))) - -;;; 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))) -|# + (if (null splice) + (setq list (cdr x)) + (rplacd splice (cdr x)))) + (t (setq splice x))))) + +(deftransform fill ((seq item &key (start 0) (end nil)) + (list t &key (:start t) (:end t))) + '(list-fill* seq item start end)) + +(deftransform fill ((seq item &key (start 0) (end nil)) + (vector t &key (:start t) (:end t)) + * + :node node) + (let* ((type (lvar-type seq)) + (element-ctype (array-type-upgraded-element-type type)) + (element-type (type-specifier element-ctype)) + (saetp (unless (eq *wild-type* element-ctype) + (find-saetp-by-ctype element-ctype)))) + (cond ((eq *wild-type* element-ctype) + (delay-ir1-transform node :constraint) + `(vector-fill* seq item start end)) + ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp)) + (let* ((n-bits (sb!vm:saetp-n-bits saetp)) + (basher-name (format nil "UB~D-BASH-FILL" n-bits)) + (basher (or (find-symbol basher-name + (load-time-value (find-package :sb!kernel))) + (abort-ir1-transform + "Unknown fill basher, please report to sbcl-devel: ~A" + basher-name))) + (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged) + ((member element-type '(character base-char)) :char) + ((eq element-type 'single-float) :single-float) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((eq element-type 'double-float) :double-float) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((equal element-type '(complex single-float)) + :complex-single-float) + (t + (aver (integer-type-p element-ctype)) + :bits))) + ;; BASH-VALUE is a word that we can repeatedly smash + ;; on the array: for less-than-word sized elements it + ;; contains multiple copies of the fill item. + (bash-value + (if (constant-lvar-p item) + (let ((tmp (lvar-value item))) + (unless (ctypep tmp element-ctype) + (abort-ir1-transform "~S is not ~S" tmp element-type)) + (let* ((bits + (ldb (byte n-bits 0) + (ecase kind + (:tagged + (ash tmp sb!vm:n-fixnum-tag-bits)) + (:char + (char-code tmp)) + (:bits + tmp) + (:single-float + (single-float-bits tmp)) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (:double-float + (logior (ash (double-float-high-bits tmp) 32) + (double-float-low-bits tmp))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (:complex-single-float + (logior (ash (single-float-bits (imagpart tmp)) 32) + (ldb (byte 32 0) + (single-float-bits (realpart tmp)))))))) + (res bits)) + (loop for i of-type sb!vm:word from n-bits by n-bits + until (= i sb!vm:n-word-bits) + do (setf res (ldb (byte sb!vm:n-word-bits 0) + (logior res (ash bits i))))) + res)) + (progn + (delay-ir1-transform node :constraint) + `(let* ((bits (ldb (byte ,n-bits 0) + ,(ecase kind + (:tagged + `(ash item ,sb!vm:n-fixnum-tag-bits)) + (:char + `(char-code item)) + (:bits + `item) + (:single-float + `(single-float-bits item)) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (:double-float + `(logior (ash (double-float-high-bits item) 32) + (double-float-low-bits item))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (:complex-single-float + `(logior (ash (single-float-bits (imagpart item)) 32) + (ldb (byte 32 0) + (single-float-bits (realpart item)))))))) + (res bits)) + (declare (type sb!vm:word res)) + ,@(unless (= sb!vm:n-word-bits n-bits) + `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits + until (= i sb!vm:n-word-bits) + do (setf res + (ldb (byte ,sb!vm:n-word-bits 0) + (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i)))))))) + res))))) + (values + ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up + ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization. + (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*)))) + `(let* ((len (length seq)) + (end (or end len)) + (bound (1+ end))) + ;; Minor abuse %CHECK-BOUND for bounds checking. + ;; (- END START) may still end up negative, but + ;; the basher handle that. + (,basher ,bash-value seq + (%check-bound seq bound start) + (- (if end (%check-bound seq bound end) len) + start))) + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + (declare (optimize (safety 0) (speed 3))) + (,basher ,bash-value data start (- end start)) + seq)) + `((declare (type ,element-type item)))))) + ((policy node (> speed space)) + (values + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + ;; 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) (speed 3))) + (do ((i start (1+ i))) + ((= i end) seq) + (declare (type index i)) + (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))))) + ((csubtypep type (specifier-type 'string)) + '(string-fill* seq item start end)) + (t + '(vector-fill* seq item start end))))) + +(deftransform fill ((seq item &key (start 0) (end nil)) + ((and sequence (not vector) (not list)) t &key (:start t) (:end t))) + `(sb!sequence:fill seq item + :start start + :end (%check-generic-sequence-bounds seq start end))) ;;;; 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 @@ -570,17 +726,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 @@ -588,7 +746,7 @@ (+ index (truly-the fixnum (- start2 - start1)))))) + start1)))))) index) (t nil)) ,(if ',equalp 'end1 nil)))))) @@ -599,7 +757,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)) @@ -608,114 +766,500 @@ (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. -;;;; -;;;; 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. +;;;; transforms for sequence functions -;;; Moved here from generic/vm-tran.lisp to satisfy clisp -;;; -;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use -;;; use that here, so that the compiler is born knowing this value. -;;; FIXME: Add a comment telling whether this holds for all vectors -;;; or only for vectors based on simple arrays (non-adjustable, etc.). +;;; 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)) -;;; FIXME: Shouldn't we be testing for legality of -;;; * START1, START2, END1, and END2 indices? -;;; * size of copied string relative to destination string? -;;; (Either there should be tests conditional on SAFETY>=SPEED, or -;;; the transform should be conditional on SPEED>SAFETY.) +;;; FIXME: In the copy loops below, we code the loops in a strange +;;; fashion: ;;; -;;; FIXME: Also, the transform should probably be dependent on -;;; SPEED>SPACE. -(deftransform replace ((string1 string2 &key (start1 0) (start2 0) - end1 end2) - (simple-string simple-string &rest t)) - `(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)) - -;;; 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. +;;; (do ((i (+ src-offset length) (1- i))) +;;; ((<= i 0) ...) +;;; (... (aref foo (1- i)) ...)) ;;; -;;; FIXME: currently KLUDGEed because of bug 188 -(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))))) +;;; 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 (#-sb-xc :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) + `(let* ((len1 (length seq1)) + (len2 (length seq2)) + (end1 (or end1 len1)) + (end2 (or end2 len2)) + (replace-len (min (- end1 start1) (- end2 start2)))) + ,(unless (policy node (= insert-array-bounds-checks 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 (sb!vm:valid-bit-bash-saetp-p saetp)) + (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) + (bash-function (intern (format nil "UB~D-BASH-COPY" + n-element-bits) + (find-package "SB!KERNEL")))) + `(funcall (function ,bash-function) seq2 start2 + seq1 start1 replace-len))) + (t + `(if (and + ;; If the sequence types are different, SEQ1 and + ;; SEQ2 must be distinct arrays. + ,(eql sequence-type1 sequence-type2) + (eq seq1 seq2) (> start1 start2)) + (do ((i (truly-the index (+ start1 replace-len -1)) + (1- i)) + (j (truly-the index (+ start2 replace-len -1)) + (1- j))) + ((< i start1)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref seq1 i) (aref seq2 j))) + (do ((i start1 (1+ i)) + (j start2 (1+ j)) + (end (+ start1 replace-len))) + ((>= 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 (make-replace-transform saetp sequence-type sequence-type) + into forms + finally (return `(progn ,@forms)))) + (define-one-transform (sequence-type1 sequence-type2) + (make-replace-transform nil sequence-type1 sequence-type2))) + (define-replace-transforms) + #!+sb-unicode + (progn + (define-one-transform (simple-array base-char (*)) (simple-array character (*))) + (define-one-transform (simple-array character (*)) (simple-array base-char (*))))) + +;;; 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)))) + (values)))))) + +#.(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))) + (policy node (> speed space))) + (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) + (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) (vector)) + (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)) + (result (make-array length :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) + result))) + (t + '(vector-subseq* seq 0 nil))))) + +(deftransform copy-seq ((seq) (list)) + '(list-copy-seq* seq)) + +(deftransform copy-seq ((seq) ((and sequence (not vector) (not list)))) + '(sb!sequence:copy-seq seq)) + +;;; 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))) + "open code" + (flet ((maybe (x) + (when (lvar-p x) + (if (constant-lvar-p x) + (when (lvar-value x) + :yes) + :maybe)))) + (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))) + (key? (maybe key)) + (test? (maybe 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)) + ,@(case key? + (:yes `((key (%coerce-callable-to-fun key)))) + (:maybe `((key (when key + (%coerce-callable-to-fun key)))))) + ,@(when test? + `((test (%coerce-callable-to-fun test))))) + (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)))) + (when (= end1 start1) + (return-from search (if from-end + end2 + start2))) + (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 test? + `(funcall test) + `(eql)) + ,(case key? + (:yes `(funcall key (aref pattern index1))) + (:maybe `(let ((elt (aref pattern index1))) + (if key + (funcall key elt) + elt))) + (otherwise `(aref pattern index1))) + ,(case key? + (:yes `(funcall key (aref text index2))) + (:maybe `(let ((elt (aref text index2))) + (if key + (funcall key elt) + elt))) + (otherwise `(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 +;;; +;;; 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. +;;; +;;; Limit full open coding based on length of constant sequences. Default +;;; value is chosen so that other parts of the compiler (constraint propagation +;;; mainly) won't go nonlinear too badly. It's not an exact number -- but +;;; in the right ballpark. +(defvar *concatenate-open-code-limit* 129) + +(deftransform concatenate ((result-type &rest lvars) + ((constant-arg + (member string simple-string base-string simple-base-string)) + &rest sequence) + * :node node) + (let ((vars (loop for x in lvars collect (gensym))) + (type (lvar-value result-type))) + (if (policy node (<= speed space)) + ;; Out-of-line + `(lambda (.dummy. ,@vars) + (declare (ignore .dummy.)) + ,(ecase type + ((string simple-string) + `(%concatenate-to-string ,@vars)) + ((base-string simple-base-string) + `(%concatenate-to-base-string ,@vars)))) + ;; Inline + (let* ((element-type (ecase type + ((string simple-string) 'character) + ((base-string simple-base-string) 'base-char))) + (lvar-values (loop for lvar in lvars + collect (when (constant-lvar-p lvar) + (lvar-value lvar)))) + (lengths + (loop for value in lvar-values + for var in vars + collect (if value + (length value) + `(sb!impl::string-dispatch ((simple-array * (*)) + sequence) + ,var + (declare (muffle-conditions compiler-note)) + (length ,var))))) + (non-constant-start + (loop for value in lvar-values + while (and (stringp value) + (< (length value) *concatenate-open-code-limit*)) + sum (length value)))) + `(apply + (lambda ,vars + (declare (ignorable ,@vars)) + (declare (optimize (insert-array-bounds-checks 0))) + (let* ((.length. (+ ,@lengths)) + (.pos. ,non-constant-start) + (.string. (make-string .length. :element-type ',element-type))) + (declare (type index .length. .pos.) + (muffle-conditions compiler-note)) + ,@(loop with first-constants = t + for first = t then nil + for value in lvar-values + for var in vars + collect + (cond ((and (stringp value) + (< (length value) *concatenate-open-code-limit*)) + ;; Fold the array reads for constant arguments + `(progn + ,@(loop for c across value + for i from 0 + collect + ;; Without truly-the we get massive numbers + ;; of pointless error traps. + `(setf (aref .string. + (truly-the index ,(if first-constants + i + `(+ .pos. ,i)))) + ,c)) + ,(unless first-constants + `(incf (truly-the index .pos.) ,(length value))))) + (t + (prog1 + `(sb!impl::string-dispatch + (#!+sb-unicode + (simple-array character (*)) + (simple-array base-char (*)) + t) + ,var + (replace .string. ,var + ,@(cond ((not first-constants) + '(:start1 .pos.)) + ((plusp non-constant-start) + `(:start1 ,non-constant-start)))) + (incf (truly-the index .pos.) (length ,var))) + (setf first-constants nil))))) + .string.)) + lvars))))) ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (continuation-type cons)) - (null-type (specifier-type 'null))) + ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference + ;; gets confused by things like (SETF CAR). + (let ((type (lvar-conservative-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-conservative-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 @@ -723,146 +1267,138 @@ ;;; %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 (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 ((find nil) + (position nil)) + (flet ((bounds-error () + (sequence-bounding-indices-bad-error sequence start end))) + (if (and end (> start end)) + (bounds-error) + (do ((slow sequence (cdr slow)) + (fast (cdr sequence) (cddr fast)) + (index 0 (+ index 1))) + ((cond ((null slow) + (if (and end (> end index)) + (bounds-error) + (return (values find position)))) + ((and end (>= index end)) + (return (values find position))) + ((eq slow fast) + (circular-list-error sequence))) + (bug "never")) + (declare (list slow fast)) + (when (>= index start) + (let* ((element (car slow)) + (key-i (funcall key element))) + (,',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 element + position index) + (return (values element 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))) - ;; I'm having difficulty believing I'm - ;; reading it right, but as far as I can see, - ;; the only guidance that ANSI gives for the - ;; order of arguments to asymmetric tests is - ;; the character-set dependent example from - ;; the definition of FIND, - ;; (find #\d "here are some.." :test #'char>) - ;; => #\Space - ;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.) - ;; (Neither the POSITION definition page nor - ;; section 17.2 ("Rules about Test Functions") - ;; seem to consider the possibility of - ;; asymmetry.) - ;; - ;; So, judging from the example, we want to - ;; do (FUNCALL TEST-FUN ITEM I), because - ;; (FUNCALL #'CHAR> #\d #\SPACE)=>T. - ;; - ;; -- WHN (whose attention was drawn to it by - ;; Alexey Dejneka's bug report/fix) - (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-"))) - `(let ((,n-sequence ,sequence-arg) - (,n-end ,end-arg)) + from-end + start + end-arg + element + done-p-expr) + (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 (or ,n-end (length ,n-sequence)))) + (,start ,start) + (,end ,end-arg) + :check-fill-pointer t) (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 @@ -875,8 +1411,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 @@ -886,8 +1422,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 @@ -899,76 +1435,128 @@ ;;; %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)) + +(deftransform %find-position ((item sequence from-end start end key test) + (t bit-vector t t t t t) + * :node node) + (when (and test (lvar-fun-is test '(eq eql equal))) + (setf test nil)) + (when (and key (lvar-fun-is key '(identity))) + (setf key nil)) + (when (or test key) + (delay-ir1-transform node :optimize) + (give-up-ir1-transform "non-trivial :KEY or :TEST")) + (catch 'not-a-bit + `(with-array-data ((bits sequence :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) + (let ((p ,(if (constant-lvar-p item) + (case (lvar-value item) + (0 `(%bit-position/0 bits from-end start end)) + (1 `(%bit-position/1 bits from-end start end)) + (otherwise (throw 'not-a-bit `(values nil nil)))) + `(%bit-position item bits from-end start end)))) + (if p + (values item (the index (- (truly-the index p) offset))) + (values nil nil)))))) + +(deftransform %find-position ((item sequence from-end start end key test) + (character string t t t function function) + * + :policy (> speed space)) + (if (eq '* (upgraded-element-type-specifier sequence)) + (let ((form + `(sb!impl::string-dispatch ((simple-array character (*)) + (simple-array base-char (*)) + (simple-array nil (*))) + sequence + (%find-position item sequence from-end start end key test)))) + (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string)) + form + ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from + ;; %FIND-POSITION. + `(with-array-data ((sequence sequence :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) + (multiple-value-bind (elt index) ,form + (values elt (when (fixnump index) (- index offset))))))) + ;; The type is known exactly, other transforms will take care of it. + (give-up-ir1-transform))) ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, ;;; POSITION-IF, etc. (define-source-transform effective-find-position-test (test test-not) - `(cond - ((and ,test ,test-not) - (error "can't specify both :TEST and :TEST-NOT")) - (,test (%coerce-callable-to-fun ,test)) - (,test-not - ;; (Without DYNAMIC-EXTENT, this is potentially horribly - ;; inefficient, but since the TEST-NOT option is deprecated - ;; anyway, we don't care.) - (complement (%coerce-callable-to-fun ,test-not))) - (t #'eql))) + (once-only ((test test) + (test-not test-not)) + `(cond + ((and ,test ,test-not) + (error "can't specify both :TEST and :TEST-NOT")) + (,test (%coerce-callable-to-fun ,test)) + (,test-not + ;; (Without DYNAMIC-EXTENT, this is potentially horribly + ;; inefficient, but since the TEST-NOT option is deprecated + ;; anyway, we don't care.) + (complement (%coerce-callable-to-fun ,test-not))) + (t #'eql)))) (define-source-transform effective-find-position-key (key) - `(if ,key - (%coerce-callable-to-fun ,key) - #'identity)) + (once-only ((key key)) + `(if ,key + (%coerce-callable-to-fun ,key) + #'identity))) (macrolet ((define-find-position (fun-name values-index) - `(define-source-transform ,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) - `(define-source-transform ,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)) @@ -990,17 +1578,129 @@ ;;; 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) - `(define-source-transform ,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)) + +(macrolet ((define-trimmer-transform (fun-name leftp rightp) + `(deftransform ,fun-name ((char-bag string) + (t simple-string)) + (let ((find-expr + (if (constant-lvar-p char-bag) + ;; If the bag is constant, use MEMBER + ;; instead of FIND, since we have a + ;; deftransform for MEMBER that can + ;; open-code all of the comparisons when + ;; the list is constant. -- JES, 2007-12-10 + `(not (member (schar string index) + ',(coerce (lvar-value char-bag) 'list) + :test #'char=)) + '(not (find (schar string index) char-bag :test #'char=))))) + `(flet ((char-not-in-bag (index) + ,find-expr)) + (let* ((end (length string)) + (left-end (if ,',leftp + (do ((index 0 (1+ index))) + ((or (= index (the fixnum end)) + (char-not-in-bag index)) + index) + (declare (fixnum index))) + 0)) + (right-end (if ,',rightp + (do ((index (1- end) (1- index))) + ((or (< index left-end) + (char-not-in-bag index)) + (1+ index)) + (declare (fixnum index))) + end))) + (if (and (eql left-end 0) + (eql right-end (length string))) + string + (subseq string left-end right-end)))))))) + (define-trimmer-transform string-left-trim t nil) + (define-trimmer-transform string-right-trim nil t) + (define-trimmer-transform string-trim t t)) + + +;;; (partially) constant-fold backq-* functions, or convert to their +;;; plain CL equivalent (now that they're not needed for pprinting). + +;; Pop constant values from the end, list/list* them if any, and link +;; the remainder with list* at runtime. +(defun transform-backq-list-or-list* (function values) + (let ((gensyms (make-gensym-list (length values))) + (reverse (reverse values)) + (constants '())) + (loop while (and reverse + (constant-lvar-p (car reverse))) + do (push (lvar-value (pop reverse)) + constants)) + (if (null constants) + `(lambda ,gensyms + (,function ,@gensyms)) + (let ((tail (apply function constants))) + (if (null reverse) + `',tail + (let* ((nvariants (length reverse)) + (variants (subseq gensyms 0 nvariants))) + `(lambda ,gensyms + (declare (ignore ,@(subseq gensyms nvariants))) + ,(if tail + `(list* ,@variants ',tail) + `(list ,@variants))))))))) + +(deftransform sb!impl::backq-list ((&rest elts)) + (transform-backq-list-or-list* 'list elts)) + +(deftransform sb!impl::backq-list* ((&rest elts)) + (transform-backq-list-or-list* 'list* elts)) + +;; Merge adjacent constant values +(deftransform sb!impl::backq-append ((&rest elts)) + (let ((gensyms (make-gensym-list (length elts))) + (acc nil) + (ignored '()) + (arguments '())) + (flet ((convert-accumulator () + (let ((constant (apply 'append (nreverse (shiftf acc nil))))) + (when constant + (push `',constant arguments))))) + (loop for gensym in gensyms + for (elt . next) on elts by #'cdr + do (cond ((constant-lvar-p elt) + (let ((elt (lvar-value elt))) + (when (and next (not (proper-list-p elt))) + (abort-ir1-transform + "Non-list or improper list spliced in ~ + the middle of a backquoted list.")) + (push gensym ignored) + (push elt acc))) + (t + (convert-accumulator) + (push gensym arguments))) + finally (convert-accumulator))) + (let ((arguments (nreverse arguments))) + `(lambda ,gensyms + (declare (ignore ,@ignored)) + (append ,@arguments))))) + +;; Nothing special for nconc +(define-source-transform sb!impl::backq-nconc (&rest elts) + `(nconc ,@elts)) + +;; cons and vector are handled with regular constant folding... +;; but we still want to convert backq-cons into cl:cons. +(deftransform sb!impl::backq-cons ((x y)) + `(cons x y))