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

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 4ff8a4d..a4717f4 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,7 +291,7 @@
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 
-(deftype eq-comparable-type ()
+(def!type eq-comparable-type ()
   '(or fixnum (not number)))
 
 ;;; True if EQL comparisons involving type can be simplified to EQ.
@@ -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
 
@@ -1351,6 +1359,30 @@
   '(%find-position-vector-macro item sequence
     from-end start end key test))
 
+(deftransform %find-position ((item sequence from-end start end key test)
+                              (character string t t t function function)
+                              *
+                              :policy (> speed space))
+  (if (eq '* (upgraded-element-type-specifier sequence))
+      (let ((form
+             `(sb!impl::string-dispatch ((simple-array character (*))
+                                         (simple-array base-char (*))
+                                         (simple-array nil (*)))
+                  sequence
+                (%find-position item sequence from-end start end key test))))
+        (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string))
+            form
+            ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from
+            ;; %FIND-POSITION.
+            `(with-array-data ((sequence sequence :offset-var offset)
+                               (start start)
+                               (end end)
+                               :check-fill-pointer t)
+               (multiple-value-bind (elt index) ,form
+                 (values elt (when (fixnump index) (- index offset)))))))
+      ;; The type is known exactly, other transforms will take care of it.
+      (give-up-ir1-transform)))
+
 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
 ;;; POSITION-IF, etc.
 (define-source-transform effective-find-position-test (test test-not)