X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=5e4de7fb7a68d8a3ca325f7a38d883c919c7b1fa;hb=a4ea3949e051d8c9248b231f175d54a20618743e;hp=a4717f459a1e1d87927b2672a9f54905e6935ddd;hpb=e3715b2ee7f3eb579a9452eadc49746e8c52c0b6;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index a4717f4..5e4de7f 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -518,9 +518,9 @@
                     (vector t &key (:start t) (:end t))
                     *
                     :node node)
-  (let* ((element-ctype (extract-upgraded-element-type seq))
+  (let* ((type (lvar-type seq))
+         (element-ctype (array-type-upgraded-element-type type))
          (element-type (type-specifier element-ctype))
-         (type (lvar-type seq))
          (saetp (unless (eq *wild-type* element-ctype)
                   (find-saetp-by-ctype element-ctype))))
     (cond ((eq *wild-type* element-ctype)
@@ -776,7 +776,7 @@
                (end1 (or end1 len1))
                (end2 (or end2 len2))
                (replace-len (min (- end1 start1) (- end2 start2))))
-          ,(unless (policy node (= safety 0))
+          ,(unless (policy node (= insert-array-bounds-checks 0))
              `(progn
                 (unless (<= 0 start1 end1 len1)
                   (sequence-bounding-indices-bad-error seq1 start1 end1))
@@ -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))
@@ -1122,6 +1129,7 @@
           `(apply
             (lambda ,vars
               (declare (ignorable ,@vars))
+              (declare (optimize (insert-array-bounds-checks 0)))
               (let* ((.length. (+ ,@lengths))
                      (.pos. 0)
                      (.string. (make-string .length. :element-type ',element-type)))
@@ -1129,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 (*))
@@ -1195,41 +1209,49 @@
                                    *
                                    :policy (> speed space))
                 "expand inline"
-                `(let ((index 0)
-                       (find nil)
+                `(let ((find nil)
                        (position nil))
-                   (declare (type index index))
-                   (dolist (i sequence
-                            (if (and end (> end index))
-                                (sequence-bounding-indices-bad-error
-                                 sequence start end)
-                                (values find position)))
-                     (when (and end (>= index end))
-                       (return (values find position)))
-                     (when (>= index start)
-                       (let ((key-i (funcall key i)))
-                         (,',condition (funcall predicate key-i)
-                                       ;; This hack of dealing with non-NIL
-                                       ;; FROM-END for list data by iterating
-                                       ;; forward through the list and keeping
-                                       ;; track of the last time we found a
-                                       ;; match might be more screwy than what
-                                       ;; the user expects, but it seems to be
-                                       ;; allowed by the ANSI standard. (And
-                                       ;; if the user is screwy enough to ask
-                                       ;; for FROM-END behavior on list data,
-                                       ;; turnabout is fair play.)
-                                       ;;
-                                       ;; It's also not enormously efficient,
-                                       ;; calling PREDICATE and KEY more often
-                                       ;; than necessary; but all the
-                                       ;; alternatives seem to have their own
-                                       ;; efficiency problems.
-                                       (if from-end
-                                           (setf find i
-                                                 position index)
-                                           (return (values i index))))))
-                     (incf index))))))
+                   (flet ((bounds-error ()
+                            (sequence-bounding-indices-bad-error sequence start end)))
+                     (if (and end (> start end))
+                         (bounds-error)
+                         (do ((slow sequence (cdr slow))
+                              (fast (cdr sequence) (cddr fast))
+                              (index 0 (+ index 1)))
+                             ((cond ((null slow)
+                                     (if (and end (> end index))
+                                         (bounds-error)
+                                         (return (values find position))))
+                                    ((and end (>= index end))
+                                     (return (values find position)))
+                                    ((eq slow fast)
+                                     (circular-list-error sequence)))
+                              (bug "never"))
+                           (declare (list slow fast))
+                           (when (>= index start)
+                             (let* ((element (car slow))
+                                    (key-i (funcall key element)))
+                               (,',condition (funcall predicate key-i)
+                                             ;; This hack of dealing with non-NIL
+                                             ;; FROM-END for list data by iterating
+                                             ;; forward through the list and keeping
+                                             ;; track of the last time we found a
+                                             ;; match might be more screwy than what
+                                             ;; the user expects, but it seems to be
+                                             ;; allowed by the ANSI standard. (And
+                                             ;; if the user is screwy enough to ask
+                                             ;; for FROM-END behavior on list data,
+                                             ;; turnabout is fair play.)
+                                             ;;
+                                             ;; It's also not enormously efficient,
+                                             ;; calling PREDICATE and KEY more often
+                                             ;; than necessary; but all the
+                                             ;; alternatives seem to have their own
+                                             ;; efficiency problems.
+                                             (if from-end
+                                                 (setf find element
+                                                       position index)
+                                                 (return (values element index)))))))))))))
   (def %find-position-if when)
   (def %find-position-if-not unless))