Re: [Sbcl-devel] [Sbcl-commits] master: don't assume only bits are looked for in bit-vectors

[Paul K. <pv...@pv...>]

On 2012-09-17, at 4:40 PM, Stas Boukarev <sta...@gm...> wrote:

> "Nikodemus Siivola" <de...@us...> writes:
> 
>> The branch "master" has been updated in SBCL:
>>       via  87c62dadeba82095c672161e30a3611016d270fb (commit)
>>      from  7c9bae1be633be46bc454bd34f55263b24aafca8 (commit)
>> 
>> - Log -----------------------------------------------------------------
>> commit 87c62dadeba82095c672161e30a3611016d270fb
>> Author: Nikodemus Siivola <nik...@ra...>
>> Date:   Mon Sep 17 20:46:18 2012 +0300
>> 
>>    don't assume only bits are looked for in bit-vectors
> Although it was wrong, it was actually a good way to catch logical
> errors, perhaps there can be some kind of compiler-note that it will always
> return NIL or something.

How does the following look?

(defun type-element-type-maybe-intersect (item-type vector-type)
  (labels ((rec (vector-type)
             (typecase vector-type
               (union-type
                (some #'rec (union-type-types vector-type)))
               (intersection-type
                (every #'rec (intersection-type-types vector-type)))
               (array-type
                (multiple-value-bind (intersect definitely)
                    (types-equal-or-intersect item-type (array-type-element-type vector-type))
                  (or (not definitely) intersect)))
               (t t))))
    (rec vector-type)))

(defun value-element-type-maybe-subtypep (value vector-type)
  (labels ((rec (vector-type)
             (typecase vector-type
               (union-type
                (some #'rec (union-type-types vector-type)))
               (intersection-type
                (every #'rec (intersection-type-types vector-type)))
               (array-type
                (multiple-value-bind (intersect definitely)
                    (ctypep value (array-type-element-type vector-type))
                  (or (not definitely) intersect)))
               (t t))))
    (rec vector-type)))

(deftransform %find-position ((item sequence from-end start end key test)
                              (t vector t t t function function)
                              *
                              :policy (> speed space))
  "expand inline"
  (let ((ok (and (or (null test) (lvar-fun-is test '(eq eql equal)))
                 (or (null key)  (lvar-fun-is key '(identity))))))
    (cond ((and ok
                (constant-lvar-p item)
                (not (value-element-type-maybe-subtypep (lvar-value item)
                                                        (lvar-type sequence))))
           (style-warn "~S or ~S will never find an element ~S to ~S in a ~S"
                       'find 'position (lvar-fun-name test)
                       (lvar-value item)
                       (type-specifier (lvar-type sequence)))
           `(values nil nil))
          ((and ok
                (not (type-element-type-maybe-intersect (lvar-type item)
                                                        (lvar-type sequence))))
           (style-warn "~S or ~S will never find an element of type ~S in a ~S"
                       'find 'position (type-specifier (lvar-type item))
                       (type-specifier (lvar-type sequence)))
           `(values nil nil))
          (t
           (delay-ir1-transform :optimize)
           (check-inlineability-of-find-position-if sequence from-end)
           '(%find-position-vector-macro item sequence
             from-end start end key test)))))

CL-USER> (compile nil `(lambda (x)
                         (declare (type (simple-array (mod 1024) 1) x)
                                  (optimize speed))
                         (position 1024 x :test #'equal)))
; in: LAMBDA (X)
;     (POSITION 1024 X :TEST #'EQUAL)
; --> NTH-VALUE MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL 
; ==>
;   (SB-KERNEL:%FIND-POSITION SB-C::ITEM SEQUENCE SB-C::FROM-END SB-C::START
;                             SB-C::END
;                             (SB-KERNEL:EFFECTIVE-FIND-POSITION-KEY SB-C::KEY)
;                             (SB-KERNEL:EFFECTIVE-FIND-POSITION-TEST SB-C::TEST
;                                                                     SB-C::TEST-NOT))
; 
; caught STYLE-WARNING:
;   FIND or POSITION will never find an element EQUAL to 1024 in a (SIMPLE-ARRAY
;                                                                   (UNSIGNED-BYTE
;                                                                    10)
;                                                                   (*))
; 
; compilation unit finished
;   caught 1 STYLE-WARNING condition