Coverage report: /home/smo/lisp/release/cl-swap-file_0.2/swap-file.lisp

Kind	Covered	All	%
expression	626	713	87.8
branch	42	54	77.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :swap-file)

2

3

(declaim (optimize (space 0) (speed 0) (debug 3) (safety 2))) ; development mode

4

5

(defstruct swap-file

6

(version 1 :type (unsigned-byte 32))

7

(block-size 4096 :type (unsigned-byte 32))

8

(next-new-offset 0 :type (unsigned-byte 32))

9

   (available-list    0 :type (unsigned-byte 32)) ; offset to first available block or 0 if none (= need to create one)

10

   (block-cache     nil :type list)               ; list of weak pointers pointing to a disk blocks.

11

   (open-blocks     nil :type list)               ; list of currently open disk blocks. This is cleared after flush.

12

(journal nil :type (or wal:wal null))

13

(stream nil :type stream))

14

15

(defstruct disk-block

16

(offset 0 :type (unsigned-byte 32)) ; file position

17

(max-data 0 :type (unsigned-byte 32)) ; maximum length of data to fit in this block

18

(deleted-p nil :type t) ; 1 byte on disk, t = 0, nil = 1

19

(next 0 :type (unsigned-byte 32)) ; 4 bytes

20

(data-size 0 :type (unsigned-byte 32)) ; 4 bytes

21

(data nil :type (or array null)))

22

23

(defun available-p (swap-file)

24

"Returns t if there is available (deleted) blocks on swap-file, nil otherwise."

25

(/= (swap-file-available-list swap-file) 0))

26

27

(defun max-data-size (block-size)

28

"Returns maximum size of payload data. This size block-size reduced by the size of block header."

29

(- block-size 1 4 4)) ;; deleted-p = 1 byte, next = 4 bytes, data-size = 4 bytes

30

31

(defun make-empty-data (swap-file)

32

   "Returns an empty array of bytes. Array's initial size is max-data-size but the array is adjustable."

33

   (make-array (max-data-size (swap-file-block-size swap-file)) :adjustable t :fill-pointer 0 :element-type 'unsigned-byte :initial-element 0))

34

35

(defun make-data-array (swap-file initial-contents)

36

"Returns an array of bytes with given initial contents."

37

   (map-into (make-array (max (length initial-contents) (max-data-size (swap-file-block-size swap-file))) :adjustable t :fill-pointer t :element-type 'unsigned-byte :initial-element 0) #'identity initial-contents))

38

39

40

(defun wal-entry-writer (entry stream)

41

"Writes a journal entry to a stream. The function is writer for write-ahead log."

42

;; write master offset

43

(little-endian:write-uint32 (car entry) stream)

44

;; write sequence size

45

(little-endian:write-uint32 (array-dimension (cdr entry) 0) stream)

46

;; write sequence

47

(write-sequence (cdr entry) stream))

48

49

(defun wal-entry-reader (stream)

50

"Reads a journal entry from stream. The function is reader for write-ahead log."

51

;; read master offset

52

(cons (little-endian:read-uint32 stream)

53

(read-sequence (make-array (little-endian:read-uint32 stream)

54

:element-type 'unsigned-byte)

55

stream)))

56

57

(defun make-master-writer (swap-file)

58

"Returns master writer function. The master writer is called by

59

write-ahead log when an entry is committed to swap-file's stream.

60

Master writer locates entry's file position and writes entry's

61

contents to that position."

62

(let ((swap-file swap-file))

63

(lambda (entry)

64

(file-position (swap-file-stream swap-file) (car entry))

65

(write-sequence (cdr entry) (swap-file-stream swap-file)))))

66

;; (finish-output (swap-file-stream swap-file)))))

67

;; (write-disk-block disk-block swap-file))))

68

69

(defun write-sequence-to-disk (data swap-file)

70

"Write sequence to disk. Sequence is written to a write ahead log."

71

(wal:write (swap-file-journal swap-file) (cons (file-position (swap-file-stream swap-file))

72

data)))

