X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=67ecb5a44e898458fc366dbc02eca9a978c87705;hb=4d0b87793a047baecf2403455ddca1a82f44a41b;hp=466496dbff1a1cceadf01a2f05c68fb7b67bc29b;hpb=1ab1dd29f2602c87d404492e588abdf5f6abfbf2;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 466496d..67ecb5a 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -316,6 +316,8 @@
       (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
            function-name key-functions variant)))
 
+(defparameter *list-open-code-limit* 128)
+
 (defun transform-list-item-seek (name item list key test test-not node)
   (when (and test test-not)
     (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name))
@@ -376,7 +378,8 @@
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
           (cond ((and cp c-list (member name '(assoc rassoc member))
-                      (policy node (>= speed space)))
+                      (policy node (>= speed space))
+                      (not (nthcdr *list-open-code-limit* c-list)))
                  `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))
                 ((and cp (not c-list))
@@ -431,7 +434,8 @@
                         ,(open-code (cdr tail))))))
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
-          (cond ((and cp c-list (policy node (>= speed space)))
+          (cond ((and cp c-list (policy node (>= speed space))
+                      (not (nthcdr *list-open-code-limit* c-list)))
                  `(let ((pred ,pred-expr)
                         ,@(when key `((key ,key-form))))
                     ,(open-code c-list)))
@@ -482,21 +486,11 @@
 ;;; almost as fast as MEMQ.
 (deftransform delete ((item list &key test) (t list &rest t) *)
   "convert to EQ test"
-  ;; FIXME: The scope of this transformation could be
-  ;; widened somewhat, letting it work whenever the test is
-  ;; 'EQL and we know from the type of ITEM that it #'EQ
-  ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
-  ;; and SYMBOL.)
-  ;;   If TEST is EQ, apply transform, else
-  ;;   if test is not EQL, then give up on transform, else
-  ;;   if ITEM is not a NUMBER or is a FIXNUM, apply
-  ;;   transform, else give up on transform.
-  (cond (test
-         (unless (lvar-fun-is test '(eq))
-           (give-up-ir1-transform)))
-        ((types-equal-or-intersect (lvar-type item)
-                                   (specifier-type 'number))
-         (give-up-ir1-transform "Item might be a number.")))
+  (let ((type (lvar-type item)))
+    (unless (or (and test (lvar-fun-is test '(eq)))
+                (and (eq-comparable-type-p type)
+                     (or (not test) (lvar-fun-is test '(eql)))))
+      (give-up-ir1-transform)))
   `(delq item list))
 
 (deftransform delete-if ((pred list) (t list))
@@ -776,7 +770,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 +1080,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 +1123,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 +1131,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 (*))
@@ -1237,9 +1245,7 @@
                                              (if from-end
                                                  (setf find element
                                                        position index)
-                                                 (unless find
-                                                   (setf find element
-                                                         position index)))))))))))))
+                                                 (return (values element index)))))))))))))
   (def %find-position-if when)
   (def %find-position-if-not unless))