From: Nikodemus Siivola Date: Tue, 13 Dec 2011 15:45:34 +0000 (+0200) Subject: faster FIND and POSITION on bit-vectors X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=41cb424785ec6daf0263acb1a6a8af9d41708990;p=sbcl.git faster FIND and POSITION on bit-vectors 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. --- diff --git a/NEWS b/NEWS index 1f3e208..9bf52bd 100644 --- a/NEWS +++ b/NEWS @@ -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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 764a683..09532f1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -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" diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 7c7e539..909db1f 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -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)))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index d3e88e0..cc02671 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -2162,7 +2162,7 @@ (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) @@ -2170,14 +2170,27 @@ (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) @@ -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 diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index f5f7483..ac8cd0f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1444,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")) + `(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)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 7de0756..2df75d1 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -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