X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=5e4de7fb7a68d8a3ca325f7a38d883c919c7b1fa;hb=a4ea3949e051d8c9248b231f175d54a20618743e;hp=325597379c31c48cd6f943955498efdff9b1741f;hpb=da5a7ccd58c2bf3c5287a11fb41e01403e5745e8;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3255973..5e4de7f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -291,7 +291,7 @@ (or end length) (sequence-bounding-indices-bad-error vector start end))))) -(deftype eq-comparable-type () +(def!type eq-comparable-type () '(or fixnum (not number))) ;;; True if EQL comparisons involving type can be simplified to EQ. @@ -317,6 +317,8 @@ function-name key-functions variant))) (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)) @@ -516,9 +518,110 @@ (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 + `(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)) + (muffle-conditions compiler-note)) + (,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) @@ -625,20 +728,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: ;;; @@ -687,14 +776,14 @@ (end1 (or end1 len1)) (end2 (or end2 len2)) (replace-len (min (- end1 start1) (- end2 start2)))) - ,(unless (policy node (= safety 0)) + ,(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 (valid-bit-bash-saetp-p saetp)) + ((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) @@ -993,67 +1082,91 @@ ;;; 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 to 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)))))) + `(apply + (lambda ,vars + (declare (ignorable ,@vars)) + (declare (optimize (insert-array-bounds-checks 0))) + (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 (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 (+ .pos. ,i))) + ,c)) + (incf .pos. ,(length value))) + `(sb!impl::string-dispatch + (#!+sb-unicode + (simple-array character (*)) + (simple-array base-char (*)) + t) + ,var + (replace .string. ,var :start1 .pos.) + (incf .pos. (length ,var))))) + .string.)) + lvars))))) ;;;; CONS accessor DERIVE-TYPE optimizers (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) @@ -1061,7 +1174,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) @@ -1096,41 +1209,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))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (let ((key-i (funcall key i))) - (,',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)) @@ -1260,6 +1381,30 @@ '(%find-position-vector-macro item sequence from-end start end key test)) +(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)