X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=325597379c31c48cd6f943955498efdff9b1741f;hb=da5a7ccd58c2bf3c5287a11fb41e01403e5745e8;hp=cf09aa01ef42d0f3e965bbc7e26e3c6433d9c192;hpb=19efdada13c0ca54d5b0249aeeece458f888896e;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index cf09aa0..3255973 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,7 +291,14 @@
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 
-(defun specialized-list-seek-function-name (function-name key-functions)
+(deftype eq-comparable-type ()
+  '(or fixnum (not number)))
+
+;;; True if EQL comparisons involving type can be simplified to EQ.
+(defun eq-comparable-type-p (type)
+  (csubtypep type (specifier-type 'eq-comparable-type)))
+
+(defun specialized-list-seek-function-name (function-name key-functions &optional 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,69 +308,162 @@
                      (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-fun-is test '(eql)))
+    (setf test nil))
+  ;; Ditto for KEY IDENTITY.
+  (when (and key (lvar-fun-is 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)
-                                                        (test-not 'test-not)))))
+      (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 (ensure-lvar-fun-form key 'key))))))
+    (let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))
+                          (setf test nil)
+                          'eq)
+                         ((and (not test) (not test-not))
+                          (when (eq-comparable-type-p (lvar-type item))
+                            'eq))))
+           (funs (delete nil (list (when key (list key 'key))
+                                   (when test (list test 'test))
+                                   (when test-not (list 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
                    `(if (let ((this ',(car tail)))
                           ,(ecase name
-                                  (assoc
-                                   `(and this (let ((target (car this)))
-                                                ,test-expr)))
+                                  ((assoc rassoc)
+                                   (let ((cxx (if (eq name 'assoc) 'car 'cdr)))
+                                     `(and this (let ((target (,cxx this)))
+                                                  ,test-expr))))
                                   (member
                                    `(let ((target this))
                                       ,test-expr))))
                         ',(ecase name
-                                 (assoc (car tail))
+                                 ((assoc rassoc) (car tail))
                                  (member tail))
                         ,(open-code (cdr tail)))))
-               (ensure-fun (fun)
-                 (if (eq 'key fun)
+               (ensure-fun (args)
+                 (if (eq 'key (second args))
                      key-form
-                     `(%coerce-callable-to-fun ,fun))))
+                     (apply #'ensure-lvar-fun-form args))))
+        (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)))
+                 `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
+                    ,(open-code c-list)))
+                ((and cp (not c-list))
+                 ;; constant nil list
+                 (if (eq name 'adjoin)
+                     '(list item)
+                     nil))
+                (t
+                 ;; specialized out-of-line version
+                 `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test)
+                    item list ,@(mapcar #'ensure-fun funs)))))))))
+
+(defun transform-list-pred-seek (name pred list key node)
+  ;; If KEY is IDENTITY, drop it.
+  (when (and key (lvar-fun-is 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
+  ;; ensures it is a function.
+  (multiple-value-bind (key key-form)
+      (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 (ensure-lvar-fun-form key 'key))))))
+    (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
+          (pred-expr (ensure-lvar-fun-form pred 'pred)))
+      (when (member name '(member-if-not assoc-if-not rassoc-if-not))
+        (setf test-expr `(not ,test-expr)))
+      (labels ((open-code (tail)
+                 (when tail
+                   `(if (let ((this ',(car tail)))
+                          ,(ecase name
+                                  ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+                                   (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr)))
+                                     `(and this (let ((target (,cxx this)))
+                                                  ,test-expr))))
+                                  ((member-if member-if-not)
+                                   `(let ((target this))
+                                      ,test-expr))))
+                        ',(ecase name
+                                 ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+                                  (car tail))
+                                 ((member-if member-if-not)
+                                  tail))
+                        ,(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)))
-                 `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+                 `(let ((pred ,pred-expr)
+                        ,@(when key `((key ,key-form))))
                     ,(open-code c-list)))
                 ((and cp (not c-list))
                  ;; constant nil list -- nothing to find!
                  nil)
                 (t
                  ;; specialized out-of-line version
-                 `(,(specialized-list-seek-function-name name funs)
-                    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))
-
-(deftransform assoc ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'assoc list key test test-not node))
+                 `(,(specialized-list-seek-function-name name (when key '(key)))
+                    ,pred-expr list ,@(when key (list key-form))))))))))
+
+(macrolet ((def (name &optional if/if-not)
+             (let ((basic (symbolicate "%" name))
+                   (basic-eq (symbolicate "%" name "-EQ"))
+                   (basic-key (symbolicate "%" name "-KEY"))
+                   (basic-key-eq (symbolicate "%" name "-KEY-EQ")))
+               `(progn
+                  (deftransform ,name ((item list &key key test test-not) * * :node node)
+                    (transform-list-item-seek ',name item list key test test-not node))
+                  (deftransform ,basic ((item list) (eq-comparable-type t))
+                    `(,',basic-eq item list))
+                  (deftransform ,basic-key ((item list) (eq-comparable-type t))
+                    `(,',basic-key-eq item list))
+                  ,@(when if/if-not
+                          (let ((if-name (symbolicate name "-IF"))
+                                (if-not-name (symbolicate name "-IF-NOT")))
+                            `((deftransform ,if-name ((pred list &key key) * * :node node)
+                                (transform-list-pred-seek ',if-name pred list key node))
+                              (deftransform ,if-not-name ((pred list &key key) * * :node node)
+                                (transform-list-pred-seek ',if-not-name pred list key node)))))))))
+  (def adjoin)
+  (def assoc  t)
+  (def member t)
+  (def rassoc t))
 
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)
@@ -408,58 +508,45 @@
                 (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))
-                    *
-                    :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))))))
-
-;;;; utilities
-
-;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
-(defun lvar-fun-is (lvar names)
-  (declare (type lvar lvar) (list names))
-  (let ((use (lvar-uses lvar)))
-    (and (ref-p use)
-         (let ((leaf (ref-leaf use)))
-           (and (global-var-p leaf)
-                (eq (global-var-kind leaf) :global-function)
-                (not (null (member (leaf-source-name leaf) names
-                                   :test #'equal))))))))
-
-;;; If LVAR is a constant lvar, the return the constant value. If it
-;;; is null, then return default, otherwise quietly give up the IR1
-;;; transform.
-;;;
-;;; ### Probably should take an ARG and flame using the NAME.
-(defun constant-value-or-lose (lvar &optional default)
-  (declare (type (or lvar null) lvar))
-  (cond ((not lvar) default)
-        ((constant-lvar-p lvar)
-         (lvar-value lvar))
-        (t
-         (give-up-ir1-transform))))
+(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))
+                    *
+                    :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)))
+
 ;;;; hairy sequence transforms
 
 ;;; FIXME: no hairy sequence transforms in SBCL?
@@ -589,57 +676,50 @@
 ;;; you tweak it, make sure that you compare the disassembly, if not the
 ;;; performance of, the functions implementing string streams
 ;;; (e.g. SB!IMPL::STRING-OUCH).
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun make-replace-transform (saetp sequence-type1 sequence-type2)
     `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
                             (,sequence-type1 ,sequence-type2 &rest t)
                             ,sequence-type1
                             :node node)
-       ,(cond
-         ((and saetp (valid-bit-bash-saetp-p saetp)) nil)
-         ;; If the sequence types are different, SEQ1 and SEQ2 must
-         ;; be distinct arrays, and we can open code the copy loop.
-         ((not (eql sequence-type1 sequence-type2)) nil)
-         ;; If we're not bit-bashing, only allow cases where we
-         ;; can determine the order of copying up front.  (There
-         ;; are actually more cases we can handle if we know the
-         ;; amount that we're copying, but this handles the
-         ;; common cases.)
-         (t '(unless (= (constant-value-or-lose start1 0)
-                      (constant-value-or-lose start2 0))
-              (give-up-ir1-transform))))
        `(let* ((len1 (length seq1))
                (len2 (length seq2))
                (end1 (or end1 len1))
                (end2 (or end2 len2))
-               (replace-len1 (- end1 start1))
-               (replace-len2 (- end2 start2)))
+               (replace-len (min (- end1 start1) (- end2 start2))))
           ,(unless (policy node (= safety 0))
              `(progn
-                 (unless (<= 0 start1 end1 len1)
-                   (sequence-bounding-indices-bad-error seq1 start1 end1))
-                 (unless (<= 0 start2 end2 len2)
-                   (sequence-bounding-indices-bad-error seq2 start2 end2))))
+                (unless (<= 0 start1 end1 len1)
+                  (sequence-bounding-indices-bad-error seq1 start1 end1))
+                (unless (<= 0 start2 end2 len2)
+                  (sequence-bounding-indices-bad-error seq2 start2 end2))))
           ,',(cond
-              ((and saetp (valid-bit-bash-saetp-p saetp))
-               (let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
-                      (bash-function (intern (format nil "UB~D-BASH-COPY"
-                                                     n-element-bits)
-                                             (find-package "SB!KERNEL"))))
-                 `(funcall (function ,bash-function) seq2 start2
-                           seq1 start1 (min replace-len1 replace-len2))))
-              (t
-               ;; We can expand the loop inline here because we
-               ;; would have given up the transform (see above)
-               ;; if we didn't have constant matching start
-               ;; indices.
-               '(do ((i start1 (1+ i))
-                     (j start2 (1+ j))
-                     (end (+ start1
-                             (min replace-len1 replace-len2))))
-                 ((>= i end))
-                 (declare (optimize (insert-array-bounds-checks 0)))
-                 (setf (aref seq1 i) (aref seq2 j)))))
+               ((and saetp (valid-bit-bash-saetp-p saetp))
+                (let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
+                       (bash-function (intern (format nil "UB~D-BASH-COPY"
+                                                      n-element-bits)
+                                              (find-package "SB!KERNEL"))))
+                  `(funcall (function ,bash-function) seq2 start2
+                    seq1 start1 replace-len)))
+               (t
+                `(if (and
+                      ;; If the sequence types are different, SEQ1 and
+                      ;; SEQ2 must be distinct arrays.
+                      ,(eql sequence-type1 sequence-type2)
+                      (eq seq1 seq2) (> start1 start2))
+                     (do ((i (truly-the index (+ start1 replace-len -1))
+                             (1- i))
+                          (j (truly-the index (+ start2 replace-len -1))
+                             (1- j)))
+                         ((< i start1))
+                       (declare (optimize (insert-array-bounds-checks 0)))
+                       (setf (aref seq1 i) (aref seq2 j)))
+                     (do ((i start1 (1+ i))
+                          (j start2 (1+ j))
+                          (end (+ start1 replace-len)))
+                         ((>= i end))
+                       (declare (optimize (insert-array-bounds-checks 0)))
+                       (setf (aref seq1 i) (aref seq2 j))))))
           seq1))))
 
 (macrolet
@@ -653,8 +733,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 +801,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)
@@ -1022,31 +1105,31 @@
                                 (sequence-bounding-indices-bad-error
                                  sequence start end)
                                 (values find position)))
-                     (let ((key-i (funcall key i)))
-                       (when (and end (>= index end))
-                         (return (values find position)))
-                       (when (>= index start)
+                     (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))))))
+                                       ;; 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))))))
   (def %find-position-if when)
   (def %find-position-if-not unless))
@@ -1260,3 +1343,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))
+