X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=a4717f459a1e1d87927b2672a9f54905e6935ddd;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=8d14f18c7bb404af9326987b14b4a5d63eb84ae2;hpb=70b392926636cc0d870a6e4e7dd8b574f998633d;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 8d14f18..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. @@ -1082,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