Coverage report: /home/ellis/comp/core/lib/obj/cache.lisp

Kind	Covered	All	%
expression	2	895	0.2
branch	0	114	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; cache.lisp --- Cache Objects

2

3

;; Cache Object Protocol

4

5

;;; Commentary:

6

7

;; based on CACLE: https://github.com/jlahd/cacle

8

9

;; CACLE provides a similar object, CACHE which obtains a block of data from a

10

;; provider function, given the block's key. The key is a user-defined value

11

;; that is used in an EQL hash-table, which provides storage for the cache

12

;; itself.

13

14

;; CACLE supports a variety of replacement policies which we also support. The

15

;; only major interface change is that we use keywords to indicate the policy

16

;; instead of objects and the :LFUDA policy is inferred simply from fixnums.

17

18

#| Cache Replacement

19

- First In First Out (:fifo): Data that has been in the cache for the longest time is discarded

20

- Last In First Out (:lifo): Most recently added data is discarded

21

- Least Recently Used (:lru): Data that has gone unused for the longest time is discarded

22

- Most Recently Used (:mru): Most recently used data is discarded

23

- Random (:random): A randomly selected piece of data is discarded

24

- Least Frequently Used (:lfu): Data with the lowest number of fetches is discarded

25

- Least Frequently Used with Dynamic Aging (:lfuda): An aging variable is

26

introduced to LFU to prefer discarding data that has been used a lot in the

27

history but less often recently.

28

|#

29

30

;;; Code:

31

(in-package :obj/cache)

32

33

;;; Cache Table

34

