From 3bb8f5292debbe26d0e62685e6d5af81d6e4fb98 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 14 Sep 2009 09:32:52 +0000 Subject: [PATCH] 1.0.31.8: specialized out-of-line CONCATENATE for strings https://bugs.launchpad.net/sbcl/+bug/417229 CONCATENATE 'STRING was already decent when SPEED > SPACE thanks to open coding by the deftransform. Deal with low-speed policies by adding %CONCATENATE-TO-STRING and %CONCATENATE-TO-BASE-STRING and transforming to them when appropriate. --- NEWS | 2 + package-data-list.lisp-expr | 2 + src/code/seq.lisp | 23 +++++++++ src/compiler/seqtran.lisp | 118 +++++++++++++++++++++++-------------------- tests/compiler.pure.lisp | 16 ++++++ version.lisp-expr | 2 +- 6 files changed, 107 insertions(+), 56 deletions(-) diff --git a/NEWS b/NEWS index aa19086..9afc309 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes relative to sbcl-1.0.31 * optimization: faster FIND and POSITION on strings of unknown element type in high SPEED policies. (thanks to Karol Swietlicki) + * optimization: faster CONCATENATE 'STRING in low SPEED policies (reported + by David Vázquez) * improvement: better error signalling for bogus parameter specializer names in DEFMETHOD forms (reported by Pluijzer) * bug fix: SAVE-LISP-AND-DIE option :SAVE-RUNTIME-OPTIONS did not work diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 76c9ad8..4a457f5 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1229,6 +1229,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%COMPARE-AND-SWAP-SVREF" "%COMPARE-AND-SWAP-SYMBOL-PLIST" "%COMPARE-AND-SWAP-SYMBOL-VALUE" + "%CONCATENATE-TO-BASE-STRING" + "%CONCATENATE-TO-STRING" "%COS" "%COS-QUICK" "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1" "%FIND-POSITION" diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 7cc9692..f63ce3b 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -866,6 +866,29 @@ (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 diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 8d14f18..9440650 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -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 diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 34ae4a8..ecea1bd 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3331,3 +3331,19 @@ (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"))) diff --git a/version.lisp-expr b/version.lisp-expr index 1444b9f..769b0f6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.31.7" +"1.0.31.8" -- 1.7.10.4