X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=28da4444f2e8ae243a78b073f999e5895baa30e1;hb=f24a665895283c52443ed45bb3e07530f760bbfa;hp=9cd3e8a910e9ea3879d941c4f9b5b5c959e24ecd;hpb=b86daba1860b622636d9e8f655a3f96de4d86801;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 9cd3e8a..28da444 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)))))
 
-(defun specialized-list-seek-function-name (function-name key-functions)
+(defun specialized-list-seek-function-name (function-name key-functions variant)
   (or (find-symbol (with-output-to-string (s)
                      ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
                      ;; this ever so slightly faster then FORMAT, this
@@ -301,32 +301,48 @@
                      (write-string (symbol-name function-name) s)
                      (dolist (f key-functions)
                        (write-char #\- s)
-                       (write-string (symbol-name f) s)))
+                       (write-string (symbol-name f) s))
+                     (when variant
+                       (write-char #\- s)
+                       (write-string (symbol-name variant) s)))
                    (load-time-value (find-package "SB!KERNEL")))
-      (bug "Unknown list item seek transform: name=~S, key-functions=~S"
-           function-name key-functions)))
-
-(defun transform-list-item-seek (name list key test test-not node)
+      (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
+           function-name key-functions variant)))
+
+(defun transform-list-item-seek (name item list key test test-not node)
+  ;; If TEST is EQL, drop it.
+  (when (and test (lvar-for-named-function test 'eql))
+    (setf test nil))
+  ;; Ditto for KEY IDENTITY.
+  (when (and key (lvar-for-named-function key 'identity))
+    (setf key nil))
   ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
   ;; not there at all. If it might be NIL, make up a form to that
-  ;; ensure it is a function.
+  ;; ensures it is a function.
   (multiple-value-bind (key key-form)
-      (if key
-          (let ((key-type (lvar-type key))
-                (null-type (specifier-type 'null)))
-            (cond ((csubtypep key-type null-type)
-                   (values nil nil))
-                  ((csubtypep null-type key-type)
-                   (values key '(if key
-                                 (%coerce-callable-to-fun key)
-                                 #'identity)))
-                  (t
-                   (values key '(%coerce-callable-to-fun key))))))
-    (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
+      (when key
+        (let ((key-type (lvar-type key))
+              (null-type (specifier-type 'null)))
+          (cond ((csubtypep key-type null-type)
+                 (values nil nil))
+                ((csubtypep null-type key-type)
+                 (values key '(if key
+                               (%coerce-callable-to-fun key)
+                               #'identity)))
+                (t
+                 (values key '(%coerce-callable-to-fun key))))))
+    (let* ((c-test (cond ((and test (lvar-for-named-function test 'eq))
+                          (setf test nil)
+                          'eq)
+                         ((and (not test) (not test-not))
+                          (when (eq-comparable-type-p (lvar-type item))
+                            'eq))))
+           (funs (remove nil (list (and key 'key) (cond (test 'test)
                                                         (test-not 'test-not)))))
            (target-expr (if key '(%funcall key target) 'target))
            (test-expr (cond (test `(%funcall test item ,target-expr))
                             (test-not `(not (%funcall test-not item ,target-expr)))
+                            (c-test `(,c-test item ,target-expr))
                             (t `(eql item ,target-expr)))))
       (labels ((open-code (tail)
                  (when tail
@@ -348,7 +364,8 @@
                      `(%coerce-callable-to-fun ,fun))))
         (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 (member name '(assoc member))
+                      (policy node (>= speed space)))
                  `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))
                 ((and cp (not c-list))
@@ -356,14 +373,17 @@
                  nil)
                 (t
                  ;; specialized out-of-line version
-                 `(,(specialized-list-seek-function-name name funs)
+                 `(,(specialized-list-seek-function-name name funs c-test)
                     item list ,@(mapcar #'ensure-fun funs)))))))))
 
 (deftransform member ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'member list key test test-not node))
+  (transform-list-item-seek 'member item list key test test-not node))
 
 (deftransform assoc ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'assoc list key test test-not node))
+  (transform-list-item-seek 'assoc item list key test test-not node))
+
+(deftransform adjoin ((item list &key key test test-not) * * :node node)
+  (transform-list-item-seek 'adjoin item list key test test-not node))
 
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)
@@ -408,29 +428,44 @@
                 (rplacd splice (cdr x))))
            (t (setq splice x)))))
 
-(deftransform fill ((seq item &key (start 0) (end (length seq)))
-                    (vector t &key (:start t) (:end index))
+(deftransform fill ((seq item &key (start 0) (end nil))
+                    (list t &key (:start t) (:end t)))
+  '(list-fill* seq item start end))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+                    (vector t &key (:start t) (:end t))
                     *
-                    :policy (> speed space))
-  "open code"
-  (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
-    (values
-     `(with-array-data ((data seq)
-                        (start start)
-                        (end end)
-                        :check-fill-pointer t)
-       (declare (type (simple-array ,element-type 1) data))
-       (declare (type fixnum start end))
-       (do ((i start (1+ i)))
-           ((= i end) seq)
-         (declare (type index i))
-         ;; WITH-ARRAY-DATA did our range checks once and for all, so
-         ;; it'd be wasteful to check again on every AREF...
-         (declare (optimize (safety 0)))
-         (setf (aref data i) item)))
-     ;; ... though we still need to check that the new element can fit
-     ;; into the vector in safe code. -- CSR, 2002-07-05
-     `((declare (type ,element-type item))))))
+                    :node node)
+  (let ((type (lvar-type seq))
+        (element-type (type-specifier (extract-upgraded-element-type seq))))
+    (cond ((and (neq '* element-type) (policy node (> speed space)))
+           (values
+            `(with-array-data ((data seq)
+                               (start start)
+                               (end end)
+                               :check-fill-pointer t)
+               (declare (type (simple-array ,element-type 1) data))
+               (declare (type index start end))
+               ;; WITH-ARRAY-DATA did our range checks once and for all, so
+               ;; it'd be wasteful to check again on every AREF...
+               (declare (optimize (safety 0) (speed 3)))
+               (do ((i start (1+ i)))
+                   ((= i end) seq)
+                 (declare (type index i))
+                 (setf (aref data i) item)))
+            ;; ... though we still need to check that the new element can fit
+            ;; into the vector in safe code. -- CSR, 2002-07-05
+            `((declare (type ,element-type item)))))
+          ((csubtypep type (specifier-type 'string))
+           '(string-fill* seq item start end))
+          (t
+           '(vector-fill* seq item start end)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+                    ((and sequence (not vector) (not list)) t &key (:start t) (:end t)))
+  `(sb!sequence:fill seq item
+                     :start start
+                     :end (%check-generic-sequence-bounds seq start end)))
 
 ;;;; utilities
 
@@ -653,8 +688,10 @@
      (define-one-transform (sequence-type1 sequence-type2)
        (make-replace-transform nil sequence-type1 sequence-type2)))
   (define-replace-transforms)
-  (define-one-transform simple-base-string (simple-array character (*)))
-  (define-one-transform (simple-array character (*)) simple-base-string))
+  #!+sb-unicode
+  (progn
+   (define-one-transform (simple-array base-char (*)) (simple-array character (*)))
+   (define-one-transform (simple-array character (*)) (simple-array base-char (*)))))
 
 ;;; Expand simple cases of UB<SIZE>-BASH-COPY inline.  "simple" is
 ;;; defined as those cases where we are doing word-aligned copies from
@@ -719,7 +756,8 @@
            (do ((i end (1- i)))
                ((<= i ,src-word))
              (setf (sb!kernel:%vector-raw-bits dst (1- i))
-                   (sb!kernel:%vector-raw-bits src (1- i)))))))))
+                   (sb!kernel:%vector-raw-bits src (1- i))))
+           (values))))))
 
 #.(loop for i = 1 then (* i 2)
         collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i)
@@ -781,40 +819,62 @@
                   (type (integer 0 #.sb!xc:array-dimension-limit) j i))
          (setf (aref ,dst (1- j)) (aref ,src (1- i))))))
 
+;;; SUBSEQ, COPY-SEQ
+
 (deftransform subseq ((seq start &optional end)
-                      ((or (simple-unboxed-array (*)) simple-vector) t &optional t)
-                      * :node node)
-  (let ((array-type (lvar-type seq)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
-      `(let* ((length (length seq))
-              (end (or end length)))
-         ,(unless (policy node (= safety 0))
-                  '(progn
-                    (unless (<= 0 start end length)
-                      (sequence-bounding-indices-bad-error seq start end))))
-         (let* ((size (- end start))
-                (result (make-array size :element-type ',element-type)))
-           ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
-                                                    (lvar-value start)
-                                                    'start)
-                                           'result 0 'size element-type)
-           result)))))
+                      (vector t &optional t)
+                      *
+                      :node node)
+  (let ((type (lvar-type seq)))
+    (cond
+      ((and (array-type-p type)
+            (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+       (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+         `(let* ((length (length seq))
+                 (end (or end length)))
+            ,(unless (policy node (zerop insert-array-bounds-checks))
+                     '(progn
+                       (unless (<= 0 start end length)
+                         (sequence-bounding-indices-bad-error seq start end))))
+            (let* ((size (- end start))
+                   (result (make-array size :element-type ',element-type)))
+              ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
+                                                       (lvar-value start)
+                                                       'start)
+                                              'result 0 'size element-type)
+              result))))
+      ((csubtypep type (specifier-type 'string))
+       '(string-subseq* seq start end))
+      (t
+       '(vector-subseq* seq start end)))))
 
 (deftransform subseq ((seq start &optional end)
                       (list t &optional t))
   `(list-subseq* seq start end))
 
-(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
-  (let ((array-type (lvar-type seq)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
-      `(let* ((length (length seq))
-              (result (make-array length :element-type ',element-type)))
-         ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
-         result))))
+(deftransform subseq ((seq start &optional end)
+                      ((and sequence (not vector) (not list)) t &optional t))
+  '(sb!sequence:subseq seq start end))
+
+(deftransform copy-seq ((seq) (vector))
+  (let ((type (lvar-type seq)))
+    (cond ((and (array-type-p type)
+                (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+           (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+             `(let* ((length (length seq))
+                     (result (make-array length :element-type ',element-type)))
+                ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
+                result)))
+          ((csubtypep type (specifier-type 'string))
+           '(string-subseq* seq 0 nil))
+          (t
+           '(vector-subseq* seq 0 nil)))))
+
+(deftransform copy-seq ((seq) (list))
+  '(list-copy-seq* seq))
+
+(deftransform copy-seq ((seq) ((and sequence (not vector) (not list))))
+  '(sb!sequence:copy-seq seq))
 
 ;;; FIXME: it really should be possible to take advantage of the
 ;;; macros used in code/seq.lisp here to avoid duplication of code,
@@ -1238,3 +1298,43 @@
                     (effective-find-position-key key))))))
   (define-find-position-if-not find-if-not 0)
   (define-find-position-if-not position-if-not 1))
+
+(macrolet ((define-trimmer-transform (fun-name leftp rightp)
+             `(deftransform ,fun-name ((char-bag string)
+                                       (t simple-string))
+                (let ((find-expr
+                       (if (constant-lvar-p char-bag)
+                           ;; If the bag is constant, use MEMBER
+                           ;; instead of FIND, since we have a
+                           ;; deftransform for MEMBER that can
+                           ;; open-code all of the comparisons when
+                           ;; the list is constant. -- JES, 2007-12-10
+                           `(not (member (schar string index)
+                                         ',(coerce (lvar-value char-bag) 'list)
+                                         :test #'char=))
+                           '(not (find (schar string index) char-bag :test #'char=)))))
+                  `(flet ((char-not-in-bag (index)
+                            ,find-expr))
+                     (let* ((end (length string))
+                            (left-end (if ,',leftp
+                                          (do ((index 0 (1+ index)))
+                                              ((or (= index (the fixnum end))
+                                                   (char-not-in-bag index))
+                                               index)
+                                            (declare (fixnum index)))
+                                          0))
+                            (right-end (if ,',rightp
+                                           (do ((index (1- end) (1- index)))
+                                               ((or (< index left-end)
+                                                    (char-not-in-bag index))
+                                                (1+ index))
+                                             (declare (fixnum index)))
+                                           end)))
+                       (if (and (eql left-end 0)
+                                (eql right-end (length string)))
+                           string
+                           (subseq string left-end right-end))))))))
+  (define-trimmer-transform string-left-trim t nil)
+  (define-trimmer-transform string-right-trim nil t)
+  (define-trimmer-transform string-trim t t))
+