(t
(bad-sequence-type-error output-type-spec)))))
+;;; Efficient out-of-line concatenate for strings. Compiler transforms
+;;; CONCATENATE 'STRING &co into these.
+(macrolet ((def (name element-type)
+ `(defun ,name (&rest sequences)
+ (declare (dynamic-extent sequences)
+ (optimize speed))
+ (let* ((lengths (mapcar #'length sequences))
+ (result (make-array (the integer (apply #'+ lengths))
+ :element-type ',element-type))
+ (start 0))
+ (declare (index start))
+ (dolist (seq sequences)
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*))
+ t)
+ seq
+ (replace result seq :start1 start))
+ (incf start (the index (pop lengths))))
+ result))))
+ (def %concatenate-to-string character)
+ (def %concatenate-to-base-string base-char))
+
;;; internal frobs
;;; FIXME: These are weird. They're never called anywhere except in
;;; CONCATENATE. It seems to me that the macros ought to just
;;; 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)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
(declare (optimize speed safety))
(setf (slot-value x 'bar) y))))
(assert (= 1 notes))))
+
+(with-test (:name :concatenate-string-opt)
+ (flet ((test (type grep)
+ (let* ((fun (compile nil `(lambda (a b c d e)
+ (concatenate ',type a b c d e))))
+ (args '("foo" #(#\.) "bar" (#\-) "quux"))
+ (res (apply fun args)))
+ (assert (search grep (with-output-to-string (out)
+ (disassemble fun :stream out))))
+ (assert (equal (apply #'concatenate type args)
+ res))
+ (assert (typep res type)))))
+ (test 'string "%CONCATENATE-TO-STRING")
+ (test 'simple-string "%CONCATENATE-TO-STRING")
+ (test 'base-string "%CONCATENATE-TO-BASE-STRING")
+ (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
projects / sbcl.git / commitdiff