X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=a4717f459a1e1d87927b2672a9f54905e6935ddd;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=3c25cc46ea8ef0a4eca77d954adf01c5c991c206;hpb=cfc3b695e6452907fef6492710777511ac4af979;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3c25cc4..a4717f4 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)) @@ -535,8 +537,14 @@ (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) - (t :bits))) + #!+#.(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. @@ -556,37 +564,51 @@ 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)))))) + (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)) - `(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)) - (:double-float - `(logior (ash (double-float-high-bits item) 32) - (double-float-low-bits 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)))) + (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) @@ -1060,62 +1082,70 @@ ;;; 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. (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)) + (let* ((.length. (+ ,@lengths)) + (.pos. 0) + (.string. (make-string .length. :element-type ',element-type))) + (declare (type index .length. .pos.) + (muffle-conditions compiler-note)) + ,@(loop for value in lvar-values + for var in vars + collect (if (stringp value) + ;; Fold the array reads for constant arguments + `(progn + ,@(loop for c across value + collect `(setf (aref .string. + .pos.) ,c) + collect `(incf .pos.))) + `(sb!impl::string-dispatch + (#!+sb-unicode + (simple-array character (*)) + (simple-array base-char (*)) + t) + ,var + (replace .string. ,var :start1 .pos.) + (incf .pos. (length ,var))))) + .string.)) + lvars))))) ;;;; CONS accessor DERIVE-TYPE optimizers @@ -1329,6 +1359,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)