-;;; 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.
-;;;
-;;; FIXME: currently KLUDGEed because of bug 188
-;;;
-;;; FIXME: disabled for sb-unicode: probably want it back
-#!-sb-unicode
-(deftransform concatenate ((rtype &rest sequences)
- (t &rest (or simple-base-string
- (simple-array nil (*))))
- simple-base-string
- :policy (< safety 3))
- (loop for rest-seqs on sequences
- for n-seq = (gensym "N-SEQ")
- for n-length = (gensym "N-LENGTH")
- for start = 0 then next-start
- for next-start = (gensym "NEXT-START")
- collect n-seq into args
- collect `(,n-length (length ,n-seq)) into lets
- collect n-length into all-lengths
- collect next-start into starts
- collect `(if (and (typep ,n-seq '(simple-array nil (*)))
- (> ,n-length 0))
- (error 'nil-array-accessed-error)
- (#.(let* ((i (position 'character sb!kernel::*specialized-array-element-types*))
- (saetp (aref sb!vm:*specialized-array-element-type-properties* i))
- (n-bits (sb!vm:saetp-n-bits saetp)))
- (intern (format nil "UB~D-BASH-COPY" n-bits)
- "SB!KERNEL"))
- ,n-seq 0 res ,start ,n-length))
- into forms
- collect `(setq ,next-start (+ ,start ,n-length)) into forms
- finally
- (return
- `(lambda (rtype ,@args)
- (declare (ignore rtype))
- (let* (,@lets
- (res (make-string (the index (+ ,@all-lengths))
- :element-type 'base-char)))
- (declare (type index ,@all-lengths))
- (let (,@(mapcar (lambda (name) `(,name 0)) starts))
- (declare (type index ,@starts))
- ,@forms)
- res)))))
+
+;;; 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
+(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)))