X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbit-bash.lisp;h=28d920453f998b67c1ac8a361b279bb6de55d2c1;hb=d5520a24b6c356918c2f91bf91dae60f62e1d065;hp=cb54b817c63ec58903d5398460614acbd65a1560;hpb=7e02fe01f102c9e536df701dc783149a8d76b3fc;p=sbcl.git

diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp
index cb54b81..28d9204 100644
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -232,11 +232,16 @@
         (values))
 
       ;; common uses for constant-byte-bashing
+      (defknown ,array-fill-name (word simple-unboxed-array ,offset ,offset)
+          simple-unboxed-array
+          ()
+        :result-arg 1)
       (defun ,array-fill-name (value dst dst-offset length)
         (declare (type word value) (type ,offset dst-offset length))
         (declare (optimize (speed 3) (safety 1)))
         (,constant-bash-name dst dst-offset length value
-                             #'%vector-raw-bits #'%set-vector-raw-bits))
+                             #'%vector-raw-bits #'%set-vector-raw-bits)
+        dst)
       (defun ,system-area-fill-name (value dst dst-offset length)
         (declare (type word value) (type ,offset dst-offset length))
         (declare (optimize (speed 3) (safety 1)))
@@ -589,3 +594,100 @@
   (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 eg. octet vectors get POSITION 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 (offset)
+                             (,@frob (%vector-raw-bits vector offset))))
+                      (declare (inline start-bit end-bit get-word))
+                      (if from-end
+                          ;; Back to front
+                          (let* ((word-offset last-word)
+                                 (word (logand end-mask (get-word 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 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* ((word-offset first-word)
+                                 (word (logand start-mask (get-word 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 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)
+  (case bit
+    (0 (%bit-position/0 vector from-end start end))
+    (1 (%bit-position/1 vector from-end start end))
+    (otherwise nil)))