X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbit-bash.lisp;h=28d920453f998b67c1ac8a361b279bb6de55d2c1;hb=87c62dadeba82095c672161e30a3611016d270fb;hp=c2fb216ae517c8bd94b957cc26bb863fc0d14869;hpb=338732358d49ab202fe55c3581294597d63aec6b;p=sbcl.git diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index c2fb216..28d9204 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -13,7 +13,8 @@ ;;;; types -(deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))) ;;;; support routines @@ -21,8 +22,8 @@ ;;; these, or DEFTRANSFORMs to convert them into something supported ;;; by the architecture. (macrolet ((def (name &rest args) - `(defun ,name ,args - (,name ,@args)))) + `(defun ,name ,args + (,name ,@args)))) (def word-logical-not x) (def word-logical-and x y) (def word-logical-or x y) @@ -39,32 +40,34 @@ ;;; at the "end" and removing bits from the "start". On big-endian ;;; machines this is a left-shift and on little-endian machines this ;;; is a right-shift. -(defun shift-towards-start (number countoid) - (declare (type sb!vm:word number) (fixnum countoid)) - (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid))) - (declare (type bit-offset count)) - (if (zerop count) - number - (ecase sb!c:*backend-byte-order* - (:big-endian - (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)) - (:little-endian - (ash number (- count))))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun shift-towards-start (number countoid) + (declare (type sb!vm:word number) (fixnum countoid)) + (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid))) + (declare (type bit-offset count)) + (if (zerop count) + number + (ecase sb!c:*backend-byte-order* + (:big-endian + (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)) + (:little-endian + (ash number (- count)))))))) ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and ;;; removing bits from the "end". On big-endian machines this is a ;;; right-shift and on little-endian machines this is a left-shift. -(defun shift-towards-end (number count) - (declare (type sb!vm:word number) (fixnum count)) - (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count))) - (declare (type bit-offset count)) - (if (zerop count) - number - (ecase sb!c:*backend-byte-order* - (:big-endian - (ash number (- count))) - (:little-endian - (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun shift-towards-end (number count) + (declare (type sb!vm:word number) (fixnum count)) + (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count))) + (declare (type bit-offset count)) + (if (zerop count) + number + (ecase sb!c:*backend-byte-order* + (:big-endian + (ash number (- count))) + (:little-endian + (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))) #!-sb-fluid (declaim (inline start-mask end-mask)) @@ -87,18 +90,18 @@ #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref)) (defun word-sap-ref (sap offset) (declare (type system-area-pointer sap) - (type index offset) - (values sb!vm:word) - (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) - (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))) + (type index offset) + (values sb!vm:word) + (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) + (sap-ref-word sap (the index (ash offset sb!vm:word-shift)))) (defun %set-word-sap-ref (sap offset value) (declare (type system-area-pointer sap) - (type index offset) - (type sb!vm:word value) - (values sb!vm:word) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))) - value)) + (type index offset) + (type sb!vm:word value) + (values sb!vm:word) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (setf (sap-ref-word sap (the index (ash offset sb!vm:word-shift))) + value)) ;;; the actual bashers and common uses of same @@ -110,29 +113,39 @@ ;;; Align the SAP to a word boundary, and update the offset accordingly. (defmacro !define-sap-fixer (bitsize) - (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize)))) + (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))) `(progn (declaim (inline ,name)) (defun ,name (sap offset) (declare (type system-area-pointer sap) (type index offset) (values system-area-pointer index)) - (let ((address (sap-int sap))) - (values (int-sap #!-alpha (word-logical-andc2 address - sb!vm:fixnum-tag-mask) - #!+alpha (ash (ash address -2) 2)) + (let ((address (sap-int sap)) + (word-mask (1- (ash 1 word-shift)))) + (values (int-sap #!-alpha (word-logical-andc2 address word-mask) + ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in + ;; terms of n-word-bits. On all systems + ;; where n-word-bits is not equal to + ;; n-machine-word-bits we have to do this + ;; another way. At this time, these + ;; systems are alphas, though there was + ;; some talk about an x86-64 build option. + #!+alpha (ash (ash address (- word-shift)) word-shift)) (+ ,(ecase bitsize - (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits)) - (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2))) - (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4))) - ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask))) + ((1 2 4) `(* (logand address word-mask) + (/ n-byte-bits ,bitsize))) + ((8 16 32 64) '(logand address word-mask))) offset))))))) +;;; We cheat a little bit by using TRULY-THE in the copying function to +;;; force the compiler to generate good code in the (= BITSIZE +;;; SB!VM:N-WORD-BITS) case. We don't use TRULY-THE in the other cases +;;; to give the compiler freedom to generate better code. (defmacro !define-byte-bashers (bitsize) (let* ((bytes-per-word (/ n-word-bits bitsize)) (byte-offset `(integer 0 (,bytes-per-word))) (byte-count `(integer 1 (,bytes-per-word))) - (max-bytes (ash most-positive-fixnum + (max-bytes (ash sb!xc:most-positive-fixnum ;; FIXME: this reflects code contained in the ;; original bit-bash.lisp, but seems very ;; nonsensical. Why shouldn't we be able to @@ -144,21 +157,22 @@ (4 0) (8 0) (16 0) - (32 0)))) + (32 0) + (64 0)))) (offset `(integer 0 ,max-bytes)) (max-word-offset (ceiling max-bytes bytes-per-word)) (word-offset `(integer 0 ,max-word-offset)) - (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize))) - (constant-bash-name (intern (format nil "CONSTANT-UB~A-BASH" bitsize) (find-package "SB!KERNEL"))) - (array-fill-name (intern (format nil "UB~A-BASH-FILL" bitsize) (find-package "SB!KERNEL"))) - (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~A-FILL" bitsize) (find-package "SB!KERNEL"))) - (unary-bash-name (intern (format nil "UNARY-UB~A-BASH" bitsize) (find-package "SB!KERNEL"))) - (array-copy-name (intern (format nil "UB~A-BASH-COPY" bitsize) (find-package "SB!KERNEL"))) - (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~A-COPY" bitsize) (find-package "SB!KERNEL"))) + (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))) + (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL"))) + (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL"))) + (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL"))) + (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL"))) + (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL"))) + (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL"))) (array-copy-to-system-area-name - (intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL"))) + (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL"))) (system-area-copy-to-array-name - (intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" bitsize) + (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))) `(progn (declaim (inline ,constant-bash-name ,unary-bash-name)) @@ -198,6 +212,13 @@ (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) mask)))) (incf dst-word-offset)))) + (let ((end (+ dst-word-offset interior))) + (declare (type ,word-offset end)) + (do () + ((>= dst-word-offset end)) + (funcall dst-set-fn dst dst-word-offset value) + (incf dst-word-offset))) + #+nil (dotimes (i interior) (funcall dst-set-fn dst dst-word-offset value) (incf dst-word-offset)) @@ -211,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))) @@ -333,10 +359,19 @@ (incf src-word-offset) (incf dst-word-offset)))) ;; Copy the interior words. - (dotimes (i interior) - (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)) - (incf src-word-offset) - (incf dst-word-offset)) + (let ((end ,(if (= bytes-per-word 1) + `(truly-the ,word-offset + (+ dst-word-offset interior)) + `(+ dst-word-offset interior)))) + (declare (type ,word-offset end)) + (do () + ((>= dst-word-offset end)) + (funcall dst-set-fn dst dst-word-offset + (funcall src-ref-fn src src-word-offset)) + ,(if (= bytes-per-word 1) + `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1))) + `(incf src-word-offset)) + (incf dst-word-offset))) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) ;; We are only writing part of the last word. @@ -349,8 +384,14 @@ (word-logical-andc2 orig mask)))))))) (t ;; We need to loop from right to left. - (incf dst-word-offset words) - (incf src-word-offset words) + ,(if (= bytes-per-word 1) + `(setf dst-word-offset (truly-the ,word-offset + (+ dst-word-offset words))) + `(incf dst-word-offset words)) + ,(if (= bytes-per-word 1) + `(setf src-word-offset (truly-the ,word-offset + (+ src-word-offset words))) + `(incf src-word-offset words)) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) (let ((mask (start-mask (* final-bytes ,bitsize))) @@ -360,10 +401,13 @@ (funcall dst-set-fn dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))) - (dotimes (i interior) - (decf src-word-offset) - (decf dst-word-offset) - (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))) + (let ((end (- dst-word-offset interior))) + (do () + ((<= dst-word-offset end)) + (decf src-word-offset) + (decf dst-word-offset) + (funcall dst-set-fn dst dst-word-offset + (funcall src-ref-fn src src-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) ;; We are only writing part of the last word. @@ -395,7 +439,8 @@ (declare (type word prev next)) (flet ((get-next-src () (setf prev next) - (setf next (funcall src-ref-fn src (incf src-word-offset))))) + (setf next (funcall src-ref-fn src + (incf src-word-offset))))) (declare (inline get-next-src)) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) @@ -410,14 +455,17 @@ (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))) (incf dst-word-offset)))) - (dotimes (i interior) - (get-next-src) - (let ((value (word-logical-or - (shift-towards-end next (* (- src-shift) ,bitsize)) - (shift-towards-start prev (* src-shift ,bitsize))))) - (declare (type word value)) - (funcall dst-set-fn dst dst-word-offset value) - (incf dst-word-offset))) + (let ((end (+ dst-word-offset interior))) + (declare (type ,word-offset end)) + (do () + ((>= dst-word-offset end)) + (get-next-src) + (let ((value (word-logical-or + (shift-towards-end next (* (- src-shift) ,bitsize)) + (shift-towards-start prev (* src-shift ,bitsize))))) + (declare (type word value)) + (funcall dst-set-fn dst dst-word-offset value) + (incf dst-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) (let ((value @@ -437,8 +485,7 @@ (t ;; We need to loop from right to left. (incf dst-word-offset words) - (incf src-word-offset - (1- (ceiling (+ src-byte-offset length) ,bytes-per-word))) + (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word))) (let ((next 0) (prev (funcall src-ref-fn src src-word-offset))) (declare (type word prev next)) @@ -460,14 +507,16 @@ (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))) (decf dst-word-offset) - (dotimes (i interior) - (get-next-src) - (let ((value (word-logical-or - (shift-towards-end next (* (- src-shift) ,bitsize)) - (shift-towards-start prev (* src-shift ,bitsize))))) - (declare (type word value)) - (funcall dst-set-fn dst dst-word-offset value) - (decf dst-word-offset))) + (let ((end (- dst-word-offset interior))) + (do () + ((<= dst-word-offset end)) + (get-next-src) + (let ((value (word-logical-or + (shift-towards-end next (* (- src-shift) ,bitsize)) + (shift-towards-start prev (* src-shift ,bitsize))))) + (declare (type word value)) + (funcall dst-set-fn dst dst-word-offset value) + (decf dst-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) (if (> src-byte-offset dst-byte-offset) @@ -545,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)))