Coverage report: /home/ellis/comp/core/std/bit.lisp

Kind	Covered	All	%
expression	70	596	11.7
branch	2	16	12.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/bit.lisp --- Bit manipulation

2

3

;;; Commentary:

4

5

;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html

6

7

;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html

8

9

;;; Code:

10

(in-package :std/bit)

11

12

;;; Bits

13

(defun make-bits (length &rest args)

14

"Make an array of bits with dimensions LENGTH and keyword arguments ARGS."

15

(apply #'make-array length (nconc (list :element-type 'bit) args)))

16

17

;; https://graphics.stanford.edu/~seander/bithacks.html

18

;; http://www.azillionmonkeys.com/qed/asmexample.html

19

(defun haipart (n count)

20

(declare (fixnum n count))

21

(let ((x (abs n)))

22

(if (minusp count)

23

(ldb (byte (- count) 0) x)

24

(ldb (byte count (max 0 (- (integer-length x) count)))

25

x))))

26

27

;; minusp = 38 bytes

28

29

;; 29 bytes

30

(defun sign-bit (n)

31

"compute the sign bit of a fixnum. If N < 0 return -1 else return 0."

32

(declare (fixnum n))

33

(ash n (- 0 (integer-length n))))

34

35

;; 51 bytes (speed 3)

36

;; 67 bytes (speed 1)

37

(defun different-signs-p (x y)

38

"Return non-nil iff x and y have opposite signs."

39

(declare (fixnum x y) (optimize (speed 1)))

40

(< (expt x y) 0))

41

42

;; TODO 2024-02-23:

43

(defun mortify-bits (x y)

44

"Interleave the bits of two numbers (Mortan numbers)."

45

(declare (fixnum x y)

46

(ignore x y))

47

;; (loop for i across (integer-length)

48

;; with z = 0

49

;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1);

50

;; do ()

51

;; return z)

52

)

53

54

(defun int-list-bits (n)

55

"Return the list of bits which compose the fixnum N."

56

(declare (fixnum n))

57

(let ((bits '()))

58

(dotimes (position (integer-length n) bits)

59

(push (ldb (byte 1 position) n) bits))))

60

61

(defun int-bit-vector (n)

62

"Return the bit representation of N as a vector of bits."

63

(declare (fixnum n))

64

(let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t)))

65

(dotimes (position (integer-length n) bits)

66

(vector-push-extend (ldb (byte 1 position) n) bits))))

67

68

(defun aref-bit (octets idx)

69

(declare (octet-vector octets) (fixnum idx))

70

(multiple-value-bind (octet-idx bit-idx)

71

(truncate idx 8)

72

(ldb (byte 1 bit-idx)

73

(aref octets octet-idx))))

74

75

