Skip to content

Commit

Permalink
faster FIND and POSITION on bit-vectors
Browse files Browse the repository at this point in the history 
 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.
  • Loading branch information
@nikodemus
nikodemus committed Dec 29, 2011
1 parent 14bf777 commit 41cb424
Show file tree
Hide file tree
Showing 6 changed files with 239 additions and 6 deletions.
2 changes: 2 additions & 0 deletions NEWS
View file
Expand Up @@ -36,6 +36,8 @@ changes relative to sbcl-1.0.54:
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
Expand Down
5 changes: 5 additions & 0 deletions package-data-list.lisp-expr
View file
Expand Up @@ -1782,6 +1782,11 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
Expand Down
99 changes: 99 additions & 0 deletions src/code/bit-bash.lisp
View file
Expand Up @@ -594,3 +594,102 @@
(declare (type system-area-pointer sap))
(declare (type fixnum offset))
(copy-ub8-to-system-area bv 0 sap offset (length bv)))


;;;; 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))))
25 changes: 19 additions & 6 deletions src/code/seq.lisp
View file
Expand Up @@ -2162,22 +2162,35 @@
(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)
(start start)
(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)
Expand All @@ -2187,7 +2200,7 @@
(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
Expand Down
25 changes: 25 additions & 0 deletions src/compiler/seqtran.lisp
View file
Expand Up @@ -1443,6 +1443,31 @@
'(%find-position-vector-macro item 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)
*
Expand Down
89 changes: 89 additions & 0 deletions tests/seq.impure.lisp
View file
Expand Up @@ -1139,4 +1139,93 @@
(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

0 comments on commit 41cb424

Please sign in to comment.