X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=e265747471409b25a80f07ccfb332d88d1229543;hb=0152c2971917eed5117f5d6b53653bd8424b6b1f;hp=cb127c40f5c4d9cec9be89aef6023d7770b75dee;hpb=b29b99561100c81e3fc90b7f05462a1fa8d0903d;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index cb127c4..e265747 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -284,12 +284,12 @@
 (deftransform %check-vector-sequence-bounds ((vector start end)
                                              (vector * *) *
                                              :node node)
-  (if (policy node (< safety speed))
+  (if (policy node (= 0 insert-array-bounds-checks))
       '(or end (length vector))
       '(let ((length (length vector)))
-        (if (<= 0 start (or end length) length)
-            (or end length)
-            (sb!impl::signal-bounding-indices-bad-error vector start end)))))
+         (if (<= 0 start (or end length) length)
+             (or end length)
+             (sequence-bounding-indices-bad-error vector start end)))))
 
 (defun specialized-list-seek-function-name (function-name key-functions)
   (or (find-symbol (with-output-to-string (s)
@@ -417,7 +417,8 @@
     (values
      `(with-array-data ((data seq)
                         (start start)
-                        (end end))
+                        (end end)
+                        :check-fill-pointer t)
        (declare (type (simple-array ,element-type 1) data))
        (declare (type fixnum start end))
        (do ((i start (1+ i)))
@@ -616,9 +617,9 @@
           ,(unless (policy node (= safety 0))
              `(progn
                  (unless (<= 0 start1 end1 len1)
-                   (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
+                   (sequence-bounding-indices-bad-error seq1 start1 end1))
                  (unless (<= 0 start2 end2 len2)
-                   (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
+                   (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))
@@ -780,26 +781,42 @@
                   (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)
-                      (sb!impl::signal-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 subseq ((seq start &optional end)
+                      ((and sequence (not vector) (not list)) t &optional t))
+  '(sb!sequence:subseq seq start end))
 
 (deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
   (let ((array-type (lvar-type seq)))
@@ -820,6 +837,7 @@
                                from-end)
                       (vector vector &rest t)
                       *
+                      :node node
                       :policy (> speed (max space safety)))
   "open code"
   (let ((from-end (when (lvar-p from-end)
@@ -827,44 +845,55 @@
                       (give-up-ir1-transform ":FROM-END is not constant."))
                     (lvar-value from-end)))
         (keyp (lvar-p key))
-        (testp (lvar-p test)))
+        (testp (lvar-p test))
+        (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
     `(block search
-       (let ((end1 (or end1 (length pattern)))
-             (end2 (or end2 (length text)))
-             ,@(when keyp
-                     '((key (coerce key 'function))))
-             ,@(when testp
-                     '((test (coerce test 'function)))))
-         (declare (type index start1 start2 end1 end2))
-         (do (,(if from-end
-                   '(index2 (- end2 (- end1 start1)) (1- index2))
-                   '(index2 start2 (1+ index2))))
-             (,(if from-end
-                   '(< index2 start2)
-                   '(>= index2 end2))
-              nil)
-           ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
-           ;; terminates is hits -1 when :FROM-END is true and :START2
-           ;; is 0.
-           (declare (type fixnum index2))
-           (when (do ((index1 start1 (1+ index1))
-                      (index2 index2 (1+ index2)))
-                     ((>= index1 end1) t)
-                   (declare (type index index1 index2))
-                   ,@(unless from-end
-                             '((when (= index2 end2)
-                                 (return-from search nil))))
-                   (unless (,@(if testp
-                                  '(funcall test)
-                                  '(eql))
-                              ,(if keyp
-                                   '(funcall key (aref pattern index1))
-                                   '(aref pattern index1))
-                              ,(if keyp
-                                   '(funcall key (aref text index2))
-                                   '(aref text index2)))
-                     (return nil)))
-             (return index2)))))))
+       (flet ((oops (vector start end)
+                (sequence-bounding-indices-bad-error vector start end)))
+         (let* ((len1 (length pattern))
+                (len2 (length text))
+                (end1 (or end1 len1))
+                (end2 (or end2 len2))
+               ,@(when keyp
+                       '((key (coerce key 'function))))
+               ,@(when testp
+                       '((test (coerce test 'function)))))
+          (declare (type index start1 start2 end1 end2))
+          ,@(when check-bounds-p
+             `((unless (<= start1 end1 len1)
+                 (oops pattern start1 end1))
+               (unless (<= start2 end2 len2)
+                 (oops pattern start2 end2))))
+          (do (,(if from-end
+                    '(index2 (- end2 (- end1 start1)) (1- index2))
+                    '(index2 start2 (1+ index2))))
+              (,(if from-end
+                    '(< index2 start2)
+                    '(>= index2 end2))
+               nil)
+            ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+            ;; terminates is hits -1 when :FROM-END is true and :START2
+            ;; is 0.
+            (declare (type fixnum index2))
+            (when (do ((index1 start1 (1+ index1))
+                       (index2 index2 (1+ index2)))
+                      ((>= index1 end1) t)
+                    (declare (type index index1 index2)
+                             (optimize (insert-array-bounds-checks 0)))
+                    ,@(unless from-end
+                              '((when (= index2 end2)
+                                  (return-from search nil))))
+                    (unless (,@(if testp
+                                   '(funcall test)
+                                   '(eql))
+                               ,(if keyp
+                                    '(funcall key (aref pattern index1))
+                                    '(aref pattern index1))
+                               ,(if keyp
+                                    '(funcall key (aref text index2))
+                                    '(aref text index2)))
+                      (return nil)))
+              (return index2))))))))
 
 
 ;;; Open-code CONCATENATE for strings. It would be possible to extend
@@ -980,7 +1009,7 @@
                    (declare (type index index))
                    (dolist (i sequence
                             (if (and end (> end index))
-                                (sb!impl::signal-bounding-indices-bad-error
+                                (sequence-bounding-indices-bad-error
                                  sequence start end)
                                 (values find position)))
                      (let ((key-i (funcall key i)))
@@ -1043,13 +1072,12 @@
                                                             end-arg
                                                             element
                                                             done-p-expr)
-  (with-unique-names (offset block index n-sequence sequence n-end end)
-    `(let ((,n-sequence ,sequence-arg)
-           (,n-end ,end-arg))
+  (with-unique-names (offset block index n-sequence sequence end)
+    `(let* ((,n-sequence ,sequence-arg))
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
                          (,start ,start)
-                         (,end (%check-vector-sequence-bounds
-                                ,n-sequence ,start ,n-end)))
+                         (,end ,end-arg)
+                         :check-fill-pointer t)
          (block ,block
            (macrolet ((maybe-return ()
                         ;; WITH-ARRAY-DATA has already performed bounds
@@ -1057,10 +1085,10 @@
                         ;; in the inner loop.
                         '(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0)))
                                            (aref ,sequence ,index))))
-                           (when ,done-p-expr
-                             (return-from ,block
-                               (values ,element
-                                       (- ,index ,offset)))))))
+                          (when ,done-p-expr
+                            (return-from ,block
+                              (values ,element
+                                      (- ,index ,offset)))))))
              (if ,from-end
                  (loop for ,index
                        ;; (If we aren't fastidious about declaring that
@@ -1071,7 +1099,7 @@
                        from (1- ,end) downto ,start do
                        (maybe-return))
                  (loop for ,index of-type index from ,start below ,end do
-                       (maybe-return))))
+                          (maybe-return))))
            (values nil nil))))))
 
 (def!macro %find-position-vector-macro (item sequence
@@ -1137,7 +1165,7 @@
   "expand inline"
   (check-inlineability-of-find-position-if sequence from-end)
   '(%find-position-vector-macro item sequence
-                                from-end start end key test))
+    from-end start end key test))
 
 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
 ;;; POSITION-IF, etc.