(defun make-bit-vector (size &optional (fill 0))

76

"Make a BIT-VECTOR with SIZE and initial-element FILL which must be a

77

BIT 0|1. Note that this representation is not as useful as you might

78

think - bit-vectors don't have a direct mapping to integers/fixnums --

79

they are vectors (AKA arrays) first, and bits second. Attempting to

80

perform bitwise-ops ends up being very inefficient so whenever

81

possible, stick with fixnums and use LOG* functions."

82

(declare (bit fill))

83

(make-array size :initial-element fill :adjustable nil :element-type 'bit))

84

85

;; simple setter/getter for integer bits

86

(define-setf-expander logbit (index place &environment env)

87

(multiple-value-bind (temps vals stores store-form access-form)

88

(get-setf-expansion place env)

89

(let ((i (gensym))

90

(store (gensym))

91

(stemp (first stores)))

92

(values `(,i ,@temps)

93

`(,index ,@vals)

94

`(,store)

95

`(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form))

96

,@(cdr stores))

97

,store-form

98

,store)

99

`(logbit ,i ,access-form)))))

100

101

(defun logbit (idx n)

102

(declare (fixnum idx n))

103

(ldb (byte 1 idx) n))

104

105

;; Hacker's Delight ch 3-1 - petalisp

106

(defun flp2 (n)

107

"Round the unsigned integer N down to the next smaller power of two."

108

(etypecase n

109

(fixnum

110

(let ((x n))

111

(declare (type (and fixnum unsigned-byte) x))

112

(setf x (logior x (ash x -1)))

113

(setf x (logior x (ash x -2)))

114

(setf x (logior x (ash x -4)))

115

(setf x (logior x (ash x -8)))

116

(setf x (logior x (ash x -16)))

117

(setf x (logior x (ash x -32)))

118

(- x (ash x -1))))

119

(unsigned-byte

120

(ash 1 (1- (integer-length n))))))

121

122

(deftype clp2-fixnum ()

123

`(integer 0 ,(expt 2 (1- (integer-length most-positive-fixnum)))))

124

125

(defun clp2 (n)

126

"Round the unsigned integer N up to the next larger power of two."

127

(etypecase n

128

(clp2-fixnum

129

(when (zerop n)

130

(return-from clp2 0))

131

(let ((x (1- n)))

132

(declare (type clp2-fixnum x))

133

(setf x (logior x (ash x -1)))

134

(setf x (logior x (ash x -2)))

135

(setf x (logior x (ash x -4)))

136

(setf x (logior x (ash x -8)))

137

(setf x (logior x (ash x -16)))

138

(setf x (logior x (ash x -32)))

139

(1+ x)))

140

(unsigned-byte

141

(ash 1 (integer-length (1- n))))))

142

143

;;; Bitfields

144

145

;; see https://github.com/marcoheisig/bitfield

146

147

;; A bitfield is a simple, efficient mechanism for storing multiple

148

;; discrete states into a single non-negative integer.

149

150

(deftype bitfield ()

151

"A bitfield is a non-negative integer that efficiently encodes

152

information about some booleans, enumerations, or small integers."

153

'unsigned-byte)

154

155

;;; Bitfield Slots

156

(defgeneric bitfield-slot-name (bitfield-slot)

157

(:documentation

158

"Returns a symbol that is the name of the bitfield slot."))

159

160

(defgeneric bitfield-slot-start (bitfield-slot)

161

(:documentation

162

"Returns the position of the first bit of this slot in the bitfield."))

163

164

(defgeneric bitfield-slot-end (bitfield-slot)

165

(:documentation

166

"Returns the position right after the last bit of this slot in the bitfield."))

167

168

(defgeneric bitfield-slot-size (bitfield-slot)

169

(:documentation

170

"Returns an unsigned byte that is the number of distinct states of the slot."))

171

172

(defgeneric bitfield-slot-initform (bitfield-slot)

173

(:documentation

174

"Returns a form that produces the initial value for that slot."))

175

176

(defgeneric bitfield-slot-pack (bitfield-slot value-form)

177

(:documentation

178

"Takes a form that produces a value and turns it into a form that produces

179

a non-negative integer representing that value."))

180

181

(defgeneric bitfield-slot-unpack (bitfield-slot value-form)

182

(:documentation

183

"Take a form that produces a value that is encoded as a non-negative

184

integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that

185

produces the decoded value."))

186

187

(defgeneric parse-atomic-bitfield-slot-specifier

188

(specifier &key initform)

189

(:documentation

190

"Parses an atomic bitfield slot specifier, i.e., a bitfield slot

191

specifier that is not a list. Returns three values:

192

193

1. A designator for a bitfield slot class.

194

195

2. The size of the bitfield slot.

196

197

3. A list of additional arguments that will be supplied to MAKE-INSTANCE

198

when creating the bitfield slot instance."))

199

200

(defgeneric parse-compound-bitfield-slot-specifier

201

(specifier arguments &key initform)

202

(:documentation

203

"Parses a compount bitfield slot specifier, i.e., a bitfield slot

204

specifier that is a list. The SPECIFIER is the CAR of that list and the

205

ARGUMENTS are the CDR of that list. Returns three values:

206

207

1. A designator for a bitfield slot class.

208

209

2. The size of the bitfield slot.

210

211

3. A list of additional arguments that will be supplied to MAKE-INSTANCE

212

when creating the bitfield slot instance."))

213

214

(defclass bitfield-slot ()

215

((%name :initarg :name :reader bitfield-slot-name)

216

(%initform :initarg :initform :reader bitfield-slot-initform)

217

(%start :initarg :start :reader bitfield-slot-start)

218

(%end :initarg :end :reader bitfield-slot-end)

219

(%size :initarg :size :reader bitfield-slot-size))

220

(:documentation "Superclass for slot objects of a BITFIELD class."))

221

222

;;; Boolean Slots

223

(defclass bitfield-boolean-slot (bitfield-slot)

224

()

225

(:documentation "Boolean bitfield slots."))

226

227

(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form)

228

`(if ,value-form 1 0))

229

230

(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form)

231

`(ecase ,value-form (0 nil) (1 t)))

232

233

(defmethod parse-atomic-bitfield-slot-specifier

234

((specifier (eql 'boolean)) &key (initform 'nil))

235

(values 'bitfield-boolean-slot

236

2

237

`(:initform ,initform)))

238

239

;;; Integer Slots

240

(defclass bitfield-integer-slot (bitfield-slot)

241

((%offset

242

:type integer

243

:initarg :offset

244

:reader bitfield-integer-slot-offset))

245

(:documentation "Integer bitfield slots."))

246

247

(defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form)

248

(let ((offset (bitfield-integer-slot-offset slot))

249

(size (bitfield-slot-size slot)))

250

`(the (integer 0 (,size))

251

(- (the (integer ,offset (,(+ offset size))) ,value-form)

252

,offset))))

253

254

(defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form)

255

(let ((offset (bitfield-integer-slot-offset slot))

256

(size (bitfield-slot-size slot)))

257

`(the (integer ,offset (,(+ offset size)))

258

(+ ,value-form ,offset))))

259

260

(defmethod parse-atomic-bitfield-slot-specifier

261

((specifier (eql 'bit)) &key (initform '0))

262

(values 'bitfield-unsigned-byte-slot

263

2

264

`(:offset 0 :initform ,initform)))

265

266

(defmethod parse-compound-bitfield-slot-specifier

267

((specifier (eql 'unsigned-byte)) arguments &key (initform '0))

268

(destructuring-bind (bits) arguments

269

(check-type bits unsigned-byte)

270

(values 'bitfield-integer-slot

271

(expt 2 bits)

272

`(:offset 0 :initform ,initform))))

273

274

(defmethod parse-compound-bitfield-slot-specifier

275

((specifier (eql 'signed-byte)) arguments &key (initform '0))

276

(destructuring-bind (bits) arguments

277

(check-type bits unsigned-byte)

278

(values 'bitfield-integer-slot

279

(expt 2 bits)

280

`(:offset ,(- (expt 2 (1- bits))) :initform ,initform))))

281

282

(defmethod parse-compound-bitfield-slot-specifier

283

((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p))

284

(flet ((fail ()

285

(error "Invalid integer bitfield slot specifier: ~S"

286

`(integer ,@bounds))))

287

(unless (typep bounds '(cons t (cons t null)))

288

(fail))

289

(destructuring-bind (lo hi) bounds

290

(let* ((start (typecase lo

291

(integer lo)

292

((cons integer null)

293

(1+ (first lo)))

294

(otherwise (fail))))

295

(end (typecase hi

296

(integer (1+ hi))

297

((cons integer null)

298

(first hi))

299

(otherwise (fail))))

300

(size (- end start)))

301

(unless (plusp size)

302

(fail))

303

(values 'bitfield-integer-slot

304

size

305

`(:offset ,start :initform ,(if initform-supplied-p initform start)))))))

306

307

;;; Member Slots

308

(defclass bitfield-member-slot (bitfield-slot)

309

((%objects

310

:type list

311

:initarg :objects

312

:reader bitfield-member-slot-objects))

313

(:documentation "Bitfield slots containing a value from a mutually-exclusive list of options."))

314

315

(defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form)

316

`(ecase ,value-form

317

,@(loop for key in (bitfield-member-slot-objects slot)

318

for value from 0

319

collect `((,key) ,value))))

320

321

(defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form)

322

`(ecase ,value-form

323

,@(loop for key from 0

324

for value in (bitfield-member-slot-objects slot)

325

collect `((,key) ',value))))

326

327

(defmethod parse-compound-bitfield-slot-specifier

328

((specifier (eql 'member)) objects &key (initform `',(first objects)))

329

(values 'bitfield-member-slot

330

(length objects)

331

`(:initform ,initform :objects ,objects)))

332

333

;;; Parsing

334

;; The position right after the last slot that has been parsed so far.

335

(defvar *bitfield-position*)

336

337

(defun parse-bitfield-slot (slot)

338

(destructuring-bind (slot-name slot-specifier &rest rest) slot

339

(check-type slot-name symbol)

340

(multiple-value-bind (slot-class size args)

341

(if (consp slot-specifier)

342

(apply #'parse-compound-bitfield-slot-specifier

343

(car slot-specifier)

344

(cdr slot-specifier)

345

rest)

346

(apply #'parse-atomic-bitfield-slot-specifier

347

slot-specifier

348

rest))

349

(apply #'make-instance slot-class

350

:name slot-name

351

:size size

352

:start *bitfield-position*

353

:end (incf *bitfield-position* (integer-length (1- size)))

354

args))))

355

356

(defmacro define-bitfield (name &body slots)

357

"Defines an encoding of enumerable properties like booleans,

358

integers or finite sets as a single non-negative integer.

359

360

For a supplied bitfield name NAME, and for some slot definitions of the

361

form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines

362

the following functions:

363

364

1. A constructor named MAKE-{NAME}, that takes one keyword argument per

365

SLOT-NAME, similar to the default constructor generated by DEFSTRUCT.

366

It returns a bitfield whose entries have the values indicated by the

367

keyword arguments, or the supplied initform.

368

369

2. A clone operation named CLONE-{NAME}, that takes an existing bitfield

370

and one keyword argument per SLOT-NAME. It returns a copy of the

371

existing bitfield, but where each supplied keyword argument supersedes

372

the value of the corresponding slot.

373

374

3. A reader function named {NAME}-{SLOT-NAME} for each slot.

375

376

In addition to these functions, NAME is defined as a suitable subtype of

377

UNSIGNED-BYTE.

378

379

This macro supports boolean, integer, and member slots. It is also

380

possible to add new kinds of slots by defining new subclasses of

381

BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK,

382

BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or

383

PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER.

384

385

Example:

386

387

(define-bitfield examplebits

388

(a boolean)

389

(b (signed-byte 2))

390

(c (unsigned-byte 3) :initform 1)

391

(d (integer -100 100))

392

(e (member foo bar baz)))

393

394

(defun examplebits-values (examplebits)

395

(list

396

(examplebits-a examplebits)

397

(examplebits-b examplebits)

398

(examplebits-c examplebits)

399

(examplebits-d examplebits)

400

(examplebits-e examplebits)))

401

402

(defparameter *default* (make-examplebits))

403

404

(examplebits-values *default*)

405

;; => (nil 0 1 -100 foo)

406

407

(defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz))

408

409

(examplebits-values *explicit*)

410

;; => (t -1 7 42 baz)

411

412

(defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar))

413

414

(examplebits-values *clone*)

415

;; => (nil -1 2 -12 bar)

416

"

417

(let* ((*bitfield-position* 0)

418

(package (symbol-package name))

419

(constructor

420

(intern (concatenate 'string "MAKE-" (symbol-name name)) package))

421

(cloner

422

(intern (concatenate 'string "CLONE-" (symbol-name name)) package))

423

(reader-prefix

424

(concatenate 'string ))

425

(slots

426

(mapcar #'parse-bitfield-slot slots))

427

(reader-names

428

(loop for slot in slots

429

collect

430

(intern (concatenate 'string (symbol-name name) "-" reader-prefix

431

(symbol-name (bitfield-slot-name slot)))

432

package))))

433

`(progn

434

(deftype ,name () '(unsigned-byte ,*bitfield-position*))

435

;; Define all slot readers.

436

,@(loop for slot in slots

437

for reader-name in reader-names

438

for start = (bitfield-slot-start slot)

439

for end = (bitfield-slot-end slot)

440

collect

441

`(declaim (inline ,reader-name))

442

collect

443

`(defun ,reader-name (,name)

444

(declare (,name ,name))

445

,(bitfield-slot-unpack

446

slot

447

`(ldb (byte ,(- end start) ,start) ,name))))

448

;; Define the cloner.

449

(declaim (inline ,cloner))

450

(defun ,cloner

451

(,name &key ,@(loop for slot in slots

452

for reader-name in reader-names

453

collect

454

`(,(bitfield-slot-name slot)

455

(,reader-name ,name))))

456

(declare (,name ,name))

457

(logior

458

,@(loop for slot in slots

459

collect

460

`(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))

461

,(bitfield-slot-start slot)))))

462

;; Define the constructor.

463

(declaim (inline ,constructor))

464

(defun ,constructor

465

(&key ,@(loop for slot in slots

466

collect

467

`(,(bitfield-slot-name slot)

468

,(bitfield-slot-initform slot))))

469

(logior

470

,@(loop for slot in slots

471

collect

472

`(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))

473

,(bitfield-slot-start slot)))))

474

',name)))

475

476

;;; From bit-smasher

477

(declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*))

478

(defvar *bit-map* #(#*0000

479

#*0001

480

#*0010

481

#*0011

482

#*0100

483

#*0101

484

#*0110

485

#*0111

486

#*1000

487

#*1001

488

#*1010

489

#*1011

490

#*1100

491

#*1101

492

#*1110

493

#*1111))

494

495

(deftype hexchar ()

496

`(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9

497

#\a #\b #\c #\d #\e #\f

498

#\A #\B #\C #\D #\E #\F))

499

500

(declaim (ftype (function (hexchar) (integer 0 16)) hexchar->int)

501

(inline hexchar-to-int))

502

(defun hexchar-to-int (char)

503

"Return the bit vector associated with a hex-value character CHAR from *bit-map*."

504

(declare (optimize (speed 2) (safety 0)))

505

(cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0)))

506

((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10)))

507

(t (- (char-code char) #.(- (char-code #\A) 10))

508

;; always return these results

509

#+nil (char<= #\A char #\F))))

510

511

;;; From Ironclad

512

(defun hex-string-to-octet-vector (string &aux (start 0) (end (length string)))

513

"Parses a substring of STRING delimited by START and END of

514

hexadecimal digits into a byte array."

515

(declare (type string string))

516

(let* ((length

517

(ash (- end start) -1)

518

#+nil (/ (- end start) 2))

519

(key (make-array length :element-type '(unsigned-byte 8))))

520

(declare (type (simple-array (unsigned-byte 8)) key))

521

(loop for i from 0

522

for j from start below end by 2

523

do (setf (aref key i)

524

(+ (* (hexchar-to-int (char string j)) 16)

525

(hexchar-to-int (char string (1+ j)))))

526

finally (return key))))

527

528

(defun octet-vector-to-hex-string (vector)

529

"Return a string containing the hexadecimal representation of the

530

subsequence of VECTOR between START and END. ELEMENT-TYPE controls

531

the element-type of the returned string."

532

(declare (type (vector (unsigned-byte 8)) vector))

533

(let* ((length (length vector))

534

(hexdigits #.(coerce "0123456789abcdef" 'simple-base-string)))

535

(loop with string = (make-string (* length 2) :element-type 'base-char)

536

for i from 0 below length

537

for j from 0 by 2

538

do (let ((byte (aref vector i)))

539

(declare (optimize (safety 0)))

540

(setf (aref string j)

541

(aref hexdigits (ldb (byte 4 4) byte))

542

(aref string (1+ j))

543

(aref hexdigits (ldb (byte 4 0) byte))))

544

finally (return string))))

545

546

(defun octets-to-integer (octet-vec &optional (bytes (length octet-vec)))

547

"Return the integer representation of OCTET-VEC by reading BYTES number of

548

bytes from the start."

549

(declare (type (simple-array (unsigned-byte 8)) octet-vec))

550

(do ((j 0 (1+ j))

551

(sum 0))

552

((>= j bytes) sum)

553

(setf sum (+ (aref octet-vec j) (ash sum 8)))))

554

555

(defun integer-to-octets (bignum &optional (n-bits (integer-length bignum)))

556

"Return an octet-vector representation of BIGNUM using N-BITS number of bits."

557

(let* ((n-bytes (ceiling n-bits 8))

558

(octet-vec (make-array n-bytes :element-type '(unsigned-byte 8))))

559

(declare (type (simple-array (unsigned-byte 8)) octet-vec))

560

(loop for i from (1- n-bytes) downto 0

561

for index from 0

562

do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum))

563

finally (return octet-vec))))

564

565

(defun octets-to-integer-le (octet-vec &optional (bytes (length octet-vec)))

566

"Return the integer representation of OCTET-VEC in little-endian by reading

567

BYTES number of bytes from the start."

568

(declare (type (simple-array (unsigned-byte 8)) octet-vec))

569

(loop for i from 0 below bytes

570

sum (ash (aref octet-vec i) (* 8 i))))

571

572

(defun integer-to-octets-le (bignum &optional (n-bits (integer-length bignum)))

573

"Return an octet-vector representation of BIGNUM in little-endian using N-BITS

574

number of bits."

575

(let* ((n-bytes (ceiling n-bits 8))

576

(octet-vec (make-array n-bytes :element-type '(unsigned-byte 8))))

577

(declare (type (simple-array (unsigned-byte 8)) octet-vec))

578

(loop for i from 0 below n-bytes

579

do (setf (aref octet-vec i) (ldb (byte 8 (* i 8)) bignum))

580

finally (return octet-vec))))

581

582

(defun read-little-endian (s &optional (bytes 4))

583

"Read a number in little-endian format from a byte (octet) stream S,

584

the number having BYTES octets (defaulting to 4)."

585

(loop for i from 0 below bytes

586

sum (ash (read-byte s) (* 8 i))))

587

588

(defun write-little-endian (i s &optional (bytes 4))

589

"Write a number to a byte stream S in little-endian having BYTES octets."

590

(write-sequence (integer-to-octets-le i bytes) s))

591

592

(defun make-octets (dimensions &rest args)

593

"Like MAKE-ARRAY but with a hard-coded element-type of (unsigned-byte 8)."

594

(apply 'make-array dimensions :element-type 'octet args))

595

596

(defun octets (&rest bytes)

597

"Return an octet-vector with initial contents BYTES."

598

(make-octets (length bytes) :initial-contents bytes))