(defun make-cache-table (&rest args)

35

"Make a value-weak hashtable. When value gets collected so does the key."

36

(apply 'make-hash-table :weakness :value args))

37

38

(defun get-cache (key cache)

39

"Get a value from a cache-table."

40

(let ((val (gethash key cache)))

41

(if val (values (sb-ext:weak-pointer-value val) t)

42

(values nil nil))))

43

44

(defsetf get-cache setf-cache)

45

46

(defun setf-cache (key cache value)

47

"Set a value in a cache-table."

48

(let ((w (sb-ext:make-weak-pointer value)))

49

(sb-ext:finalize value (make-finalizer key cache))

50

(setf (gethash key cache) w)

51

value))

52

53

(defun make-finalizer (key cache)

54

(declare (ignorable key cache))

55

(lambda () (remhash key cache)))

56

57

(defun remcache (key cache)

58

(remhash key cache))

59

60

(defun map-cache (fn cache)

61

(with-hash-table-iterator (nextfn cache)

62

(loop

63

(multiple-value-bind (valid? key value) (nextfn)

64

(when (not valid?)

65

(return-from map-cache))

66

(funcall fn key (sb-ext:weak-pointer-value value))))))

67

68

(defun dump-cache (cache)

69

(format t "Dumping cache: ~A~%" cache)

70

(map-cache #'(lambda (k v)

71

(format t ":k ~A :v ~A~%" k v))

72

cache))

73

74

;;; Entry

75

(defclass cache-entry ()

76

((key :accessor key :initarg :key)

77

(data :accessor data)

78

(pending :initarg :pending)

79

(rc :accessor entry-rc :initform 0)

80

(expiry :reader entry-expiry)))

81

82

(defclass indexed-cache-entry (cache-entry)

83

((index :accessor index)))

84

85

(defclass linked-cache-entry (cache-entry)

86

((next :reader next)

87

(prev :reader prev)))

88

89

(defmethod shared-initialize ((entry linked-cache-entry) slot-names &rest initargs)

90

(declare (ignore initargs))

91

(call-next-method)

92

(when (or (eq slot-names t)

93

(find 'next slot-names))

94

(setf (slot-value entry 'next) entry))

95

(when (or (eq slot-names t)

96

(find 'prev slot-names))

97

(setf (slot-value entry 'prev) entry)))

98

99

(defmethod unlink ((entry linked-cache-entry))

100

(let ((n (slot-value entry 'next))

101

(p (slot-value entry 'prev)))

102

(when (and (eq n entry)

103

(eq p entry))

104

(error "Attempt to unlink an already unlinked entry ~s" entry))

105

(setf (slot-value n 'prev) p

106

(slot-value p 'next) n

107

(slot-value entry 'next) entry

108

(slot-value entry 'prev) entry)

109

entry))

110

111

(defun ensure-unlinked (entry)

112

(with-slots (next prev)

113

entry

114

(unless (and (eq next entry)

115

(eq prev entry))

116

(error "Attempt to link an already linked entry ~s" entry))))

117

118

(defmethod link-before ((entry linked-cache-entry) (ref linked-cache-entry))

119

(ensure-unlinked entry)

120

(let ((n ref)

121

(p (slot-value ref 'prev)))

122

(setf (slot-value p 'next) entry

123

(slot-value n 'prev) entry

124

(slot-value entry 'next) n

125

(slot-value entry 'prev) p)

126

entry))

127

128

(defmethod link-after ((entry linked-cache-entry) (ref linked-cache-entry))

129

(ensure-unlinked entry)

130

(let ((n (slot-value ref 'next))

131

(p ref))

132

(setf (slot-value p 'next) entry

133

(slot-value n 'prev) entry

134

(slot-value entry 'next) n

135

(slot-value entry 'prev) p)

136

entry))

137

138

(defclass heap-cache-entry (indexed-cache-entry)

139

((weight :accessor entry-weight :initform 0 :initarg :weight)))

140

141

(defun heap-parent-idx (idx)

142

(floor (1- idx) 2))

143

144

(defun heap-left-idx (idx)

145

(1+ (* idx 2)))

146

147

(defun heap-right-idx (idx)

148

(* (1+ idx) 2))

149

150

(defun heap-parent (heap idx)

151

(and (> idx 0)

152

(aref heap (heap-parent-idx idx))))

153

154

(defun heap-left (heap idx)

155

(let ((left (heap-left-idx idx)))

156

(and (< left (length heap))

157

(aref heap left))))

158

159

(defun heap-right (heap idx)

160

(let ((right (heap-right-idx idx)))

161

(and (< right (length heap))

162

(aref heap right))))

163

164

(defun heap-swap (heap i1 i2)

165

(let ((e1 (aref heap i1))

166

(e2 (aref heap i2)))

167

(setf (index e1) i2

168

(index e2) i1

169

(aref heap i1) e2

170

(aref heap i2) e1)

171

(values e2 e1)))

172

173

(defun sink-down (heap idx &optional prefer-to-sink)

174

(let ((me (aref heap idx))

175

(left (heap-left heap idx))

176

(right (heap-right heap idx)))

177

(unless (and (or (null left)

178

(< (entry-weight me)

179

(entry-weight left))

180

(and (not prefer-to-sink)

181

(= (entry-weight me)

182

(entry-weight left))))

183

(or (null right)

184

(< (entry-weight me)

185

(entry-weight right))

186

(and (not prefer-to-sink)

187

(= (entry-weight me)

188

(entry-weight right)))))

189

;; heavier than (one of) children, do sink

190

(let ((lightest (if (and right

191

(< (entry-weight right)

192

(entry-weight left)))

193

(heap-right-idx idx)

194

(heap-left-idx idx))))

195

(heap-swap heap idx lightest)

196

(sink-down heap lightest prefer-to-sink)))))

197

198

(defun bubble-up (heap idx)

199

(let ((me (aref heap idx))

200

(parent (heap-parent heap idx)))

201

(unless (or (null parent)

202

(>= (entry-weight me)

203

(entry-weight parent)))

204

;; lighter than parent, do bubble

205

(let ((p (heap-parent-idx idx)))

206

(heap-swap heap idx p)

207

(bubble-up heap p)))))

208

209

;;; Policy

210

(deftype cache-policy () '(or keyword fixnum))

211

212

(defgeneric entry-added (policy queue entry)

213

(:method (policy (queue cons-queue) (entry cache-entry))

214

(change-class entry 'linked-cache-entry))

215

(:method (policy (queue cons-queue) (entry cache-entry))

216

(link-after entry (next queue)))

217

(:method :before (policy (queue vector-queue) (entry cache-entry))

218

(change-class entry 'indexed-cache-entry))

219

(:method (policy (queue vector-queue) (entry cache-entry))

220

(setf (index entry) (push-queue* entry queue)))

221

(:method ((policy (eql :lfu)) (queue vector-queue) (entry cache-entry))

222

(change-class entry 'heap-cache-entry)

223

(setf (entry-weight entry) 1

224

(index entry) (push-queue* entry queue))

225

(bubble-up (data queue) (index entry)))

226

(:method ((policy fixnum) queue (entry cache-entry))

227

(entry-added :lfu queue entry)

228

(incf (entry-weight entry) policy)

229

(sink-down (data queue) (index entry))))

230

231

(defgeneric access-entry (policy queue entry)

232

(:method (policy (queue cons-queue) (entry cache-entry)) t)

233

(:method (policy (queue vector-queue) (entry cache-entry)) t)

234

(:method ((policy (eql :lru)) queue (entry cache-entry))

235

(unlink entry)

236

(link-after entry (next queue))

237

t)

238

(:method ((policy (eql :mru)) queue (entry cache-entry))

239

(unlink entry)

240

(link-after entry (next queue))

241

t)

242

(:method ((policy (eql :lfu)) (queue vector-queue) (entry heap-cache-entry))

243

(incf (entry-weight entry))

244

(sink-down (data queue) (index entry) t)

245

t))

246

247

(defgeneric entry-removed (policy queue entry)

248

(:method (policy (queue cons-queue) (entry cache-entry))

249

(unlink entry))

250

(:method (policy (queue vector-queue) (entry cache-entry))

251

(let ((i (index entry)))

252

(setf (index entry) nil

253

(aref (data queue) i) nil)

254

(let ((w 0))

255

(loop for i below (queue-count queue)

256

for e = (aref (data queue) i)

257

when e

258

do (if (= w i)

259

(incf w)

260

(setf (index e) w

261

(aref (data queue) w) e

262

w (1+ w))))

263

(setf (fill-pointer (data queue)) w))))

264

(:method ((policy (eql :lfu)) (queue vector-queue) (entry heap-cache-entry))

265

(let ((i (index entry)))

266

(setf (index entry) nil)

267

(unless (= i (1- (queue-count* queue)))

268

(setf (aref (data queue) i) (pop-queue* queue)

269

(index (aref (data queue) i)) i)

270

(sink-down (data queue) i)))))

271

272

(defgeneric evict-entry (policy queue)

273

(:method ((policy (eql :fifo)) queue)

274

(let* ((next (next queue))

275

(last (last next)))

276

(unless (eq last next)

277

(unlink last)

278

last)))

279

(:method ((policy (eql :lifo)) queue)

280

(let* ((next (next queue))

281

(first (next next)))

282

(unless (eq first next)

283

(unlink first)

284

first)))

285

(:method ((policy (eql :random)) queue)

286

(unless (queue-full-p queue)

287

(let ((e (loop for i = (random (raw-queue-capacity (queue queue)))

288

for e = (aref (data queue) i)

289

while (null e)

290

finally (return e))))

291

(entry-removed policy queue e)

292

e)))

293

(:method ((policy (eql :lfu)) (queue vector-queue))

294

(unless (queue-empty-p* queue)

295

(let ((light (aref (data queue) 0))

296

(heavy (pop-queue* queue)))

297

(unless (queue-empty-p* queue)

298

(setf (aref (data queue) 0) heavy

299

(index heavy) 0)

300

(sink-down (data queue) 0 t))

301

light)))

302

(:method ((policy fixnum) (queue vector-queue))

303

(when-let ((target (evict-entry :lfu queue)))

304

;; CACLE updates the policy object here, we return the weight

305

;; (entry-weight target)

306

target)))

307

308

;;; Cache

309

(defclass cache ()

310

((policy :initarg :policy :accessor cache-policy)

311

(kernel :initarg :kernel :accessor kernel)

312

(cleanup :initarg :cleanup :accessor cache-cleanup)

313

(table :initarg :table :accessor table)

314

(queue :initform (make-queue) :initarg :queue :accessor queue)))

315

316

(defmethod initialize-instance ((cache cache) &key policy kernel (test 'eql) capacity element-type

317

&allow-other-keys)

318

(call-next-method)

319

(unless kernel (required-argument :kernel))

320

(setf (slot-value cache 'table) (make-hash-table :test test)

321

(slot-value cache 'queue) (make-queue :capacity capacity :element-type element-type))

322

(cond ((and policy (not (typep (queue cache) 'vector-queue)))

323

(error "Policy defined, but queue is possibly infinite"))

324

((null policy)

325

(unless (not (typep (queue cache) 'vector-queue))

326

(error "Queue size is defined, but policy missing")))

327

((typep policy '(or keyword fixnum null))

328

(setf (slot-value cache 'policy) policy))

329

(t

330

(error "Invalid policy ~s" policy))))

331

332

(defun make-cache (capacity provider &key (test 'eql) (policy :fifo) cleanup (element-type 'cache-entry))

333

"Create a new cache with the specified capacity, kernel function, and options."

334

(make-instance 'cache

335

:test test

336

:capacity capacity

337

:kernel provider

338

:policy policy

339

:cleanup cleanup

340

:element-type element-type))

341

342

(defvar *cleanup-list*)

343

(defmacro with-collected-cleanups ((cache) &body body)

344

(with-gensyms (i fn)

345

`(let* ((,fn (with-queue-lock (queue ,cache)

346

(slot-value ,cache 'cleanup)))

347

(*cleanup-list* (null ,fn)))

348

(unwind-protect

349

(progn ,@body)

350

(when ,fn

351

(dolist (,i *cleanup-list*)

352

(funcall ,fn ,i)))))))

353

354

(defun prepare-cleanup (entry hash)

355

(cond ((eq *cleanup-list* t)

356

(remhash (key entry) hash))

357

((zerop (entry-rc entry))

358

(remhash (key entry) hash)

359

(push (slot-value entry 'data) *cleanup-list*))

360

((< (entry-rc entry) 0)

361

(error "Internal error: double prepare-cleanup for ~s" entry))

362

(t

363

(setf (entry-rc entry) (- (entry-rc entry))))))

364

365

;; REVIEW 2025-07-04:

366

(defun ensure-cache-size (cache)

367

(with-slots (policy table) cache

368

(loop while (not (queue-full-p* (queue cache)))

369

for old = (evict-entry policy (queue cache))

370

while old

371

do (progn

372

;; (decf size (slot-value old 'size))

373

(prepare-cleanup old table)))))

374

375

(defun cache-count (cache)

376

"Returns the current count of items in the cache."

377

(with-queue-lock (queue cache)

378

(hash-table-count (slot-value cache 'table))))

379

380

(defmethod get-val ((cache cache) key &key shallow force)

381

"Return the value associated with KEY in CACHE.

382

383

If the item is not currently in the cache, or has expired, it is fetched from

384

the provider and stored in the cache.

385

386

If FORCE is specified, a new value is fetched from the provider even if

387

it already exists in the cache.

388

389

If a cleanup function is defined for the cache, remember to call cache-release

390

with the second value returned by GET-VAL."

391

(with-slots (table policy kernel) cache

392

(let ((lock (lock (queue cache))))

393

(with-collected-cleanups (cache)

394

(multiple-value-bind (hit data entry)

395

(with-mutex (lock)

396

(when force

397

(let ((entry (gethash key table)))

398

(when entry

399

(prepare-cleanup entry table)

400

;; (decf (cache-size cache) (slot-value entry 'size))

401

(when policy

402

(entry-removed policy (queue cache) entry)))))

403

(flet ((miss ()

404

                        (let ((entry (make-instance 'cache-entry :key key :pending (make-waitqueue))))

405

(setf (gethash key table) entry)

406

(values nil entry))))

407

(loop

408

(let ((entry (gethash key table)))

409

(cond ((and (null entry)

410

shallow)

411

;; cache miss, and no waiting

412

(return (values t nil nil)))

413

414

((null entry)

415

;; cache miss - initialize fetch from source

416

(return (miss)))

417

418

((and (slot-boundp entry 'pending)

419

shallow)

420

;; cache hit - but data not yet ready, and no waiting

421

(return (values t nil nil)))

422

423

((slot-boundp entry 'pending)

424

;; cache hit - but data not yet ready

425

(let ((pending (slot-value entry 'pending)))

426

(condition-wait pending lock)

427

                              ;; note: the pending slot is no longer bound after the wait

428

(condition-notify pending)

429

;; data now available

430

(when (eq (gethash key table) entry)

431

;; ... and not immediately cleaned up

432

(if (cache-cleanup cache)

433

(progn

434

(if (>= (entry-rc entry) 0)

435

(incf (entry-rc entry))

436

(decf (entry-rc entry)))

437

                                      (return (values t (slot-value entry 'data) entry)))

438

                                    (return (values t (slot-value entry 'data)))))))

439

440

((and entry policy

441

(or (and (slot-boundp entry 'expiry)

442

(<= (slot-value entry 'expiry)

443

(get-universal-time)))

444

(and (>= (entry-rc entry) 0)

445

                                          (not (access-entry policy (queue cache) entry)))))

446

;; cached data has expired or been invalidated

447

(remhash key table)

448

(prepare-cleanup entry table)

449

(decf (slot-value cache 'size) (slot-value entry 'size))

450

(entry-removed policy (queue cache) entry)

451

(if shallow

452

(return (values t nil nil)) ; no waiting

453

(return (miss))))

454

455

((cache-cleanup cache)

456

(if (>= (entry-rc entry) 0)

457

(incf (entry-rc entry))

458

(decf (entry-rc entry)))

459

(return (values t (slot-value entry 'data) entry)))

460

461

(t

462

(return (values t (slot-value entry 'data) nil))))))))

463

(if hit

464

(values data entry)

465

(multiple-value-bind (content size)

466

(handler-case (funcall kernel key)

467

(error (e)

468

(with-mutex (lock)

469

(remhash key table)

470

(condition-notify (slot-value data 'pending))

471

(slot-makunbound data 'pending))

472

(error e)))

473

(with-collected-cleanups (cache)

474

(unless (typep size 'real)

475

(setf size (if content 1 0))

476

                     (warn "Cache provider did not return a proper size for the data - assuming size of ~d" size))

477

(with-mutex (lock)

478

(setf (slot-value data 'data) content)

479

;; (slot-value data 'size) size)

480

;; (with-slots (lifetime) cache

481

;; (when lifetime

482

;; (setf (slot-value data 'expiry)

483

;; (+ (get-universal-time) lifetime))))

484

(condition-notify (slot-value data 'pending))

485

(slot-makunbound data 'pending)

486

;; (incf (slot-value cache 'size) size)

487

(when policy

488

(ensure-cache-size cache)

489

(entry-added policy (queue cache) data))

490

(if (cache-cleanup cache)

491

(progn

492

(incf (entry-rc data))

493

(values content data))

494

(values content nil)))))))))))

495

496

(defmethod cache-release ((cache cache) entry)

497

"Releases a reference for an item fetched earlier.

498

499

An item fetched from the cache with cache-fetch will not be cleaned up before

500

it is released."

501

(when entry

502

(with-slots (table cleanup) cache

503

(let ((to-clean

504

(with-queue-lock (queue cache)

505

(let ((busy (entry-rc entry)))

506

(cond ((zerop busy)

507

                          (error "Double release for item with the key ~a" (key entry)))

508

((> busy 0)

509

(decf (entry-rc entry))

510

nil)

511

(t

512

(when (zerop (incf (entry-rc entry)))

513

(when (eq (gethash (key entry) table) entry)

514

(remhash (key entry) table))

515

(slot-value entry 'data))))))))

516

(when (and cleanup to-clean)

517

(funcall cleanup to-clean)))))

518

nil)

519

520

(defmacro with-cache (var (cache key &key shallow) &body body)

521

"Combines a cache-fetch and cache-release in a form."

522

(with-gensyms (c-var tag)

523

`(let ((,c-var ,cache))

524

(multiple-value-bind (,var ,tag)

525

(cache-fetch ,c-var ,key ,@(and shallow '(:shallow t)))

526

(unwind-protect

527

(progn ,@body)

528

(cache-release ,c-var ,tag))))))

529

530

(defmethod cache-remove ((cache cache) key)

531

"Remove the item with the specified key from the cache."

532

(with-slots (table policy) cache

533

(with-collected-cleanups (cache)

534

(with-queue-lock (queue cache)

535

(let ((entry (gethash key table)))

536

(when entry

537

(prepare-cleanup entry table)

538

;; (decf size (slot-value entry 'size))

539

(when policy

540

(entry-removed policy (queue cache) entry))

541

t))))))

542

543

(defmethod cache-flush ((cache cache))

544

"Flush the cache, removing all items currently stored in it. If a cleanup

545

function is defined for the cache, it is called for every item."

546

(with-slots (table policy cleanup) cache

547

(with-collected-cleanups (cache)

548

(with-queue-lock (queue cache)

549

(maphash #'(lambda (k v)

550

(declare (ignore k))

551

(prepare-cleanup v table)

552

(entry-removed policy (queue cache) v))

553

table)

554

;; (setf size 0)

555

))

556

nil))