X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=40040ab2576fb9d897a0a3f31b471ee59ead02a5;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=eaf85fdfe82167c81ef38158739f007f5294a0b6;hpb=1db4f16ef02f5b4d699d78541edb19ad8f3defc8;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index eaf85fd..40040ab 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -126,14 +126,15 @@ ;;; 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) +(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)) + (places) + (around)) (let ((found-vector-p nil)) (flet ((process-vector (length) (unless found-vector-p @@ -150,10 +151,22 @@ (declarations `(type list ,index)) (places `(car ,index)) (tests `(endp ,index)))) - ((csubtypep type (specifier-type 'vector)) + ((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")))) @@ -162,12 +175,18 @@ (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))))) + (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. @@ -182,7 +201,7 @@ ;;; 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 seq &rest seqs) * * - :policy (>= speed space)) + :node node :policy (>= speed space)) "open code" (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) @@ -244,25 +263,45 @@ ,(build-sequence-iterator seqs seq-args :result result - :body push-dacc)))))))))) + :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) - ,(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))) + ,(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))) @@ -276,7 +315,7 @@ '(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 * *) * :policy (< safety 3)) '(setf (car (nthcdr i s)) v)) @@ -291,6 +330,13 @@ (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 @@ -309,7 +355,11 @@ (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)) @@ -330,15 +380,16 @@ (%coerce-callable-to-fun key) #'identity))) (t - (values key '(%coerce-callable-to-fun key)))))) + (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 (remove nil (list (and key 'key) (cond (test 'test) - (test-not 'test-not))))) + (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))) @@ -359,15 +410,16 @@ ((assoc rassoc) (car tail)) (member tail)) ,(open-code (cdr tail))))) - (ensure-fun (fun) - (if (eq 'key fun) + (ensure-fun (args) + (if (eq 'key (second args)) key-form - `(%coerce-callable-to-fun ,fun)))) + (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))) - `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs) + (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 @@ -376,7 +428,7 @@ nil)) (t ;; specialized out-of-line version - `(,(specialized-list-seek-function-name name funs c-test) + `(,(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) @@ -397,11 +449,9 @@ (%coerce-callable-to-fun key) #'identity))) (t - (values key '(%coerce-callable-to-fun key)))))) + (values key (ensure-lvar-fun-form key 'key)))))) (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target))) - (pred-expr (if (csubtypep (lvar-type pred) (specifier-type 'function)) - 'pred - '(%coerce-callable-to-fun pred)))) + (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) @@ -423,7 +473,8 @@ ,(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))) + (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))) @@ -436,16 +487,24 @@ ,pred-expr list ,@(when key (list key-form)))))))))) (macrolet ((def (name &optional if/if-not) - `(progn - (deftransform ,name ((item list &key key test test-not) * * :node node) - (transform-list-item-seek ',name item list key test test-not node)) - ,@(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)))))))) + (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) @@ -466,21 +525,11 @@ ;;; almost as fast as MEMQ. (deftransform delete ((item list &key test) (t list &rest t) *) "convert to EQ test" - ;; FIXME: The scope of this transformation could be - ;; widened somewhat, letting it work whenever the test is - ;; 'EQL and we know from the type of ITEM that it #'EQ - ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, - ;; and SYMBOL.) - ;; If TEST is EQ, apply transform, else - ;; if test is not EQL, then give up on transform, else - ;; if ITEM is not a NUMBER or is a FIXNUM, apply - ;; transform, else give up on transform. - (cond (test - (unless (lvar-fun-is test '(eq)) - (give-up-ir1-transform))) - ((types-equal-or-intersect (lvar-type item) - (specifier-type 'number)) - (give-up-ir1-transform "Item might be a number."))) + (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)) @@ -502,9 +551,122 @@ (vector t &key (:start t) (:end t)) * :node node) - (let ((type (lvar-type seq)) - (element-type (type-specifier (extract-upgraded-element-type seq)))) - (cond ((and (neq '* element-type) (policy node (> speed space))) + (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) @@ -533,22 +695,6 @@ :start start :end (%check-generic-sequence-bounds seq start end))) -;;;; utilities - -;;; 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 (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)))) - - ;;;; hairy sequence transforms ;;; FIXME: no hairy sequence transforms in SBCL? @@ -627,20 +773,6 @@ (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) -(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: In the copy loops below, we code the loops in a strange ;;; fashion: ;;; @@ -678,57 +810,50 @@ ;;; you tweak it, make sure that you compare the disassembly, if not the ;;; performance of, the functions implementing string streams ;;; (e.g. SB!IMPL::STRING-OUCH). -(eval-when (:compile-toplevel :load-toplevel :execute) +(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) - ,(cond - ((and saetp (valid-bit-bash-saetp-p saetp)) nil) - ;; If the sequence types are different, SEQ1 and SEQ2 must - ;; be distinct arrays, and we can open code the copy loop. - ((not (eql sequence-type1 sequence-type2)) nil) - ;; If we're not bit-bashing, only allow cases where we - ;; can determine the order of copying up front. (There - ;; are actually more cases we can handle if we know the - ;; amount that we're copying, but this handles the - ;; common cases.) - (t '(unless (= (constant-value-or-lose start1 0) - (constant-value-or-lose start2 0)) - (give-up-ir1-transform)))) `(let* ((len1 (length seq1)) (len2 (length seq2)) (end1 (or end1 len1)) (end2 (or end2 len2)) - (replace-len1 (- end1 start1)) - (replace-len2 (- end2 start2))) - ,(unless (policy node (= safety 0)) + (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)))) + (unless (<= 0 start1 end1 len1) + (sequence-bounding-indices-bad-error seq1 start1 end1)) + (unless (<= 0 start2 end2 len2) + (sequence-bounding-indices-bad-error seq2 start2 end2)))) ,',(cond - ((and saetp (valid-bit-bash-saetp-p saetp)) - (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) - (bash-function (intern (format nil "UB~D-BASH-COPY" - n-element-bits) - (find-package "SB!KERNEL")))) - `(funcall (function ,bash-function) seq2 start2 - seq1 start1 (min replace-len1 replace-len2)))) - (t - ;; We can expand the loop inline here because we - ;; would have given up the transform (see above) - ;; if we didn't have constant matching start - ;; indices. - '(do ((i start1 (1+ i)) - (j start2 (1+ j)) - (end (+ start1 - (min replace-len1 replace-len2)))) - ((>= i end)) - (declare (optimize (insert-array-bounds-checks 0))) - (setf (aref seq1 i) (aref seq2 j))))) + ((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 @@ -882,7 +1007,8 @@ (let ((type (lvar-type seq))) (cond ((and (array-type-p type) - (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (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))) @@ -897,8 +1023,6 @@ 'start) 'result 0 'size element-type) result)))) - ((csubtypep type (specifier-type 'string)) - '(string-subseq* seq start end)) (t '(vector-subseq* seq start end))))) @@ -919,8 +1043,6 @@ (result (make-array length :element-type ',element-type))) ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) result))) - ((csubtypep type (specifier-type 'string)) - '(string-subseq* seq 0 nil)) (t '(vector-subseq* seq 0 nil))))) @@ -942,127 +1064,189 @@ :node node :policy (> speed (max space safety))) "open code" - (let ((from-end (when (lvar-p from-end) - (unless (constant-lvar-p from-end) - (give-up-ir1-transform ":FROM-END is not constant.")) - (lvar-value from-end))) - (keyp (lvar-p key)) - (testp (lvar-p test)) - (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) - `(block search - (flet ((oops (vector start end) - (sequence-bounding-indices-bad-error vector start end))) - (let* ((len1 (length pattern)) - (len2 (length text)) - (end1 (or end1 len1)) - (end2 (or end2 len2)) - ,@(when keyp - '((key (coerce key 'function)))) - ,@(when testp - '((test (coerce test 'function))))) - (declare (type index start1 start2 end1 end2)) - ,@(when check-bounds-p - `((unless (<= start1 end1 len1) - (oops pattern start1 end1)) - (unless (<= start2 end2 len2) - (oops pattern start2 end2)))) - (do (,(if from-end - '(index2 (- end2 (- end1 start1)) (1- index2)) - '(index2 start2 (1+ index2)))) - (,(if from-end - '(< index2 start2) - '(>= index2 end2)) - nil) - ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop - ;; terminates is hits -1 when :FROM-END is true and :START2 - ;; is 0. - (declare (type fixnum index2)) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((>= index1 end1) t) - (declare (type index index1 index2) - (optimize (insert-array-bounds-checks 0))) - ,@(unless from-end - '((when (= index2 end2) - (return-from search nil)))) - (unless (,@(if testp - '(funcall test) - '(eql)) - ,(if keyp - '(funcall key (aref pattern index1)) - '(aref pattern index1)) - ,(if keyp - '(funcall key (aref text index2)) - '(aref text index2))) - (return nil))) - (return index2)))))))) + (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) - (symbol &rest sequence) - * - :policy (> speed space)) - (unless (constant-lvar-p result-type) - (give-up-ir1-transform)) - (let* ((element-type (let ((type (lvar-value result-type))) - ;; Only handle the simple result type cases. If - ;; somebody does (CONCATENATE '(STRING 6) ...) - ;; their code won't be optimized, but nobody does - ;; that in practice. - (case type - ((string simple-string) 'character) - ((base-string simple-base-string) 'base-char) - (t (give-up-ir1-transform))))) - (vars (loop for x in lvars collect (gensym))) - (lvar-values (loop for lvar in lvars - collect (when (constant-lvar-p lvar) - (lvar-value lvar)))) - (lengths - (loop for value in lvar-values - for var in vars - collect (if value - (length value) - `(sb!impl::string-dispatch ((simple-array * (*)) - sequence) - ,var - (declare (muffle-conditions compiler-note)) - (length ,var)))))) - `(apply - (lambda ,vars - (declare (ignorable ,@vars)) - (let* ((.length. (+ ,@lengths)) - (.pos. 0) - (.string. (make-string .length. :element-type ',element-type))) - (declare (type index .length. .pos.) - (muffle-conditions compiler-note)) - ,@(loop for value in lvar-values - for var in vars - collect (if (stringp value) - ;; Fold the array reads for constant arguments - `(progn - ,@(loop for c across value - collect `(setf (aref .string. - .pos.) ,c) - collect `(incf .pos.))) - `(sb!impl::string-dispatch - (#!+sb-unicode - (simple-array character (*)) - (simple-array base-char (*)) - t) - ,var - (replace .string. ,var :start1 .pos.) - (incf .pos. (length ,var))))) - .string.)) - lvars))) + ((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 (lvar-type cons)) + ;; 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) @@ -1070,7 +1254,7 @@ (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (lvar-type cons)) + (let ((type (lvar-conservative-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -1105,41 +1289,49 @@ * :policy (> speed space)) "expand inline" - `(let ((index 0) - (find nil) + `(let ((find nil) (position nil)) - (declare (type index index)) - (dolist (i sequence - (if (and end (> end index)) - (sequence-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)))))) + (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)) @@ -1269,6 +1461,55 @@ '(%find-position-vector-macro item sequence 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) @@ -1392,3 +1633,74 @@ (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))