changeset 543: |
b88bd4b0a039 |
parent: |
e2e5c4831389
|
child: |
ec1d4d544c36 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sat, 13 Jul 2024 00:03:13 -0400 |
permissions: |
-rw-r--r-- |
description: |
tweaks |
1 ;;; std/bit.lisp --- Bit manipulation 5 ;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html 7 ;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html 13 (defun make-bits (length &rest args) 14 (apply #'make-array length (nconc (list :element-type 'bit) args))) 16 ;; https://graphics.stanford.edu/~seander/bithacks.html 17 ;; http://www.azillionmonkeys.com/qed/asmexample.html 18 (defun haipart (n count) 19 (declare (fixnum n count)) 22 (ldb (byte (- count) 0) x) 23 (ldb (byte count (max 0 (- (integer-length x) count))) 30 "compute the sign bit of a fixnum. If N < 0 return -1 else return 0." 32 (ash n (- 0 (integer-length n)))) 36 (defun different-signs-p (x y) 37 "Return non-nil iff x and y have opposite signs." 38 (declare (fixnum x y) (optimize (speed 1))) 42 (defun mortify-bits (x y) 43 "Interleave the bits of two numbers (Mortan numbers)." 46 ;; (loop for i across (integer-length) 48 ;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1); 53 (defun int-list-bits (n) 56 (dotimes (position (integer-length n) bits) 57 (push (ldb (byte 1 position) n) bits)))) 59 (defun int-bit-vector (n) 61 (let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) 62 (dotimes (position (integer-length n) bits) 63 (vector-push-extend (ldb (byte 1 position) n) bits)))) 65 (defun aref-bit (octets idx) 66 (declare (octet-vector octets) (fixnum idx)) 67 (multiple-value-bind (octet-idx bit-idx) 70 (aref octets octet-idx)))) 72 (defun make-bit-vector (size &optional (fill 0)) 73 "Make a BIT-VECTOR with SIZE and initial-element FILL which must be a 74 BIT 0|1. Note that this representation is not as useful as you might 75 think - bit-vectors don't have a direct mapping to integers/fixnums -- 76 they are vectors (AKA arrays) first, and bits second. Attempting to 77 perform bitwise-ops ends up being very inefficient so whenever 78 possible, stick with fixnums and use LOG* functions." 80 (make-array size :initial-element fill :adjustable nil :element-type 'bit)) 82 ;; simple setter/getter for integer bits 83 (define-setf-expander logbit (index place &environment env) 84 (multiple-value-bind (temps vals stores store-form access-form) 85 (get-setf-expansion place env) 88 (stemp (first stores))) 92 `(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form)) 96 `(logbit ,i ,access-form))))) 99 (declare (fixnum idx n)) 100 (ldb (byte 1 idx) n)) 104 ;; see https://github.com/marcoheisig/bitfield 106 ;; A bitfield is a simple, efficient mechanism for storing multiple 107 ;; discrete states into a single non-negative integer. 110 "A bitfield is a non-negative integer that efficiently encodes 111 information about some booleans, enumerations, or small integers." 115 (defgeneric bitfield-slot-name (bitfield-slot) 117 "Returns a symbol that is the name of the bitfield slot.")) 119 (defgeneric bitfield-slot-start (bitfield-slot) 121 "Returns the position of the first bit of this slot in the bitfield.")) 123 (defgeneric bitfield-slot-end (bitfield-slot) 125 "Returns the position right after the last bit of this slot in the bitfield.")) 127 (defgeneric bitfield-slot-size (bitfield-slot) 129 "Returns an unsigned byte that is the number of distinct states of the slot.")) 131 (defgeneric bitfield-slot-initform (bitfield-slot) 133 "Returns a form that produces the initial value for that slot.")) 135 (defgeneric bitfield-slot-pack (bitfield-slot value-form) 137 "Takes a form that produces a value and turns it into a form that produces 138 a non-negative integer representing that value.")) 140 (defgeneric bitfield-slot-unpack (bitfield-slot value-form) 142 "Take a form that produces a value that is encoded as a non-negative 143 integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that 144 produces the decoded value.")) 146 (defgeneric parse-atomic-bitfield-slot-specifier 147 (specifier &key initform) 149 "Parses an atomic bitfield slot specifier, i.e., a bitfield slot 150 specifier that is not a list. Returns three values: 152 1. A designator for a bitfield slot class. 154 2. The size of the bitfield slot. 156 3. A list of additional arguments that will be supplied to MAKE-INSTANCE 157 when creating the bitfield slot instance.")) 159 (defgeneric parse-compound-bitfield-slot-specifier 160 (specifier arguments &key initform) 162 "Parses a compount bitfield slot specifier, i.e., a bitfield slot 163 specifier that is a list. The SPECIFIER is the CAR of that list and the 164 ARGUMENTS are the CDR of that list. Returns three values: 166 1. A designator for a bitfield slot class. 168 2. The size of the bitfield slot. 170 3. A list of additional arguments that will be supplied to MAKE-INSTANCE 171 when creating the bitfield slot instance.")) 173 (defclass bitfield-slot () 174 ((%name :initarg :name :reader bitfield-slot-name) 175 (%initform :initarg :initform :reader bitfield-slot-initform) 176 (%start :initarg :start :reader bitfield-slot-start) 177 (%end :initarg :end :reader bitfield-slot-end) 178 (%size :initarg :size :reader bitfield-slot-size))) 181 (defclass bitfield-boolean-slot (bitfield-slot) 184 (defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form) 185 `(if ,value-form 1 0)) 187 (defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form) 188 `(ecase ,value-form (0 nil) (1 t))) 190 (defmethod parse-atomic-bitfield-slot-specifier 191 ((specifier (eql 'boolean)) &key (initform 'nil)) 192 (values 'bitfield-boolean-slot 194 `(:initform ,initform))) 197 (defclass bitfield-integer-slot (bitfield-slot) 201 :reader bitfield-integer-slot-offset))) 203 (defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form) 204 (let ((offset (bitfield-integer-slot-offset slot)) 205 (size (bitfield-slot-size slot))) 206 `(the (integer 0 (,size)) 207 (- (the (integer ,offset (,(+ offset size))) ,value-form) 210 (defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form) 211 (let ((offset (bitfield-integer-slot-offset slot)) 212 (size (bitfield-slot-size slot))) 213 `(the (integer ,offset (,(+ offset size))) 214 (+ ,value-form ,offset)))) 216 (defmethod parse-atomic-bitfield-slot-specifier 217 ((specifier (eql 'bit)) &key (initform '0)) 218 (values 'bitfield-unsigned-byte-slot 220 `(:offset 0 :initform ,initform))) 222 (defmethod parse-compound-bitfield-slot-specifier 223 ((specifier (eql 'unsigned-byte)) arguments &key (initform '0)) 224 (destructuring-bind (bits) arguments 225 (check-type bits unsigned-byte) 226 (values 'bitfield-integer-slot 228 `(:offset 0 :initform ,initform)))) 230 (defmethod parse-compound-bitfield-slot-specifier 231 ((specifier (eql 'signed-byte)) arguments &key (initform '0)) 232 (destructuring-bind (bits) arguments 233 (check-type bits unsigned-byte) 234 (values 'bitfield-integer-slot 236 `(:offset ,(- (expt 2 (1- bits))) :initform ,initform)))) 238 (defmethod parse-compound-bitfield-slot-specifier 239 ((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p)) 241 (error "Invalid integer bitfield slot specifier: ~S" 242 `(integer ,@bounds)))) 243 (unless (typep bounds '(cons t (cons t null))) 245 (destructuring-bind (lo hi) bounds 246 (let* ((start (typecase lo 256 (size (- end start))) 259 (values 'bitfield-integer-slot 261 `(:offset ,start :initform ,(if initform-supplied-p initform start))))))) 264 (defclass bitfield-member-slot (bitfield-slot) 268 :reader bitfield-member-slot-objects))) 270 (defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form) 272 ,@(loop for key in (bitfield-member-slot-objects slot) 274 collect `((,key) ,value)))) 276 (defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form) 278 ,@(loop for key from 0 279 for value in (bitfield-member-slot-objects slot) 280 collect `((,key) ',value)))) 282 (defmethod parse-compound-bitfield-slot-specifier 283 ((specifier (eql 'member)) objects &key (initform `',(first objects))) 284 (values 'bitfield-member-slot 286 `(:initform ,initform :objects ,objects))) 289 ;; The position right after the last slot that has been parsed so far. 290 (defvar *bitfield-position*) 292 (defun parse-bitfield-slot (slot) 293 (destructuring-bind (slot-name slot-specifier &rest rest) slot 294 (check-type slot-name symbol) 295 (multiple-value-bind (slot-class size args) 296 (if (consp slot-specifier) 297 (apply #'parse-compound-bitfield-slot-specifier 301 (apply #'parse-atomic-bitfield-slot-specifier 304 (apply #'make-instance slot-class 307 :start *bitfield-position* 308 :end (incf *bitfield-position* (integer-length (1- size))) 311 (defmacro define-bitfield (name &body slots) 312 "Defines an encoding of enumerable properties like booleans, 313 integers or finite sets as a single non-negative integer. 315 For a supplied bitfield name NAME, and for some slot definitions of the 316 form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines 317 the following functions: 319 1. A constructor named MAKE-{NAME}, that takes one keyword argument per 320 SLOT-NAME, similar to the default constructor generated by DEFSTRUCT. 321 It returns a bitfield whose entries have the values indicated by the 322 keyword arguments, or the supplied initform. 324 2. A clone operation named CLONE-{NAME}, that takes an existing bitfield 325 and one keyword argument per SLOT-NAME. It returns a copy of the 326 existing bitfield, but where each supplied keyword argument supersedes 327 the value of the corresponding slot. 329 3. A reader function named {NAME}-{SLOT-NAME} for each slot. 331 In addition to these functions, NAME is defined as a suitable subtype of 334 This macro supports boolean, integer, and member slots. It is also 335 possible to add new kinds of slots by defining new subclasses of 336 BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK, 337 BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or 338 PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER. 342 (define-bitfield examplebits 345 (c (unsigned-byte 3) :initform 1) 346 (d (integer -100 100)) 347 (e (member foo bar baz))) 349 (defun examplebits-values (examplebits) 351 (examplebits-a examplebits) 352 (examplebits-b examplebits) 353 (examplebits-c examplebits) 354 (examplebits-d examplebits) 355 (examplebits-e examplebits))) 357 (defparameter *default* (make-examplebits)) 359 (examplebits-values *default*) 360 ;; => (nil 0 1 -100 foo) 362 (defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz)) 364 (examplebits-values *explicit*) 365 ;; => (t -1 7 42 baz) 367 (defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar)) 369 (examplebits-values *clone*) 370 ;; => (nil -1 2 -12 bar) 372 (let* ((*bitfield-position* 0) 373 (package (symbol-package name)) 375 (intern (concatenate 'string "MAKE-" (symbol-name name)) package)) 377 (intern (concatenate 'string "CLONE-" (symbol-name name)) package)) 379 (concatenate 'string )) 381 (mapcar #'parse-bitfield-slot slots)) 383 (loop for slot in slots 385 (intern (concatenate 'string (symbol-name name) "-" reader-prefix 386 (symbol-name (bitfield-slot-name slot))) 389 (deftype ,name () '(unsigned-byte ,*bitfield-position*)) 390 ;; Define all slot readers. 391 ,@(loop for slot in slots 392 for reader-name in reader-names 393 for start = (bitfield-slot-start slot) 394 for end = (bitfield-slot-end slot) 396 `(declaim (inline ,reader-name)) 398 `(defun ,reader-name (,name) 399 (declare (,name ,name)) 400 ,(bitfield-slot-unpack 402 `(ldb (byte ,(- end start) ,start) ,name)))) 403 ;; Define the cloner. 404 (declaim (inline ,cloner)) 406 (,name &key ,@(loop for slot in slots 407 for reader-name in reader-names 409 `(,(bitfield-slot-name slot) 410 (,reader-name ,name)))) 411 (declare (,name ,name)) 413 ,@(loop for slot in slots 415 `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) 416 ,(bitfield-slot-start slot))))) 417 ;; Define the constructor. 418 (declaim (inline ,constructor)) 420 (&key ,@(loop for slot in slots 422 `(,(bitfield-slot-name slot) 423 ,(bitfield-slot-initform slot)))) 425 ,@(loop for slot in slots 427 `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) 428 ,(bitfield-slot-start slot))))) 432 (declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*)) 433 (defvar *bit-map* #(#*0000 451 `(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 452 #\a #\b #\c #\d #\e #\f 453 #\A #\B #\C #\D #\E #\F)) 455 (declaim (ftype (function (hex-char) (integer 0 16)) hexchar->int) 456 (inline hexchar->int)) 457 (defun hexchar-to-int (char) 458 "Return the bit vector associated with a hex-value character CHAR from *bit-map*." 459 (declare (optimize (speed 2) (safety 0))) 460 (cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0))) 461 ((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10))) 462 (t (- (char-code char) #.(- (char-code #\A) 10)) 463 ;; always return these results 464 #+nil (char<= #\A char #\F)))) 467 (defun hex-string-to-octet-vector (string &aux (start 0) (end (length string))) 468 "Parses a substring of STRING delimited by START and END of 469 hexadecimal digits into a byte array." 470 (declare (type string string)) 472 (ash (- end start) -1) 473 #+nil (/ (- end start) 2)) 474 (key (make-array length :element-type '(unsigned-byte 8)))) 475 (declare (type (simple-array (unsigned-byte 8)) key)) 477 for j from start below end by 2 478 do (setf (aref key i) 479 (+ (* (hexchar-to-int (char string j)) 16) 480 (hexchar-to-int (char string (1+ j))))) 481 finally (return key)))) 483 (defun octet-vector-to-hex-string (vector) 484 "Return a string containing the hexadecimal representation of the 485 subsequence of VECTOR between START and END. ELEMENT-TYPE controls 486 the element-type of the returned string." 487 (declare (type (vector (unsigned-byte 8)) vector)) 488 (let* ((length (length vector)) 489 (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string))) 490 (loop with string = (make-string (* length 2) :element-type 'base-char) 491 for i from 0 below length 493 do (let ((byte (aref vector i))) 494 (declare (optimize (safety 0))) 495 (setf (aref string j) 496 (aref hexdigits (ldb (byte 4 4) byte)) 498 (aref hexdigits (ldb (byte 4 0) byte)))) 499 finally (return string)))) 501 (defun octets-to-integer (octet-vec &optional (end (length octet-vec))) 502 (declare (type (simple-array (unsigned-byte 8)) octet-vec)) 506 (setf sum (+ (aref octet-vec j) (ash sum 8))))) 508 (defun read-little-endian (s &optional (bytes 4)) 509 "Read a number in little-endian format from an byte (octet) stream S, 510 the number having BYTES octets (defaulting to 4)." 511 (loop for i from 0 below bytes 512 sum (ash (read-byte s) (* 8 i)))) 514 (defun write-little-endian (i s &optional (bytes 4)) 515 (write-sequence (nreverse (integer-to-octets i (* 8 bytes))) s)) 517 (defun integer-to-octets (bignum &optional (n-bits (integer-length bignum))) 518 (let* ((n-bytes (ceiling n-bits 8)) 519 (octet-vec (make-array n-bytes :element-type '(unsigned-byte 8)))) 520 (declare (type (simple-array (unsigned-byte 8)) octet-vec)) 521 (loop for i from (1- n-bytes) downto 0 523 do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum)) 524 finally (return octet-vec))))