Read data a word at a time for efficiency's sake.
Could do even better with VOPs, but this already wins hugely on sparse
vectors -- and works on all backends. (Tested on both little- and big-endian
hosts.)
This also makes constraint propagation in sparse universes a bit less sucky.
of the :LITTLE-ENDIAN feature. (Thanks to Luís Oliveira, lp#901661)
* enhancement: better disassembly of segment-prefixes on x86 and other
instruction prefixes (e.g. LOCK) on x86 and x86-64.
+ * optimization: FIND and POSITION on bit-vectors are orders of magnitude
+ faster (assuming KEY and TEST are not used, or are sufficiently trivial).
* optimization: SUBSEQ on vectors of unknown element type is substantially
faster. (lp#902537)
* optimization: specialized arrays with non-zero :INITIAL-ELEMENT can
"UB64-BASH-COPY" "SYSTEM-AREA-UB64-COPY"
"COPY-UB64-TO-SYSTEM-AREA" "COPY-UB64-FROM-SYSTEM-AREA"
+ ;; Bit bashing position for bit-vectors
+ "%BIT-POSITION"
+ "%BIT-POSITION/0"
+ "%BIT-POSITION/1"
+
;; SIMPLE-FUN type and accessors
"SIMPLE-FUN"
"SIMPLE-FUN-P"
(declare (type system-area-pointer sap))
(declare (type fixnum offset))
(copy-ub8-to-system-area bv 0 sap offset (length bv)))
+
+\f
+;;;; Bashing-Style search for bits
+;;;;
+;;;; Similar search would work well for base-strings as well.
+;;;; (Technically for all unboxed sequences of sub-word size elements,
+;;;; but somehow I doubt other eg. octet vectors get POSIION or FIND
+;;;; used as much on them.)
+(defconstant +bit-position-base-mask+ (1- n-word-bits))
+(defconstant +bit-position-base-shift+ (integer-length +bit-position-base-mask+))
+(macrolet ((def (name frob)
+ `(defun ,name (vector from-end start end)
+ (declare (simple-bit-vector vector)
+ (index start end)
+ (optimize (speed 3) (safety 0)))
+ (unless (= start end)
+ (let* ((last-word (ash end (- +bit-position-base-shift+)))
+ (last-bits (logand end +bit-position-base-mask+))
+ (first-word (ash start (- +bit-position-base-shift+)))
+ (first-bits (logand start +bit-position-base-mask+))
+ ;; These mask out everything but the interesting parts.
+ (end-mask #!+little-endian (lognot (ash -1 last-bits))
+ #!+big-endian (ash -1 (- sb!vm:n-word-bits last-bits)))
+ (start-mask #!+little-endian (ash -1 first-bits)
+ #!+big-endian (lognot (ash -1 (- sb!vm:n-word-bits first-bits)))))
+ (declare (index last-word first-word))
+ (flet ((#!+little-endian start-bit
+ #!+big-endian end-bit (x)
+ (declare (word x))
+ (- #!+big-endian sb!vm:n-word-bits
+ (integer-length (logand x (- x)))
+ #!+little-endian 1))
+ (#!+little-endian end-bit
+ #!+big-endian start-bit (x)
+ (declare (word x))
+ (- #!+big-endian sb!vm:n-word-bits
+ (integer-length x)
+ #!+little-endian 1))
+ (found (i word-offset)
+ (declare (index i word-offset))
+ (return-from ,name
+ (logior i (truly-the
+ fixnum
+ (ash word-offset +bit-position-base-shift+)))))
+ (get-word (sap offset)
+ (,@frob (sap-ref-word sap (* n-word-bytes offset)))))
+ (declare (inline start-bit end-bit get-word))
+ (with-pinned-objects (vector)
+ (if from-end
+ ;; Back to front
+ (let* ((sap (vector-sap vector))
+ (word-offset last-word)
+ (word (logand end-mask (get-word sap word-offset))))
+ (declare (word word)
+ (index word-offset))
+ (unless (zerop word)
+ (when (= word-offset first-word)
+ (setf word (logand word start-mask)))
+ (unless (zerop word)
+ (found (end-bit word) word-offset)))
+ (decf word-offset)
+ (loop
+ (when (< word-offset first-word)
+ (return-from ,name nil))
+ (setf word (get-word sap word-offset))
+ (unless (zerop word)
+ (when (= word-offset first-word)
+ (setf word (logand word start-mask)))
+ (unless (zerop word)
+ (found (end-bit word) word-offset)))
+ (decf word-offset)))
+ ;; Front to back
+ (let* ((sap (vector-sap vector))
+ (word-offset first-word)
+ (word (logand start-mask (get-word sap word-offset))))
+ (declare (word word)
+ (index word-offset))
+ (unless (zerop word)
+ (when (= word-offset last-word)
+ (setf word (logand word end-mask)))
+ (unless (zerop word)
+ (found (start-bit word) word-offset)))
+ (incf word-offset)
+ (loop
+ (when (> word-offset last-word)
+ (return-from ,name nil))
+ (setf word (get-word sap word-offset))
+ (unless (zerop word)
+ (when (= word-offset last-word)
+ (setf word (logand word end-mask)))
+ (unless (zerop word)
+ (found (start-bit word) word-offset)))
+ (incf word-offset)))))))))))
+ (def %bit-position/0 (logandc2 #.(1- (expt 2 n-word-bits))))
+ (def %bit-position/1 (identity)))
+(defun %bit-position (bit vector from-end start end)
+ (ecase bit
+ (0 (%bit-position/0 vector from-end start end))
+ (1 (%bit-position/1 vector from-end start end))))
(macrolet (;; shared logic for defining %FIND-POSITION and
;; %FIND-POSITION-IF in terms of various inlineable cases
;; of the expression defined in FROB and VECTOR*-FROB
- (frobs ()
+ (frobs (&optional bit-frob)
`(seq-dispatch sequence-arg
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(end end)
:check-fill-pointer t)
(multiple-value-bind (f p)
- (macrolet ((frob2 () '(if from-end
- (frob sequence t)
- (frob sequence nil))))
+ (macrolet ((frob2 () `(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
(typecase sequence
#!+sb-unicode
((simple-array character (*)) (frob2))
((simple-array base-char (*)) (frob2))
- (t (vector*-frob sequence))))
+ ,@(when bit-frob
+ `((simple-bit-vector
+ (if (and (eq #'identity key)
+ (or (eq #'eq test)
+ (eq #'eql test)
+ (eq #'equal test)))
+ (let ((p (%bit-position (the bit item) sequence
+ from-end start end)))
+ (if p
+ (values item p)
+ (values nil nil)))
+ (vector*-frob sequence)))))
+ (t
+ (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (- p offset)))))))))
(defun %find-position (item sequence-arg from-end start end key test)
(vector*-frob (sequence)
`(%find-position-vector-macro item ,sequence
from-end start end key test)))
- (frobs)))
+ (frobs t)))
(defun %find-position-if (predicate sequence-arg from-end start end key)
(macrolet ((frob (sequence from-end)
`(%find-position-if predicate ,sequence
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"))
+ `(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
+ (abort-ir1-transform)))
+ `(%bit-position (the bit 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))
(assert (raises-error? (concatenate type "qu" '(#\u #\x))))
(assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
+(defun test-bit-position (size set start end from-end res)
+ (let ((v (make-array size :element-type 'bit :initial-element 0)))
+ (dolist (i set)
+ (setf (bit v i) 1))
+ (dolist (f (list (compile nil
+ `(lambda (b v s e fe)
+ (position b (the bit-vector v) :start s :end e :from-end fe)))
+ (compile nil
+ `(lambda (b v s e fe)
+ (assert (eql b 1))
+ (position 1 (the bit-vector v) :start s :end e :from-end fe)))
+ (compile nil
+ `(lambda (b v s e fe)
+ (position b (the vector v) :start s :end e :from-end fe)))))
+ (let ((got (funcall f 1 v start end from-end)))
+ (unless (eql res got)
+ (cerror "Continue" "POSITION 1, Wanted ~S, got ~S.~% size = ~S, set = ~S, from-end = ~S"
+ res got
+ size set from-end)))))
+ (let ((v (make-array size :element-type 'bit :initial-element 1)))
+ (dolist (i set)
+ (setf (bit v i) 0))
+ (dolist (f (list (compile nil
+ `(lambda (b v s e fe)
+ (position b (the bit-vector v) :start s :end e :from-end fe)))
+ (compile nil
+ `(lambda (b v s e fe)
+ (assert (eql b 0))
+ (position 0 (the bit-vector v) :start s :end e :from-end fe)))
+ (compile nil
+ `(lambda (b v s e fe)
+ (position b (the vector v) :start s :end e :from-end fe)))))
+ (let ((got (funcall f 0 v start end from-end)))
+ (unless (eql res got)
+ (cerror "Continue" "POSITION 0, Wanted ~S, got ~S.~% size = ~S, set = ~S, from-end = ~S"
+ res got
+ size set from-end))))))
+
+(defun random-test-bit-position (n)
+ (loop repeat n
+ do (let* ((vector (make-array (+ 2 (random 5000)) :element-type 'bit))
+ (offset (random (1- (length vector))))
+ (size (1+ (random (- (length vector) offset))))
+ (disp (make-array size :element-type 'bit :displaced-to vector
+ :displaced-index-offset offset)))
+ (assert (plusp size))
+ (loop repeat 10
+ do (setf (bit vector (random (length vector))) 1))
+ (flet ((test (orig)
+ (declare (bit-vector orig))
+ (let ((copy (coerce orig 'simple-vector))
+ (p0 (random (length orig)))
+ (p1 (1+ (random (length orig)))))
+ (multiple-value-bind (s e)
+ (if (> p1 p0)
+ (values p0 p1)
+ (values p1 p0))
+ (assert (eql (position 1 copy :start s :end e)
+ (position 1 orig :start s :end e)))
+ (assert (eql (position 1 copy :start s :end e :from-end t)
+ (position 1 orig :start s :end e :from-end t)))))))
+ (test vector)
+ (test disp)))))
+
+(with-test (:name :bit-position)
+ (test-bit-position 0 (list) 0 0 nil nil)
+ (test-bit-position 0 (list) 0 0 t nil)
+ (test-bit-position 1 (list 0) 0 0 nil nil)
+ (test-bit-position 1 (list 0) 0 0 t nil)
+ (test-bit-position 1 (list 0) 0 1 nil 0)
+ (test-bit-position 1 (list 0) 0 1 t 0)
+ (test-bit-position 10 (list 0 1) 0 1 nil 0)
+ (test-bit-position 10 (list 0 1) 1 1 nil nil)
+ (test-bit-position 10 (list 0 1) 0 1 t 0)
+ (test-bit-position 10 (list 0 1) 1 1 t nil)
+ (test-bit-position 10 (list 0 3) 1 4 nil 3)
+ (test-bit-position 10 (list 0 3) 1 4 t 3)
+ (test-bit-position 10 (list 0 3 6) 1 10 nil 3)
+ (test-bit-position 10 (list 0 3 6) 1 10 t 6)
+ (test-bit-position 1000 (list 128 700) 20 500 nil 128)
+ (test-bit-position 1000 (list 128 700) 20 500 t 128)
+ (test-bit-position 1000 (list 423 762) 200 800 nil 423)
+ (test-bit-position 1000 (list 423 762) 200 800 t 762)
+ (test-bit-position 1000 (list 298 299) 100 400 nil 298)
+ (test-bit-position 1000 (list 298 299) 100 400 t 299))
+
+(with-test (:name (:bit-position :random-test))
+ (random-test-bit-position 10000))
+
;;; success
projects / sbcl.git / commitdiff