From a4ea3949e051d8c9248b231f175d54a20618743e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 7 Nov 2010 01:14:39 +0000 Subject: [PATCH] 1.0.44.1: more conservative CONCATENATE open-coding Don't fully open code for long strings, no matter what policy: constraint-propagation will go seriously nonlinear. Also optimize the open-coded form a bit. Use (SETF (AREF .STRING. (TRULY-THE INDEX (+ .POS. ))) ) ...repeat... (INCF .POS. ) instead of (SETF (AREF .STRING .POS.) ) (INCF .POS.) ...repeat... . Smaller code, easier on the constraint propagation, and a tiny bit faster too. --- NEWS | 4 ++++ src/compiler/seqtran.lisp | 21 +++++++++++++++++---- tests/compiler.pure.lisp | 26 ++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 48 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 6e6948f..4b162ec 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.0.44: + * bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant + long string arguments slowed the compiler down to a crawl. + changes in sbcl-1.0.44 relative to sbcl-1.0.43: * enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the external-format for its :INPUT, :OUTPUT, AND :ERROR :STREAMs. diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3c7fa16..5e4de7f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1086,6 +1086,13 @@ ;;; 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. +;;; +;;; Limit full open coding based on length of constant sequences. Default +;;; value is chosen so that other parts of to compiler (constraint propagation +;;; mainly) won't go nonlinear too badly. It's not an exact number -- but +;;; in the right ballpark. +(defvar *concatenate-open-code-limit* 129) + (deftransform concatenate ((result-type &rest lvars) ((constant-arg (member string simple-string base-string simple-base-string)) @@ -1130,13 +1137,19 @@ (muffle-conditions compiler-note)) ,@(loop for value in lvar-values for var in vars - collect (if (stringp value) + collect (if (and (stringp value) + (< (length value) *concatenate-open-code-limit*)) ;; Fold the array reads for constant arguments `(progn ,@(loop for c across value - collect `(setf (aref .string. - .pos.) ,c) - collect `(incf .pos.))) + for i from 0 + collect + ;; Without truly-the we get massive numbers + ;; of pointless error traps. + `(setf (aref .string. + (truly-the index (+ .pos. ,i))) + ,c)) + (incf .pos. ,(length value))) `(sb!impl::string-dispatch (#!+sb-unicode (simple-array character (*)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 90b460e..fbadfe9 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3655,3 +3655,29 @@ (assert (equal (with-output-to-string (*standard-output*) (funcall fun t)) "(1 2)T")))) + +(with-test (:name :constant-concatenate-compile-time) + (flet ((make-lambda (n) + `(lambda (x) + (declare (optimize (speed 3) (space 0))) + (concatenate 'string x ,(make-string n))))) + (let* ((l0 (make-lambda 1)) + (l1 (make-lambda 10)) + (l2 (make-lambda 100)) + (l3 (make-lambda 1000)) + (t0 (get-internal-run-time)) + (f0 (compile nil l0)) + (t1 (get-internal-run-time)) + (f1 (compile nil l1)) + (t2 (get-internal-run-time)) + (f2 (compile nil l2)) + (t3 (get-internal-run-time)) + (f3 (compile nil l3)) + (t4 (get-internal-run-time)) + (d0 (- t1 t0)) + (d1 (- t2 t1)) + (d2 (- t3 t2)) + (d3 (- t4 t3)) + (short-avg (/ (+ d0 d1 d2) 3))) + (assert (and f1 f2 f3)) + (assert (< d3 (* 10 short-avg)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 6c8c8c6..3707069 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.44" +"1.0.44.1" -- 1.7.10.4