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. <constant>))) <char>)
    ...repeat...
    (INCF .POS. <constant>)

  instead of

    (SETF (AREF .STRING .POS.) <char>)
    (INCF .POS.)
    ...repeat...

  . Smaller code, easier on the constraint propagation, and a tiny
  bit faster too.

diff --git a/NEWS b/NEWS
index 6e6948f..4b162ec 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"