73

;; (write-sequence data (swap-file-stream swap-file)))

74

75

(defun write-uint32-to-disk (value swap-file)

76

"Write 32-bit unsigned byte to disk. Value is written to a write ahead log."

77

(write-sequence-to-disk

78

(binary-file:with-output-to-binary-array (out)

79

(little-endian:write-uint32 value out))

80

swap-file))

81

82

(defun write-uint8-to-disk (value swap-file)

83

"Write 8-bit unsigned byte to disk. Value is written to a write ahead log."

84

(write-sequence-to-disk

85

(little-endian:write-uint8 value (swap-file-stream swap-file))

86

swap-file))

87

88

(defun write-swap-file-header (swap-file)

89

"Write swap-file's header to a swap-file's stream."

90

(write-sequence

91

(binary-file:with-output-to-binary-array (s)

92

(little-endian:write-uint8 (char-code #\S) s)

93

(little-endian:write-uint8 (char-code #\W) s)

94

(little-endian:write-uint8 (char-code #\A) s)

95

(little-endian:write-uint8 (char-code #\P) s)

96

(little-endian:write-uint32 (swap-file-version swap-file) s)

97

(little-endian:write-uint32 (swap-file-block-size swap-file) s)

98

(little-endian:write-uint32 (swap-file-next-new-offset swap-file) s)

99

(little-endian:write-uint32 (swap-file-available-list swap-file) s)

100

;; pad 0's till end of the first block.

101

      (write-sequence (make-array (- (swap-file-block-size swap-file) (swap-file-header-size)) :initial-element 0 :element-type 'unsigned-byte) s))

102

(swap-file-stream swap-file))

103

(finish-output (swap-file-stream swap-file))

104

swap-file)

105

106

(defun read-swap-file-next-new-offset (swap-file)

107

"Reads and returns offset of the next new disk block."

108

(file-position (swap-file-stream swap-file) 12)

109

(little-endian:read-uint32 (swap-file-stream swap-file)))

110

111

(defun write-swap-file-next-new-offset (swap-file)

112

"Writes offset of the next new disk block to swap-file's stream."

113

(file-position (swap-file-stream swap-file) 12)

114

(write-uint32-to-disk (swap-file-next-new-offset swap-file) swap-file))

115

116

(defun read-swap-file-first-available (swap-file)

117

"Reads and returns offset of first available (deleted) disk block. If

118

there is no available blocks, returns 0."

119

(file-position (swap-file-stream swap-file) 16)

120

(little-endian:read-uint32 (swap-file-stream swap-file)))

121

122

(defun write-swap-file-first-available (offset swap-file)

123

"Writes offset of first available (deleted) disk block to the

124

swap-file's stream."

125

(file-position (swap-file-stream swap-file) 16)

126

(write-uint32-to-disk offset swap-file))

127

128

(defun read-swap-file-header (swap-file)

129

"Reads swap-file header and updates swap-file structure. Returns updated swap-file structure."

130

(unless (and (= (little-endian:read-uint8 (swap-file-stream swap-file)) (char-code #\S))

131

(= (little-endian:read-uint8 (swap-file-stream swap-file)) (char-code #\W))

132

(= (little-endian:read-uint8 (swap-file-stream swap-file)) (char-code #\A))

133

(= (little-endian:read-uint8 (swap-file-stream swap-file)) (char-code #\P)))

134

(error "Not a swap file."))

135

(unless (= (swap-file-version swap-file) (little-endian:read-uint32 (swap-file-stream swap-file)))

136

(error "Swap file version does not match."))

137

(setf (swap-file-block-size swap-file) (little-endian:read-uint32 (swap-file-stream swap-file))

138

(swap-file-next-new-offset swap-file) (little-endian:read-uint32 (swap-file-stream swap-file))

139

(swap-file-available-list swap-file) (little-endian:read-uint32 (swap-file-stream swap-file)))

140

swap-file)

141

142

(defun swap-file-header-size ()

143

"Returns size of swap-file header."

144

(+ 4 ; "SWAP"

145

4 ; version

146

4 ; block size

147

4 ; next new offset

148

4 ; next available offset

149

))

150

151

(defun set-block-data (disk-block data)

152

"Sets disk-blocks data. Returns updated disk-block."

153

(setf (disk-block-data disk-block) data)

154

(if (array-has-fill-pointer-p data)

155

(setf (disk-block-data-size disk-block) (fill-pointer data))

156

(setf (disk-block-data-size disk-block) (length data)))

157

disk-block)

158

159

(defun allocate-new-block (swap-file &optional (data (make-empty-data swap-file)))

160

"Returns new empty block from swap file. Disk block is allocated

161

from end of the file if none is available. Empty block data array

162

contains only zeros and fill pointer is set to 0. If data is given,

163

the given data is to allocated block but not flushed to the disk. In

164

that case caller should call write-disk-block after allocation."

165

(declare (optimize (speed 0) (space 0) (debug 3)))

166

(let ((new-block (make-disk-block :offset (swap-file-next-new-offset swap-file)

167

                                     ;;(file-position (swap-file-stream swap-file))

168

                                     :max-data (max-data-size (swap-file-block-size swap-file))

169

:deleted-p nil

170

:next 0

171

:data-size (fill-pointer data)

172

:data data)))

173

174

;; write all 0's to new block.

175

(file-position (swap-file-stream swap-file) (swap-file-next-new-offset swap-file))

176

     (write-sequence-to-disk (make-array (swap-file-block-size swap-file) :element-type 'unsigned-byte :initial-element 0)

177

swap-file)

178

179

;; increment next new offset

180

(incf (swap-file-next-new-offset swap-file) (swap-file-block-size swap-file))

181

(write-swap-file-next-new-offset swap-file)

182

183

new-block))

184

185

(defun append-to-available (disk-block swap-file)

186

"Pushes given disk-block to swap-file's available list. Available

187

list is updated at disk."

188

;; link block to available list.

189

(setf (disk-block-next disk-block) (swap-file-available-list swap-file))

190

(setf (swap-file-available-list swap-file) (disk-block-offset disk-block))

191

(write-swap-file-first-available (disk-block-offset disk-block) swap-file)

192

193

;; seek to disk block

194

(file-position (swap-file-stream swap-file) (disk-block-offset disk-block))

195

196

;; mark block as deleted

197

(setf (disk-block-deleted-p disk-block) t)

198

(write-uint8-to-disk 1 swap-file)

199

200

;; write next available to disk

201

(write-uint32-to-disk (disk-block-next disk-block) swap-file)

202

disk-block)

203

204

(defun get-first-available (swap-file)

205

"Returns first available (deleted) disk block or nil if there is no available disk blocks."

206

(when (available-p swap-file)

207

(let ((disk-block (read-disk-block swap-file (swap-file-available-list swap-file))))

208

(setf (swap-file-available-list swap-file) (disk-block-next disk-block))

209

(write-swap-file-first-available (disk-block-next disk-block) swap-file)

210

211

;; seek to disk block

212

(file-position (swap-file-stream swap-file) (disk-block-offset disk-block))

213

214

;; mark block as undeleted

215

(setf (disk-block-deleted-p disk-block) nil)

216

(write-uint8-to-disk 0 swap-file)

217

218

;; write next available to disk

219

(setf (disk-block-next disk-block) 0)

220

(write-uint32-to-disk 0 swap-file)

221

disk-block)))

222

223

(defun read-disk-block-array (stream block-size)

224

"Reads and returns (single) disk block's data as an array of bytes."

225

(let ((array (make-array block-size :element-type 'unsigned-byte :initial-element 0))

226

(result 0))

227

(setq result (read-sequence array stream))

228

(assert (= block-size result))

229

array))

230

231

(defun read-disk-block (swap-file offset)

232

"Reads and returns disk block from swap file. If disk node is marked as deleted, the

233

data is not read."

234

(file-position (swap-file-stream swap-file) offset)

235

(binary-file:with-input-from-binary-array (s (read-disk-block-array (swap-file-stream swap-file)

236

                                                                       (swap-file-block-size swap-file)))

237

(let ((disk-block (make-disk-block :offset offset

238

                                        :max-data (max-data-size (swap-file-block-size swap-file))

239

:deleted-p (= (read-byte s) 1)

240

:next (little-endian:read-uint32 s)

241

                                        :data-size (little-endian:read-uint32 s)

242

:data (make-empty-data swap-file))))

243

(unless (disk-block-deleted-p disk-block)

244

(setf (fill-pointer (disk-block-data disk-block)) (disk-block-data-size disk-block))

245

(read-sequence (disk-block-data disk-block) s :start 0))

246

disk-block)))

247

248

(defun read-connected-blocks (swap-file offset)

249

   "Returns a list of connected disk blocks read from swap-file starting from disk block at given offset."

250

(let ((disk-block (open-block swap-file offset)))

251

(if (= (disk-block-next disk-block) 0)

252

(list disk-block)

253

(cons disk-block (read-connected-blocks swap-file (disk-block-next disk-block))))))

254

255

(defun merge-data (data-chunks)

256

"Returns a new adjustable array with fill pointer. Arrays size is

257

equal to sum of given data chunks and contents are merged from data

258

chunks. Data chunks are arrays themselves."

259

(when data-chunks

260

(let ((new-data (make-array (reduce #'+ data-chunks :key #'data-size :initial-value 0)

261

                                 :initial-element 0 :element-type 'unsigned-byte :adjustable t :fill-pointer t))

262

(start 0))

263

(mapcar #'(lambda (data-chunk)

264

(setf (subseq new-data start (+ start (data-size data-chunk))) data-chunk)

265

(incf start (data-size data-chunk)))

266

data-chunks)

267

new-data)))

268

269

(defun data-size-below-max (disk-block)

270

"Returns disk blocks data size or disk block maximum data size if

271

current disk block's data size is over than maximum."

272

(min (disk-block-data-size disk-block)

273

(disk-block-max-data disk-block)))

274

275

(defgeneric data-size (obj)

276

(:method ((obj disk-block))

277

(disk-block-data-size obj))

278

(:method ((obj array))

279

(if (array-has-fill-pointer-p obj)

280

(fill-pointer obj)

281

(length obj))))

282

283

(defun next-p (disk-block)

284

"Returns t if disk bock has next block set, nil otherwise."

285

(/= (disk-block-next disk-block) 0))

286

287

(defun split-data (data max-size)

288

"Returns data splitted to a list of byte arrays with each having size below max-size."

289

(when data

290

(if (= (length data) 0)

291

'(#())

292

(do ((pos 0 (+ pos max-size))

293

(chunks nil))

294

((>= pos (length data)) (reverse chunks))

295

           (push (make-array (min (- (length data) pos) max-size) :displaced-to data :displaced-index-offset pos) chunks)))))

296

297

(defun offset (disk-block)

298

"Returns disk block's offset or 0 if disk block is nil."

299

(if disk-block

300

(disk-block-offset disk-block)

301

0))

302

303

(defun write-connected-blocks (data-chunks swap-file offset)

304

"Writes data splitted to data-chunks to the swap-file starting from

305

disk block at given offset. The old disk block contents are

306

overwritten. If the data is shorter than old data the exceeding disk

307

blocks are deleted. If the data is longer than old data new disk

308

blocks are allocated as needed."

309

(cond

310

((and (null data-chunks) (= offset 0))

311

nil)

312

;; unlink old connected blocks if there is no more data left.

313

((and (null data-chunks) (> offset 0))

314

(unlink-block swap-file offset)

315

nil)

316

;; allocate new block.

317

((and data-chunks (= offset 0))

318

        (write-disk-block (create-block swap-file :next (offset (write-connected-blocks (rest data-chunks) swap-file 0)) :data (first data-chunks)) swap-file))

319

;; write over old connected block.

320

(t ; (and data-chunks (> offset 0))

321

(let ((disk-block (open-block swap-file offset)))

322

        (setf (disk-block-next disk-block) (offset (write-connected-blocks (rest data-chunks) swap-file (disk-block-next disk-block))))

323

        (write-disk-block (set-block-data (open-block swap-file offset) (first data-chunks)) swap-file)))))

324

325

;; (defun delete-extending (disk-block swap-file)

326

;; "Unlinks extending blocks from given disk block, if such exist."

327

;; (when (next-p disk-block)

328

;; (unlink-block swap-file (open-block swap-file (disk-block-next disk-block)))

329

;; (setf (disk-block-next disk-block) 0)))

330

331

(defun write-disk-block (disk-block swap-file)

332

"Write disk block to swap file. The disk block must be allocated

333

before it can be written. If the data array contents exceed block

334

size new blocks are allocated until all data can fit and also

335

exceeding data is written to the disk."

336

337

;; if sequence is over max data, write extending data to existing or new extending block.

338

;; this called first because we want to get next block's offset before writing

339

;; current block on disk.

340

;; (if (> (fill-pointer (disk-block-data disk-block)) (disk-block-max-data disk-block))

341

;; (write-extending disk-block swap-file)

342

;; (delete-extending disk-block swap-file))

343

344

;; locate disk-block on swap-file

345

(file-position (swap-file-stream swap-file) (disk-block-offset disk-block))

346

347

;; write disk block to disk.

348

(write-sequence-to-disk

349

;; construct full disk block array using in memory stream.

350

(binary-file:with-output-to-binary-array (out)

351

(let ((allowed-size (data-size-below-max disk-block)))

352

;; write deleted-p

353

(write-byte (if (disk-block-deleted-p disk-block) 1 0) out)

354

;; write next block offset

355

(little-endian:write-uint32 (disk-block-next disk-block) out)

356

;; write data-size

357

(little-endian:write-uint32 allowed-size out)

358

;; write data

359

(write-sequence (disk-block-data disk-block) out :end allowed-size)))

360

swap-file)

361

disk-block)

362

363

;;;

364

;;; exported functions

365

;;;

366

367

(defun flush (swap-file)

368

"Forces all written changes to be written on to swap-file's file."

369

(if (swap-file-journal swap-file)

370

(wal:commit (swap-file-journal swap-file)))

371

(finish-output (swap-file-stream swap-file))

372

(setf (swap-file-open-blocks swap-file) nil)

373

swap-file)

374

375

(defun rollback (swap-file)

376

"Discard all changes to a swap-file."

377

(wal:rollback (swap-file-journal swap-file))

378

swap-file)

379

380

(defun create-journal (swap-file)

381

"Create journal for a swap-file."

382

   (setf (swap-file-journal swap-file) (wal:open (swap-file-stream swap-file) (make-master-writer swap-file) :if-exists :error :if-does-not-exist :create :entry-writer #'wal-entry-writer :entry-reader #'wal-entry-reader))

383

swap-file)

384

385

(defun open-journal (swap-file)

386

"Open existing journal for a swap-file."

387

   (setf (swap-file-journal swap-file) (wal:open (swap-file-stream swap-file) (make-master-writer swap-file) :if-exists :overwrite :if-does-not-exist :error :entry-writer #'wal-entry-writer :entry-reader #'wal-entry-reader))

388

(wal:recover (swap-file-journal swap-file))

389

swap-file)

390

391

(defun create (filespec &key (if-exists :error) (block-size 4096))

392

"Creates and returns new swap-file. Swap-file is created to given filespec."

393

(assert (>= block-size 20))

394

(write-swap-file-header

395

    (create-journal (make-swap-file :version 1 :block-size block-size :next-new-offset block-size :stream (binary-file:open-binary-stream filespec :if-exists if-exists :if-does-not-exist :create)))))

396

397

(defun open (filespec &key (if-exists :overwrite) (if-does-not-exist :error))

398

"Opens and returns existing swap-file."

399

(open-journal

400

    (read-swap-file-header (make-swap-file :version 1 :stream (binary-file:open-binary-stream filespec :if-exists if-exists :if-does-not-exist if-does-not-exist)))))

401

402

(defun close (swap-file)

403

"Closes swap-file."

404

(flush swap-file)

405

(cl:close (swap-file-stream swap-file)))

406

407

(defun push-to-cache (swap-file disk-block)

408

"Push disk block to swap-file disk block cache."

409

(push (sb-ext:make-weak-pointer disk-block) (swap-file-block-cache swap-file))

410

disk-block)

411

412

(defun get-from-cache (swap-file offset)

413

"Returns disk block from cache, or nil if disk block with given

414

offset does not exist."

415

(do* ((pos (swap-file-block-cache swap-file) (cdr pos))

416

(db nil))

417

((null pos) db)

418

(let ((v (sb-ext:weak-pointer-value (car pos))))

419

(when (and v (= (disk-block-offset v) offset))

420

(setq db v)))))

421

422

(defun create-block (swap-file &key (next 0) (data (make-empty-data swap-file)))

423

"Allocates and returns empty disk block from swap-file."

424

(let ((disk-block

425

(if (available-p swap-file)

426

(push-to-cache swap-file (get-first-available swap-file))

427

(push-to-cache swap-file (allocate-new-block swap-file)))))

428

(setf (disk-block-next disk-block) next)

429

(push disk-block (swap-file-open-blocks swap-file))

430

(set-block-data disk-block data)))

431

432

(defun open-block (swap-file offset)

433

"Opens and returns existing disk block from swap-file."

434

(let ((disk-block (get-from-cache swap-file offset)))

435

(unless disk-block

436

(setq disk-block (push-to-cache swap-file (read-disk-block swap-file offset))))

437

(push disk-block (swap-file-open-blocks swap-file))

438

disk-block))

439

440

(defun read-data (swap-file offset)

441

"Returns an adjustable array with fill pointer. Function read-data

442

reads connected disk blocks from swap-file starting from given

443

offset. If disk block extends to next block, the data of consequtive

444

blocks are automatically appended to the data array of the read

445

block. In other words, returned data array may contain data from

446

multiple disk blocks."

447

(merge-data (mapcar #'disk-block-data (read-connected-blocks swap-file offset))))

448

449

(defun write-data (data swap-file offset)

450

"Write data to a swap-file and to a given offset."

451

(write-connected-blocks (split-data data (max-data-size (swap-file-block-size swap-file)))

452

swap-file offset))

453

454

455

(defun close-block (swap-file disk-block)

456

"Closes disk block."

457

(write-disk-block disk-block swap-file))

458

;; (wal:write (swap-file-journal swap-file) disk-block))

459

460

(defun ensure-disk-block (disk-block-spec swap-file)

461

"Returns or opens and returns a disk block."

462

(etypecase disk-block-spec

463

(disk-block disk-block-spec)

464

(integer (open-block swap-file disk-block-spec))))

465

466

 (defun unlink-block (swap-file disk-block-spec &aux (disk-block (ensure-disk-block disk-block-spec swap-file)))

467

"Unlinks disk block. Disk block is pushed into available disk blocks list."

468

(let ((next (disk-block-next disk-block)))

469

;; link block to available list

470

(append-to-available disk-block swap-file)

471

472

;; any extending blocks are also deleted

473

(if (> next 0)

474

(unlink-block swap-file (open-block swap-file next))

475

swap-file)))

476

477

(defun set-file-position-after-header (swap-file &optional (offset 0))

478

"Sets swap file's file position after swap file header. If offset is

479

given, the offset is added to file position. The file position after

480

header is reserved for application meta data. Available meta data size

481

is block size reduced by header size."

482

(file-position (swap-file-stream swap-file) (+ (swap-file-header-size) offset)))