Fix typo in comment in src/compiler/seqtran.lisp

[sbcl.git] / src / compiler / seqtran.lisp

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 68306ee..a83a68c 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -643,15 +643,28 @@
                                                            (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
                            res)))))
              (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))
-                 (declare (optimize (safety 0) (speed 3)))
-                 (,basher ,bash-value data start (- end start))
-                 seq)
+              ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up
+              ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization.
+              (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*))))
+                  `(let* ((len (length seq))
+                          (end (or end len))
+                          (bound (1+ end)))
+                     ;; Minor abuse %CHECK-BOUND for bounds checking.
+                     ;; (- END START) may still end up negative, but
+                     ;; the basher handle that.
+                     (,basher ,bash-value seq
+                              (%check-bound seq bound start)
+                              (- (if end (%check-bound seq bound end) len)
+                                 start)))
+               `(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))
+                  (declare (optimize (safety 0) (speed 3)))
+                  (,basher ,bash-value data start (- end start))
+                  seq))
               `((declare (type ,element-type item))))))
           ((policy node (> speed space))
            (values
@@ -994,7 +1007,8 @@
   (let ((type (lvar-type seq)))
     (cond
       ((and (array-type-p type)
-            (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+            (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))
+            (policy node (> speed space)))
        (let ((element-type (type-specifier (array-type-specialized-element-type type))))
          `(let* ((length (length seq))
                  (end (or end length)))
@@ -1009,8 +1023,6 @@
                                                        'start)
                                               'result 0 'size element-type)
               result))))
-      ((csubtypep type (specifier-type 'string))
-       '(string-subseq* seq start end))
       (t
        '(vector-subseq* seq start end)))))
 
@@ -1031,8 +1043,6 @@
                      (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)))))
 
@@ -1140,7 +1150,7 @@
 ;;; practice.
 ;;;
 ;;; Limit full open coding based on length of constant sequences. Default
-;;; value is chosen so that other parts of to compiler (constraint propagation
+;;; value is chosen so that other parts of the 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)
@@ -1434,6 +1444,31 @@
     from-end start end key test))
 
 (deftransform %find-position ((item sequence from-end start end key test)
+                              (t bit-vector t t t t t)
+                              * :node node)
+  (when (and test (lvar-fun-is test '(eq eql equal)))
+    (setf test nil))
+  (when (and key (lvar-fun-is key '(identity)))
+    (setf key nil))
+  (when (or test key)
+    (delay-ir1-transform node :optimize)
+    (give-up-ir1-transform "non-trivial :KEY or :TEST"))
+  (catch 'not-a-bit
+    `(with-array-data ((bits sequence :offset-var offset)
+                       (start start)
+                       (end end)
+                       :check-fill-pointer t)
+       (let ((p ,(if (constant-lvar-p item)
+                     (case (lvar-value item)
+                       (0 `(%bit-position/0 bits from-end start end))
+                       (1 `(%bit-position/1 bits from-end start end))
+                       (otherwise (throw 'not-a-bit `(values nil nil))))
+                     `(%bit-position item bits from-end start end))))
+         (if p
+             (values item (the index (- (truly-the index p) offset)))
+             (values nil nil))))))
+
+(deftransform %find-position ((item sequence from-end start end key test)
                               (character string t t t function function)
                               *
                               :policy (> speed space))
@@ -1579,4 +1614,3 @@
   (define-trimmer-transform string-left-trim t nil)
   (define-trimmer-transform string-right-trim nil t)
   (define-trimmer-transform string-trim t t))
-