source: branches/portable/recovery.lisp@ 31

Last change on this file since 31 was 18, checked in by wws, 10 years ago

CCL no longer has 8-bit strings.
  • Property svn:eol-style set to native
File size: 48.3 KB
Line 
1;;;-*- Mode: Lisp; Package: WOOD -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; recovery.lisp
6;; Support logging/recovery for WOOD.
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17
18;;
19;; To do:
20;;
21;; Remember most recently consed object so that undo
22;; bytes are unnecessary for subsequent stores into that object.
23
24(in-package :wood)
25
26;;;;;;;;;;;;;;;;;;;;;;;;;;
27;;
28;; Modification History
29;;
30;; -------------- 0.96
31;; -------------- 0.95
32;; -------------- 0.94
33;; 03/21/96 bill (make-string ... :element-type 'base-character)
34;; -------------- 0.93
35;; -------------- 0.9
36;; -------------- 0.8
37;; -------------- 0.6
38;; -------------- 0.5
39;; 05/27/92 bill New file
40;;
41
42#|
43Format of a log file:
44=========
45<Entry 0> ; first log entry
46...
47<Entry n> ; last log entry
48=========
49
50Format of a log entry:
51=========
52<Type> ; one byte. The type of entry
53<Data> ; entry type specific
54=========
55
56
57Format of data types written in log:
58
59<byte> ; 8 bits of data
60<word> ; 2 <byte>s
61<long> ; 4 <byte>s
62<length> ; 1 or more bytes. Each contains 7 bits of data.
63 ; If the MSB of a byte is set, there are more bytes
64<string> ; <length><data> - <data> is <length> bytes
65
66
67Entry descriptions:
68
69Header. The first entry in a log file:
70=========
71$log-header-type ; <byte>
72$log-version ; <byte>
73<EOF> ; <long> - End of file address
74<checkpoint> ; LSN of last checkpoint record
75<log for> ; <string> - Name of file that this
76 ; one is logging. Assumed to be in
77 ; the same directory as the log file.
78=========
79
80Begin transaction:
81=========
82$begin-transaction-type ; <byte>
83<parent LSN> ; <long> - LSN of parent transaction or 0
84=========
85
86Continue transaction.
87A Continue transaction record is written when a different
88transaction needs to write log records.
89=========
90$continue-transaction-type ; <byte>
91<LSN> ; <long>
92=========
93
94Abort transaction:
95=========
96$abort-transaction-type ; <byte>
97<LSN> ; <long>
98=========
99
100Commit transaction:
101=========
102$commit-transaction-type ; <byte>
103<LSN> ; <long>
104=========
105
106Checkpoint:
107=========
108$checkpoint-type ; <byte>
109<open transaction count> ; <length>
110<lsn 0> ; <long>
111...
112<lsn n> ; <long>
113=========
114
115There are 2 basic kinds of data entries: with and without undo.
116Eventually, we may want to work at encoding the address as a
117byte or word, offset from the past address written to the log.
118This poses problems for undo, however, as undo parses the log
119backwards.
120
121Write data without undo:
122=========
123<type> ; <byte>
124<address> ; <long>
125<size> ; <length> (optional) size of data
126<data>
127=========
128
129Write data with undo:
130=========
131<type> ; <byte>
132<undo-link> ; <length> - negative offset to last undo
133<address> ; <long>
134<size> ; <length> (optional) size of data
135<old data>
136<new data>
137=========
138
139Write byte:
140=========
141$write-byte ; <byte>
142<address> ; <long>
143<data> ; <byte>
144=========
145
146Write byte with undo:
147=========
148$write-byte-with-undo ; <byte>
149<undo-link) ; <length>
150<address> ; <long>
151<old data> ; <byte>
152<new data> ; <byte>
153=========
154
155Write word:
156=========
157$write-word ; <byte>
158<address> ; <long>
159<data> ; <word>
160=========
161
162Write word with undo:
163=========
164$write-word-with-undo ; <byte>
165<undo-link) ; <length>
166<address> ; <long>
167<old data> ; <word>
168<new data> ; <word>
169=========
170
171Write long:
172=========
173$write-long ; <byte>
174<address> ; <long>
175<data> ; <long>
176=========
177
178Write long with undo:
179=========
180$write-long-with-undo ; <byte>
181<undo-link) ; <length>
182<address> ; <long>
183<old data> ; <long>
184<new data> ; <long>
185=========
186
187Write bytes:
188=========
189$write-bytes ; <byte>
190<address> ; <long>
191<size> ; <length>
192<data> ; <size> <byte>s
193=========
194
195write bytes with undo:
196=========
197$write-bytes-with-undo ; <byte>
198<undo-link> ; <length>
199<address> ; <long>
200<size> ; <length>
201<old data> ; <size> <byte>s
202<new data> ; <size> <byte>s
203=========
204
205Fill bytes:
206=========
207$fill-byte ; <byte>
208<address> ; <long>
209<count> ; <length>
210<data> ; <byte>
211=========
212
213Fill bytes with undo:
214=========
215$fill-byte-with-undo ; <byte>
216<undo-link> ; <length>
217<address> ; <long>
218<count> ; <length>
219<old data> ; <count> <byte>s
220<new data> ; <byte>
221=========
222
223Fill word:
224=========
225$fill-word ; <byte>
226<address> ; <long>
227<count> ; <length>
228<data> ; <word>
229=========
230
231Fill word with undo:
232=========
233$fill-word-with-undo ; <byte>
234<undo-link> ; <length>
235<address> ; <long>
236<count> ; <length>
237<old data> ; <count> <word>s
238<new data> ; <word>
239=========
240
241Fill long:
242=========
243$fill-long ; <byte>
244<address> ; <long>
245<count> ; <length>
246<data> ; <long>
247=========
248
249Fill long with undo:
250=========
251$fill-long-with-undo ; <byte>
252<undo-link> ; <length>
253<address> ; <long>
254<count> ; <length>
255<old data> ; <count> <long>s
256<new data> ; <long>
257=========
258
259|#
260
261(defconstant $log-header-type #xfe)
262(defconstant $log-version 1)
263(defconstant $log-min-version 1) ; the minimum version we can handle
264(defconstant $log-eof-address 2)
265(defconstant $log-checkpoint-address 6)
266
267(defconstant $begin-transaction-type 1)
268(defconstant $continue-transaction-type 2)
269(defconstant $abort-transaction-type 3)
270(defconstant $commit-transaction-type 4)
271(defconstant $write-byte 5)
272(defconstant $write-byte-with-undo 6)
273(defconstant $write-word 7)
274(defconstant $write-word-with-undo 8)
275(defconstant $write-long 9)
276(defconstant $write-long-with-undo 10)
277(defconstant $write-bytes 11)
278(defconstant $write-bytes-with-undo 12)
279(defconstant $fill-byte 13)
280(defconstant $fill-byte-with-undo 14)
281(defconstant $fill-word 15)
282(defconstant $fill-word-with-undo 16)
283(defconstant $fill-long 17)
284(defconstant $fill-long-with-undo 18)
285(defconstant $checkpoint-type 19)
286
287; tables at bottom of file
288(declaim (special *log-type->name* *log-undo-functions*))
289
290(defun log-type->name (log-type)
291 (svref *log-type->name* log-type))
292
293; A dc-log is used for logging writes to a disk-cache.
294; It keeps the current output page locked so that entries
295; can be made quickly.
296(defstruct (dc-log (:print-function print-dc-log))
297 log-for ; the disk-cache I'm logging
298 disk-cache ; the disk-cache for the log file
299 page ; the disk-page for page-buffer
300 buffer ; one block of log bytes
301 (ptr 0) ; index into page-buffer
302 (bytes-left 0) ; number of bytes after ptr
303 modified ; true if we've written in the page
304 page-0 ; first page - for EOF & last checkpoint
305 buffer-0 ; and it's buffer
306 (eof 0) ; End of file if PTR not at EOF
307 active-transactions ; list of LSN's
308 )
309
310(defun print-dc-log (dc-log stream level)
311 (declare (ignore level))
312 (let* ((log-for (dc-log-log-for dc-log))
313 (log-for-stream (and log-for (disk-cache-stream log-for)))
314 (log-for-path (and log-for-stream (pathname log-for-stream)))
315 (dc (dc-log-disk-cache dc-log))
316 (dc-stream (and dc (disk-cache-stream dc)))
317 (dc-path (and dc-stream (pathname dc-stream))))
318 (print-unreadable-object (dc-log stream :type t :identity t)
319 (let ((pos (log-position dc-log)))
320 (prin1 pos stream)
321 (write-char #\/ stream)
322 (prin1 (max pos (dc-log-eof dc-log)) stream))
323 (when (or log-for-path dc-path)
324 (write-char #\space stream)
325 (prin1 dc-path stream)
326 (write-char #\space stream)
327 (prin1 log-for-path stream)))))
328
329; Open a disk-cache log
330; filename is a string or pathname
331; log-for is a disk-cache
332(defun open-dc-log (filename log-for &key
333 (if-exists :overwrite)
334 (if-does-not-exist :create))
335 (let ((check-header? (and (probe-file filename) (eq if-exists :overwrite)))
336 (disk-cache (open-disk-cache filename
337 :if-exists if-exists
338 :if-does-not-exist if-does-not-exist))
339 (log-for-name (file-namestring (disk-cache-stream log-for)))
340 dc-log)
341 (when disk-cache
342 (setq dc-log (make-dc-log :log-for log-for
343 :disk-cache disk-cache))
344 (if check-header?
345 (progn
346 (log-position dc-log 0)
347 (let ((page (dc-log-page dc-log)))
348 (lock-page page) ; extra lock to keep page-0 swapped in
349 (setf (dc-log-page-0 dc-log) page
350 (dc-log-buffer-0 dc-log) (dc-log-buffer dc-log)))
351 (unless (eql $log-header-type (log-read-byte dc-log))
352 (error "Bad log header in ~s" dc-log))
353 (unless (<= $log-min-version (log-read-byte dc-log) $log-version)
354 (error "Bad log version in ~s" dc-log))
355 (let* ((eof (log-read-long dc-log))
356 (checkpoint (log-read-long dc-log))
357 (dc-log-for-name (log-read-string dc-log)))
358 (declare (ignore checkpoint)) (setf (dc-log-eof dc-log) eof)
359 (unless (equalp log-for-name dc-log-for-name)
360 (cerror "Ignore this problem."
361 "~s is a log for ~s, not ~s"
362 dc-log dc-log-for-name log-for-name))
363 (log-position dc-log eof)))
364 (progn
365 (unless (eql 0 (disk-cache-size disk-cache))
366 (error "~s is not empty." disk-cache))
367 (log-extend dc-log)
368 (log-position dc-log 0)
369 (let ((page (dc-log-page dc-log)))
370 (lock-page page) ; extra lock to keep page-0 swapped in
371 (setf (dc-log-page-0 dc-log) page
372 (dc-log-buffer-0 dc-log) (dc-log-buffer dc-log)))
373 (log-write-byte dc-log $log-header-type)
374 (log-write-byte dc-log $log-version)
375 (log-write-long dc-log 0) ; eof
376 (log-write-long dc-log 0) ; checkpoint
377 (log-write-string dc-log log-for-name t)
378 (setf (dc-log-eof dc-log) (log-position dc-log))))
379 dc-log)))
380
381(defun close-dc-log (dc-log &optional ignore-active-transactions)
382 (let ((disk-cache (dc-log-disk-cache dc-log)))
383 (when disk-cache
384 (force-log dc-log)
385 (unless (or ignore-active-transactions
386 (null (dc-log-active-transactions dc-log)))
387 (cerror "Close the log anyway."
388 "Attempt to close ~s with active transactions."
389 dc-log))
390 (close-disk-cache (dc-log-disk-cache dc-log))
391 (setf (dc-log-disk-cache dc-log) nil
392 (dc-log-page dc-log) nil
393 (dc-log-buffer dc-log) nil
394 (dc-log-page-0 dc-log) nil
395 (dc-log-buffer-0 dc-log) nil)
396 t)))
397
398; Make a dc-log one block longer.
399; Position the pointer at the beginning of the new block.
400; return the position of the pointer.
401(defun log-extend (dc-log)
402 (let* ((disk-cache (dc-log-disk-cache dc-log))
403 (page-size (disk-cache-page-size disk-cache))
404 (size (disk-cache-size disk-cache))
405 (old-page (dc-log-page dc-log)))
406 (unless (eql 0 (mod size page-size))
407 (error "Inconsistency: Log is not an even number of pages long"))
408 (extend-disk-cache disk-cache (+ size page-size))
409 (multiple-value-bind (buffer offset bytes-left page)
410 (get-disk-page disk-cache size t)
411 (unless (and (eql offset 0) (eql bytes-left page-size))
412 (error "Inconsistent page offset stuff."))
413 (array-fill-byte buffer 0 0 bytes-left)
414 (lock-page page)
415 (when old-page
416 (when (dc-log-modified dc-log)
417 (mark-page-modified old-page)
418 (setf (dc-log-modified dc-log) nil))
419 (unlock-page old-page))
420 (setf (dc-log-page dc-log) page
421 (dc-log-buffer dc-log) buffer
422 (dc-log-ptr dc-log) 0
423 (dc-log-bytes-left dc-log) bytes-left))
424 size))
425
426(defun log-next-page (dc-log &optional extend-p)
427 (let* ((page (dc-log-page dc-log))
428 (disk-cache (disk-page-disk-cache page))
429 (page-size (disk-cache-page-size disk-cache))
430 (address (+ (disk-page-address page) page-size)))
431 (declare (fixnum page-size))
432 (when (dc-log-modified dc-log)
433 (mark-page-modified page)
434 (setf (dc-log-modified dc-log) nil))
435 (multiple-value-bind (buf offset size new-page)
436 (get-disk-page disk-cache address)
437 (declare (fixnum offset size))
438 (unless (or (eql offset 0) (eql offset page-size))
439 (error "Non-aligned log page in ~s" dc-log))
440 (unless (> size 0)
441 (if extend-p
442 (return-from log-next-page
443 (log-extend dc-log)))
444 (error "Attempt to read past eof of ~s" dc-log))
445 (lock-page new-page)
446 (setf (dc-log-page dc-log) new-page
447 (dc-log-buffer dc-log) buf
448 (dc-log-ptr dc-log) 0
449 (dc-log-bytes-left dc-log) size)
450 (unlock-page page))
451 address))
452
453(defun log-read-byte (dc-log)
454 (unless (dc-log-p dc-log)
455 (setq dc-log (require-type dc-log 'dc-log)))
456 (locally (declare (optimize (speed 3) (safety 0)))
457 (let ((bytes-left (dc-log-bytes-left dc-log)))
458 (declare (fixnum bytes-left))
459 (when (<= bytes-left 0)
460 (log-next-page dc-log)
461 (setq bytes-left (dc-log-bytes-left dc-log)))
462 (let ((buf (dc-log-buffer dc-log))
463 (ptr (dc-log-ptr dc-log)))
464 (declare (fixnum ptr)
465 (type (simple-array (unsigned-byte 8) (*)) buf))
466 (prog1
467 (aref buf ptr)
468 (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
469 (dc-log-bytes-left dc-log) (the fixnum (1- bytes-left))))))))
470
471(defun log-read-word (dc-log)
472 (unless (dc-log-p dc-log)
473 (setq dc-log (require-type dc-log 'dc-log)))
474 (locally (declare (optimize (speed 3) (safety 0)))
475 (let ((bytes-left (dc-log-bytes-left dc-log)))
476 (declare (fixnum bytes-left))
477 (if (>= bytes-left 2)
478 (let ((buf (dc-log-buffer dc-log))
479 (ptr (dc-log-ptr dc-log)))
480 (declare (fixnum ptr)
481 (type (simple-array (unsigned-byte 8) (*)) buf))
482 (prog1
483 (the fixnum
484 (+ (the fixnum (ash (the fixnum (aref buf ptr)) 8))
485 (the fixnum (aref buf (incf ptr)))))
486 (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
487 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 2)))))
488 (the fixnum
489 (+ (the fixnum (ash (the fixnum (log-read-byte dc-log)) 8))
490 (the fixnum (log-read-byte dc-log))))))))
491
492(defun log-read-long (dc-log)
493 (unless (dc-log-p dc-log)
494 (setq dc-log (require-type dc-log 'dc-log)))
495 (locally (declare (optimize (speed 3) (safety 0)))
496 (let ((bytes-left (dc-log-bytes-left dc-log)))
497 (declare (fixnum bytes-left))
498 (macrolet ((add-em (b3 b2 b1 b0)
499 `(let ((-b3- ,b3)
500 (-low-3- (the fixnum
501 (+ (the fixnum (ash (the fixnum ,b2) 16))
502 (the fixnum (ash (the fixnum ,b1) 8))
503 (the fixnum ,b0)))))
504 (if (eql 0 -b3-)
505 -low-3-
506 (+ (ash -b3- 24) -low-3-)))))
507 (if (>= bytes-left 4)
508 (let ((buf (dc-log-buffer dc-log))
509 (ptr (dc-log-ptr dc-log)))
510 (declare (fixnum ptr)
511 (type (simple-array (unsigned-byte 8) (*)) buf))
512 (prog1
513 (add-em (aref buf ptr)
514 (aref buf (incf ptr))
515 (aref buf (incf ptr))
516 (aref buf (incf ptr)))
517 (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
518 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4)))))
519 (add-em (log-read-byte dc-log)
520 (log-read-byte dc-log)
521 (log-read-byte dc-log)
522 (log-read-byte dc-log)))))))
523
524(defvar *log-pointer-buf*
525 (make-array 4 :element-type '(unsigned-byte 8)))
526
527(defun log-read-pointer (dc-log)
528 (unless (dc-log-p dc-log)
529 (setq dc-log (require-type dc-log 'dc-log)))
530 (locally (declare (optimize (speed 3) (safety 0)))
531 (let ((pointer-buf (or *log-pointer-buf*
532 (make-array 4 :element-type '(unsigned-byte 8)))))
533 (declare (type (simple-array (unsigned-byte 8) (*)) pointer-buf))
534 (setq *log-pointer-buf* nil)
535 (let ((bytes-left (dc-log-bytes-left dc-log)))
536 (declare (fixnum bytes-left))
537 (if (>= bytes-left 4)
538 (let ((buf (dc-log-buffer dc-log))
539 (ptr (dc-log-ptr dc-log)))
540 (declare (fixnum ptr)
541 (type (simple-array (unsigned-byte 8) (*)) buf))
542 (setf (aref pointer-buf 0) (aref buf ptr)
543 (aref pointer-buf 1) (aref buf (incf ptr))
544 (aref pointer-buf 2) (aref buf (incf ptr))
545 (aref pointer-buf 3) (aref buf (incf ptr))
546 (dc-log-ptr dc-log) (the fixnum (1+ ptr))
547 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))))
548 (setf (aref pointer-buf 0) (log-read-byte dc-log)
549 (aref pointer-buf 1) (log-read-byte dc-log)
550 (aref pointer-buf 2) (log-read-byte dc-log)
551 (aref pointer-buf 3) (log-read-byte dc-log))))
552 (multiple-value-bind (res imm?) (%%load-pointer pointer-buf 0)
553 (setq *log-pointer-buf* pointer-buf)
554 (values res imm?)))))
555
556(defun log-write-byte (dc-log byte)
557 (unless (fixnump byte)
558 (setq byte (require-type byte 'fixnum)))
559 (unless (dc-log-p dc-log)
560 (setq dc-log (require-type dc-log 'dc-log)))
561 (locally (declare (optimize (speed 3) (safety 0))
562 (fixnum byte))
563 (let ((bytes-left (dc-log-bytes-left dc-log)))
564 (declare (fixnum bytes-left))
565 (when (<= bytes-left 0)
566 (log-next-page dc-log t)
567 (setq bytes-left (dc-log-bytes-left dc-log)))
568 (let ((buf (dc-log-buffer dc-log))
569 (ptr (dc-log-ptr dc-log)))
570 (declare (fixnum ptr)
571 (type (simple-array (unsigned-byte 8) (*)) buf))
572 (setf (aref buf ptr) byte
573 (dc-log-ptr dc-log) (the fixnum (1+ ptr))
574 (dc-log-bytes-left dc-log) (the fixnum (1- bytes-left))
575 (dc-log-modified dc-log) t)
576 byte))))
577
578(defun log-write-word (dc-log word)
579 (unless (fixnump word)
580 (setq word (require-type word 'fixnum)))
581 (unless (dc-log-p dc-log)
582 (setq dc-log (require-type dc-log 'dc-log)))
583 (locally (declare (optimize (speed 3) (safety 0))
584 (fixnum word))
585 (let ((bytes-left (dc-log-bytes-left dc-log)))
586 (declare (fixnum bytes-left))
587 (if (>= bytes-left 2)
588 (let ((buf (dc-log-buffer dc-log))
589 (ptr (dc-log-ptr dc-log)))
590 (declare (fixnum ptr)
591 (type (simple-array (unsigned-byte 8) (*)) buf))
592 (setf (aref buf ptr) (ash word -8)
593 (aref buf (the fixnum (1+ ptr))) (logand word #xff)
594 (dc-log-ptr dc-log) (the fixnum (+ ptr 2))
595 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 2))
596 (dc-log-modified dc-log) t))
597 (progn
598 (log-write-byte dc-log (ash word -8))
599 (log-write-byte dc-log (logand word #xff))))
600 word)))
601
602(defun log-write-long (dc-log long)
603 (setq long (require-type long 'integer))
604 (unless (dc-log-p dc-log)
605 (setq dc-log (require-type dc-log 'dc-log)))
606 (locally (declare (optimize (speed 3) (safety 0)))
607 (let ((bytes-left (dc-log-bytes-left dc-log))
608 (low3 (if (fixnump long)
609 (the fixnum (logand (the fixnum long) #xffffff))
610 (logand long #xffffff))))
611 (declare (fixnum bytes-left low3))
612 (if (>= bytes-left 4)
613 (let ((buf (dc-log-buffer dc-log))
614 (ptr (dc-log-ptr dc-log)))
615 (declare (fixnum ptr)
616 (type (simple-array (unsigned-byte 8) (*)) buf))
617 (setf (aref buf ptr) (if (eql low3 long) 0 (ash long -24))
618 (aref buf (incf ptr)) (ash low3 -16)
619 (aref buf (incf ptr)) (logand (ash low3 -8) #xff)
620 (aref buf (incf ptr)) (logand low3 #xff)
621 (dc-log-ptr dc-log) (the fixnum (1+ ptr))
622 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))
623 (dc-log-modified dc-log) t))
624 (progn
625 (log-write-byte dc-log (if (eql low3 long) 0 (ash long -24)))
626 (log-write-byte dc-log (ash low3 -16))
627 (log-write-byte dc-log (logand (ash low3 -8) #xff))
628 (log-write-byte dc-log (logand low3 #xff))))
629 long)))
630
631(defun log-write-pointer (dc-log pointer &optional imm?)
632 (unless (dc-log-p dc-log)
633 (setq dc-log (require-type dc-log 'dc-log)))
634 (locally (declare (optimize (speed 3) (safety 0)))
635 (let ((pointer-buf (or *log-pointer-buf*
636 (make-array 4 :element-type '(unsigned-byte 8)))))
637 (declare (type (simple-array (unsigned-byte 8) (*)) pointer-buf))
638 (setq *log-pointer-buf* nil)
639 (%%store-pointer pointer pointer-buf 0 imm?)
640 (let ((bytes-left (dc-log-bytes-left dc-log)))
641 (declare (fixnum bytes-left))
642 (if (>= bytes-left 4)
643 (let ((buf (dc-log-buffer dc-log))
644 (ptr (dc-log-ptr dc-log)))
645 (declare (fixnum ptr)
646 (type (simple-array (unsigned-byte 8) (*)) buf))
647 (setf (aref buf ptr) (aref pointer-buf 0)
648 (aref buf (incf ptr)) (aref pointer-buf 1)
649 (aref buf (incf ptr)) (aref pointer-buf 2)
650 (aref buf (incf ptr)) (aref pointer-buf 3)
651 (dc-log-ptr dc-log) (the fixnum (1+ ptr))
652 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))
653 (dc-log-modified dc-log) t))
654 (progn
655 (log-write-byte dc-log (aref pointer-buf 0))
656 (log-write-byte dc-log (aref pointer-buf 1))
657 (log-write-byte dc-log (aref pointer-buf 2))
658 (log-write-byte dc-log (aref pointer-buf 3)))))
659 (values pointer imm?))))
660
661(defun log-read-length (dc-log)
662 (let ((res 0)
663 (byte 0))
664 (declare (fixnum res byte))
665 (loop
666 (setq byte (log-read-byte dc-log))
667 (if (logbitp 7 byte)
668 (setq res (+ (the fixnum (ash res 8)) (logand #x7f byte)))
669 (return (the fixnum (+ (the fixnum (ash res 8)) byte)))))))
670
671(defun log-write-length (dc-log length)
672 (unless (fixnump length)
673 (setq length (require-type length 'fixnum)))
674 (labels ((foo (dc-log length hibit)
675 (declare (fixnum length hibit)
676 (optimize (speed 3) (safety 0)))
677 (if (>= length 128)
678 (progn
679 (foo dc-log (ash length -7) 128)
680 (log-write-byte dc-log (logior hibit (logand length #x7f))))
681 (log-write-byte dc-log (logior hibit length)))))
682 (foo dc-log length 0)))
683
684(defun make-log-buffer (length)
685 (make-array length :element-type '(unsigned-byte 8)))
686
687; Will read a length from the log if the END arg is omitted.
688; If STRING is specified, it can be any 1-d array capable of holding
689; bytes (same limitations as %copy-byte-array-portion)
690; If STRING is not specified, will cons up a string.
691(defun log-read-string (dc-log &optional string (start 0) length)
692 (unless (fixnump start)
693 (setq start (require-type start 'fixnum)))
694 (if length
695 (setq length (require-type length 'fixnum)))
696 (unless (dc-log-p dc-log)
697 (setq dc-log (require-type dc-log 'dc-log)))
698 (locally (declare (fixnum start)
699 (optimize (speed 3) (safety 0)))
700 (let ((length (or length (log-read-length dc-log)))
701 (buf (dc-log-buffer dc-log))
702 (ptr (dc-log-ptr dc-log))
703 (bytes-left (dc-log-bytes-left dc-log)))
704 (declare (fixnum length ptr bytes-left))
705 (unless string (setq string (make-log-buffer length)))
706 (unless (<= length 0)
707 (if (<= bytes-left 0)
708 (log-next-page dc-log))
709 (loop
710 (let ((bytes-to-move (if (< bytes-left length) bytes-left length)))
711 (declare (fixnum bytes-to-move))
712 (%copy-byte-array-portion buf ptr bytes-to-move string start)
713 (when (<= (decf length bytes-to-move) 0)
714 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-move))
715 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-move)))
716 (return))
717 (incf start bytes-to-move)
718 (log-next-page dc-log)
719 (setq buf (dc-log-buffer dc-log)
720 ptr (dc-log-ptr dc-log)
721 bytes-left (dc-log-bytes-left dc-log)))))
722 string)))
723
724; Again, STRING is as for %copy-byte-array-portion
725(defun log-write-string (dc-log string write-length? &optional
726 (start 0) length)
727 (let ((string-length (length string)))
728 (declare (fixnum string-length))
729 (setq start (require-type start 'fixnum))
730 (unless (<= 0 start string-length)
731 (error "~s not inside string" 'start))
732 (locally (declare (fixnum start))
733 (if length
734 (progn
735 (setq length (require-type length 'fixnum))
736 (locally (declare (fixnum length))
737 (unless (<= start (+ start length) string-length)
738 (error "(+ ~s ~s) not inside string" 'start 'length))))
739 (setq length (- string-length start)))))
740 (unless (dc-log-p dc-log)
741 (setq dc-log (require-type dc-log 'dc-log)))
742 (locally (declare (fixnum start length)
743 (optimize (speed 3) (safety 0)))
744 (when write-length?
745 (log-write-length dc-log length))
746 (when (> length 0)
747 (let ((buf (dc-log-buffer dc-log))
748 (ptr (dc-log-ptr dc-log))
749 (bytes-left (dc-log-bytes-left dc-log)))
750 (declare (fixnum ptr bytes-left))
751 (loop
752 (let ((bytes-to-write (if (< bytes-left length) bytes-left length)))
753 (declare (fixnum bytes-to-write))
754 (%copy-byte-array-portion string start bytes-to-write buf ptr)
755 (when (<= (decf length bytes-to-write) 0)
756 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-write))
757 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-write)))
758 (return))
759 (incf start bytes-to-write)
760 (setf (dc-log-modified dc-log) t)
761 (log-next-page dc-log t)
762 (setq buf (dc-log-buffer dc-log)
763 ptr (dc-log-ptr dc-log)
764 bytes-left (dc-log-bytes-left dc-log)))))))
765 string)
766
767(defun log-write-disk-cache-portion (dc-log address length)
768 (setq length (require-type length 'fixnum))
769 (locally (declare (fixnum length))
770 (let ((disk-cache (dc-log-log-for dc-log))
771 (buf (make-log-buffer 512))
772 (bytes-to-copy 0))
773 (declare (fixnum bytes-to-copy))
774 (declare (dynamic-extent buf))
775 (unless (<= length 0)
776 (loop
777 (with-locked-page (disk-cache address nil page-buf offset bytes-left)
778 (declare (fixnum offset bytes-left))
779 (setq bytes-to-copy 512)
780 (if (< bytes-left bytes-to-copy)
781 (setq bytes-to-copy bytes-left))
782 (if (< length bytes-to-copy)
783 (setq bytes-to-copy length))
784 (%copy-byte-array-portion page-buf offset bytes-to-copy buf 0))
785 (log-write-string dc-log buf nil 0 bytes-to-copy)
786 (if (<= (decf length bytes-to-copy) 0)
787 (return))
788 (incf address bytes-to-copy))))))
789
790(defun log-read-disk-cache-portion (dc-log address length)
791 (setq length (require-type length 'fixnum))
792 (locally (declare (fixnum length))
793 (let ((disk-cache (dc-log-log-for dc-log))
794 (buf (make-log-buffer 512))
795 (bytes-to-copy 0))
796 (declare (fixnum bytes-to-copy))
797 (declare (dynamic-extent buf))
798 (unless (<= length 0)
799 (loop
800 (with-locked-page (disk-cache address t page-buf offset bytes-left)
801 (declare (fixnum offset bytes-left))
802 (setq bytes-to-copy 512)
803 (if (< bytes-left bytes-to-copy)
804 (setq bytes-to-copy bytes-left))
805 (if (< length bytes-to-copy)
806 (setq bytes-to-copy length))
807 (log-read-string dc-log buf 0 bytes-to-copy)
808 (%copy-byte-array-portion buf offset bytes-to-copy page-buf 0)
809 (if (<= (decf length bytes-to-copy) 0)
810 (return))
811 (incf address bytes-to-copy)))))))
812
813(defun log-position (dc-log &optional new-position)
814 (let* ((page (dc-log-page dc-log))
815 (pos (if page
816 (+ (disk-page-address page) (dc-log-ptr dc-log))
817 0))
818 (disk-cache (dc-log-disk-cache dc-log)))
819 (if (null new-position)
820 pos
821 (let ((eof (dc-log-eof dc-log))
822 (offset 0))
823 (declare (fixnum offset))
824 (if (> pos eof)
825 (setq eof (setf (dc-log-eof dc-log) pos)))
826 (if (> new-position eof)
827 (error "Attempt to set position past EOF"))
828 (when (eql new-position (disk-cache-size disk-cache))
829 (setq offset 1)
830 (decf new-position))
831 (when (dc-log-modified dc-log)
832 (mark-page-modified page)
833 (setf (dc-log-modified dc-log) nil))
834 (multiple-value-bind (buf ptr bytes-left new-page)
835 (get-disk-page disk-cache new-position)
836 (declare (fixnum ptr bytes-left))
837 (unless (eq page new-page)
838 (lock-page new-page)
839 (setf (dc-log-page dc-log) new-page
840 (dc-log-buffer dc-log) buf)
841 (when page (unlock-page page)))
842 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr offset))
843 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left offset))))
844 new-position))))
845
846(defun force-log (dc-log)
847 (let* ((buf-0 (dc-log-buffer-0 dc-log))
848 (old-eof (%load-long buf-0 $log-eof-address))
849 (eof (max (dc-log-eof dc-log) (log-position dc-log))))
850 (unless (eql eof old-eof)
851 (%store-long eof buf-0 $log-eof-address)
852 (mark-page-modified (dc-log-page-0 dc-log)))
853 (when (dc-log-modified dc-log)
854 (mark-page-modified (dc-log-page dc-log))
855 (setf (dc-log-modified dc-log) nil))
856 (flush-disk-cache (dc-log-disk-cache dc-log))))
857
858#|
859Begin transaction:
860=========
861$begin-transaction-type ; <byte>
862<parent LSN> ; <long> - LSN of parent transaction or 0
863=========
864|#
865; Returns the LSN of the new transaction
866(defun begin-transaction-log-entry (dc-log &optional (parent-lsn 0))
867 (setq parent-lsn (require-type parent-lsn 'integer))
868 (let ((lsn (log-position dc-log)))
869 (log-write-byte dc-log $begin-transaction-type)
870 (log-write-long dc-log parent-lsn)
871 (push lsn (dc-log-active-transactions dc-log))
872 lsn))
873
874#|
875Continue transaction.
876A Continue transaction record is written when a different
877transaction needs to write log records.
878=========
879$continue-transaction-type ; <byte>
880<LSN> ; <long>
881=========
882|#
883(defun log-ensure-active-transaction (dc-log transaction-lsn)
884 (unless (member transaction-lsn (dc-log-active-transactions dc-log))
885 (error "~s is not an active transaction of ~s" transaction-lsn dc-log)))
886
887(defun continue-transaction-log-entry (dc-log transaction-lsn)
888 (log-ensure-active-transaction dc-log transaction-lsn)
889 (log-write-byte dc-log $continue-transaction-type)
890 (log-write-long dc-log transaction-lsn))
891
892#|
893Abort transaction:
894=========
895$abort-transaction-type ; <byte>
896<LSN> ; <long>
897=========
898|#
899(defun abort-transaction-log-entry (dc-log transaction-lsn)
900 (log-ensure-active-transaction dc-log transaction-lsn)
901 (setf (dc-log-active-transactions dc-log)
902 (delete transaction-lsn (dc-log-active-transactions dc-log)))
903 (log-write-byte dc-log $abort-transaction-type)
904 (log-write-long dc-log transaction-lsn))
905
906
907#|
908Commit transaction:
909=========
910$commit-transaction-type ; <byte>
911<LSN> ; <long>
912=========
913|#
914(defun commit-transaction-log-entry (dc-log transaction-lsn)
915 (log-ensure-active-transaction dc-log transaction-lsn)
916 (setf (dc-log-active-transactions dc-log)
917 (delete transaction-lsn (dc-log-active-transactions dc-log)))
918 (log-write-byte dc-log $commit-transaction-type)
919 (log-write-long dc-log transaction-lsn))
920
921#|
922Checkpoint:
923=========
924$checkpoint-type ; <byte>
925<open transaction count> ; <length>
926<lsn 0> ; <long>
927...
928<lsn n> ; <long>
929=========
930|#
931(defun checkpoint-log-entry (dc-log)
932 (let* ((lsn (log-position dc-log))
933 (active-transactions (dc-log-active-transactions dc-log))
934 (count (length active-transactions)))
935 (log-write-byte dc-log $checkpoint-type)
936 (log-write-length dc-log count)
937 (dolist (lsn active-transactions)
938 (log-write-long dc-log lsn))
939 (%store-long lsn (dc-log-buffer-0 dc-log) $log-checkpoint-address)
940 (mark-page-modified (dc-log-page-0 dc-log))
941 count))
942
943;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
944;;
945;; The undoable log entries each have an undo function.
946;; This function is called by undo-aborted-transaction with two args:
947;; a log positioned just after the <undo-link> and the disk-cache
948;; we're logging.
949;;
950
951#|
952Write byte:
953=========
954$write-byte ; <byte>
955<address> ; <long>
956<data> ; <byte>
957=========
958
959Write byte with undo:
960=========
961$write-byte-with-undo ; <byte>
962<undo-link) ; <length>
963<address> ; <long>
964<old data> ; <byte>
965<new data> ; <byte>
966=========
967|#
968
969(defun write-byte-log-entry (dc-log address byte &optional last-undo)
970 (if last-undo
971 (progn
972 (log-write-byte dc-log $write-byte-with-undo)
973 (log-write-length dc-log (- (log-position dc-log) last-undo))
974 (log-write-long dc-log address)
975 (log-write-byte dc-log (read-8-bits (dc-log-disk-cache dc-log) address)))
976 (progn
977 (log-write-byte dc-log $write-byte)
978 (log-write-long dc-log address)))
979 (log-write-byte dc-log byte))
980
981(defun undo-write-byte (log disk-cache)
982 (setf (read-8-bits disk-cache (log-read-long log)) (log-read-byte log)))
983
984#|
985Write word:
986=========
987$write-word ; <byte>
988<address> ; <long>
989<data> ; <word>
990=========
991
992Write word with undo:
993=========
994$write-word-with-undo ; <byte>
995<undo-link) ; <length>
996<address> ; <long>
997<old data> ; <word>
998<new data> ; <word>
999=========
1000|#
1001
1002(defun write-word-log-entry (dc-log address word &optional last-undo)
1003 (if last-undo
1004 (progn
1005 (log-write-byte dc-log $write-word-with-undo)
1006 (log-write-length dc-log (- (log-position dc-log) last-undo))
1007 (log-write-long dc-log address)
1008 (log-write-word dc-log (read-word (dc-log-disk-cache dc-log) address)))
1009 (progn
1010 (log-write-byte dc-log $write-word)
1011 (log-write-long dc-log address)))
1012 (log-write-word dc-log word))
1013
1014(defun undo-write-word (log disk-cache)
1015 (setf (read-word disk-cache (log-read-long log)) (log-read-word log)))
1016
1017#|
1018Write long:
1019=========
1020$write-long ; <byte>
1021<address> ; <long>
1022<data> ; <long>
1023=========
1024
1025Write long with undo:
1026=========
1027$write-long-with-undo ; <byte>
1028<undo-link) ; <length>
1029<address> ; <long>
1030<old data> ; <long>
1031<new data> ; <long>
1032=========
1033|#
1034
1035(defun write-long-log-entry (dc-log address long &optional imm? last-undo)
1036 (if last-undo
1037 (progn
1038 (log-write-byte dc-log $write-byte-with-undo)
1039 (log-write-length dc-log (- (log-position dc-log) last-undo))
1040 (log-write-long dc-log address)
1041 (log-write-long dc-log (read-long (dc-log-disk-cache dc-log) address)))
1042 (progn
1043 (log-write-byte dc-log $write-long)
1044 (log-write-long dc-log address)))
1045 (if imm?
1046 (log-write-pointer dc-log long t)
1047 (log-write-long dc-log long)))
1048
1049(defun undo-write-long (log disk-cache)
1050 (setf (read-long disk-cache (log-read-long log)) (log-read-long log)))
1051
1052#|
1053Write bytes:
1054=========
1055$write-bytes ; <byte>
1056<address> ; <long>
1057<size> ; <length>
1058<data> ; <size> <byte>s
1059=========
1060
1061write bytes with undo:
1062=========
1063$write-bytes-with-undo ; <byte>
1064<undo-link> ; <length>
1065<address> ; <long>
1066<size> ; <length>
1067<old data> ; <size> <byte>s
1068<new data> ; <size> <byte>s
1069=========
1070|#
1071(defun write-bytes-log-entry (dc-log string start length address &optional last-undo)
1072 (if last-undo
1073 (progn
1074 (log-write-byte dc-log $write-bytes-with-undo)
1075 (log-write-length dc-log (- (log-position dc-log) last-undo))
1076 (log-write-long dc-log address)
1077 (log-write-length dc-log length)
1078 (log-write-disk-cache-portion dc-log address length)
1079 (log-write-string dc-log string nil start length))
1080 (progn
1081 (log-write-byte dc-log $write-bytes)
1082 (log-write-long dc-log address)
1083 (log-write-string dc-log string t start length)))
1084 string)
1085
1086(defun undo-write-bytes (log disk-cache)
1087 (declare (ignore disk-cache))
1088 (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
1089
1090#|
1091Fill bytes:
1092=========
1093$fill-byte ; <byte>
1094<address> ; <long>
1095<count> ; <length>
1096<data> ; <byte>
1097=========
1098
1099Fill bytes with undo:
1100=========
1101$fill-byte-with-undo ; <byte>
1102<undo-link> ; <length>
1103<address> ; <long>
1104<count> ; <length>
1105<old data> ; <count> <byte>s
1106<new data> ; <byte>
1107=========
1108|#
1109(defun fill-byte-log-entry (dc-log address value count &optional last-undo)
1110 (if last-undo
1111 (progn
1112 (log-write-byte dc-log $fill-byte-with-undo)
1113 (log-write-length dc-log (- (log-position dc-log) last-undo))
1114 (log-write-long dc-log address)
1115 (log-write-length dc-log count)
1116 (log-write-disk-cache-portion dc-log address count))
1117 (progn
1118 (log-write-byte dc-log $fill-byte)
1119 (log-write-long dc-log address)
1120 (log-write-length dc-log count)))
1121 (log-write-byte dc-log value))
1122
1123(defun undo-fill-byte (log disk-cache)
1124 (declare (ignore disk-cache))
1125 (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
1126
1127#|
1128Fill word:
1129=========
1130$fill-word ; <byte>
1131<address> ; <long>
1132<count> ; <length>
1133<data> ; <word>
1134=========
1135
1136Fill word with undo:
1137=========
1138$fill-word-with-undo ; <byte>
1139<undo-link> ; <length>
1140<address> ; <long>
1141<count> ; <length>
1142<old data> ; <count> <word>s
1143<new data> ; <word>
1144=========
1145|#
1146(defun fill-word-log-entry (dc-log address value count &optional last-undo)
1147 (if last-undo
1148 (progn
1149 (log-write-byte dc-log $fill-word-with-undo)
1150 (log-write-length dc-log (- (log-position dc-log) last-undo))
1151 (log-write-long dc-log address)
1152 (log-write-length dc-log count)
1153 (log-write-disk-cache-portion dc-log address count))
1154 (progn
1155 (log-write-byte dc-log $fill-word)
1156 (log-write-long dc-log address)
1157 (log-write-length dc-log count)))
1158 (log-write-word dc-log value))
1159
1160(defun undo-fill-word (log disk-cache)
1161 (declare (ignore disk-cache))
1162 (log-read-disk-cache-portion
1163 log (log-read-long log) (* 2 (the fixnum (log-read-length log)))))
1164
1165#|
1166Fill long:
1167=========
1168$fill-long ; <byte>
1169<address> ; <long>
1170<count> ; <length>
1171<data> ; <long>
1172=========
1173
1174Fill long with undo:
1175=========
1176$fill-long-with-undo ; <byte>
1177<undo-link> ; <length>
1178<address> ; <long>
1179<count> ; <length>
1180<old data> ; <count> <long>s
1181<new data> ; <long>
1182=========
1183|#
1184(defun fill-long-log-entry (dc-log address value count &optional imm? last-undo)
1185 (if last-undo
1186 (progn
1187 (log-write-byte dc-log $fill-long-with-undo)
1188 (log-write-length dc-log (- (log-position dc-log) last-undo))
1189 (log-write-long dc-log address)
1190 (log-write-length dc-log count)
1191 (log-write-disk-cache-portion dc-log address count))
1192 (progn
1193 (log-write-byte dc-log $fill-long)
1194 (log-write-long dc-log address)
1195 (log-write-length dc-log count)))
1196 (if imm?
1197 (log-write-pointer dc-log value t)
1198 (log-write-long dc-log value)))
1199
1200(defun undo-fill-long (log disk-cache)
1201 (declare (ignore disk-cache))
1202 (log-read-disk-cache-portion
1203 log (log-read-long log) (* 4 (the fixnum (log-read-length log)))))
1204
1205;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1206;;
1207;; Support for undoing aborted transactions
1208;;
1209
1210(eval-when (:compile-toplevel :execute)
1211 (require "LISPEQU")) ; ccl::%cons-pool & ccl::pool.data
1212
1213(defvar *dc-log-resource* (ccl::%cons-pool))
1214
1215(defun allocate-dc-log ()
1216 (let ((log (ccl::pool.data *dc-log-resource*)))
1217 (if log
1218 (progn
1219 (setf (ccl::pool.data *dc-log-resource*)
1220 (dc-log-log-for log))
1221 (setf (dc-log-log-for log) nil)
1222 log)
1223 (make-dc-log))))
1224
1225; The reason we copy a log is so that recovery can use it as a pointer.
1226; We need to lock the page a second time so that it remains locked
1227; when we move to a different page with either log.
1228(defun dc-log-copy (log)
1229 (let ((copy (allocate-dc-log))
1230 (page (dc-log-page log)))
1231 (setf (dc-log-log-for copy) (dc-log-log-for log)
1232 (dc-log-disk-cache copy) (dc-log-disk-cache log)
1233 (dc-log-page copy) page
1234 (dc-log-buffer copy) (dc-log-buffer log)
1235 (dc-log-ptr copy) (dc-log-ptr log)
1236 (dc-log-bytes-left copy) (dc-log-bytes-left log)
1237 (dc-log-modified copy) (dc-log-modified log)
1238 (dc-log-page-0 copy) (dc-log-page-0 log)
1239 (dc-log-buffer-0 copy) (dc-log-buffer-0 log)
1240 (dc-log-eof copy) (dc-log-eof log)
1241 (dc-log-active-transactions copy) (dc-log-active-transactions log))
1242 (when page (lock-page page))
1243 copy))
1244
1245(defun free-dc-log (log)
1246 (let ((page (dc-log-page log)))
1247 (when page
1248 (unlock-page page)))
1249 (setf (dc-log-disk-cache log) nil
1250 (dc-log-page log) nil
1251 (dc-log-buffer log) nil
1252 (dc-log-ptr log) 0
1253 (dc-log-bytes-left log) 0
1254 (dc-log-modified log) nil
1255 (dc-log-page-0 log) nil
1256 (dc-log-buffer-0 log) nil
1257 (dc-log-eof log) 0
1258 (dc-log-active-transactions log) nil)
1259 (let ((pool *dc-log-resource*))
1260 (setf (dc-log-log-for log) (ccl::pool.data pool)
1261 (ccl::pool.data pool) log))
1262 nil)
1263
1264(defmacro with-dc-log-copy ((copy log) &body body)
1265 `(let ((,copy (dc-log-copy ,log)))
1266 (unwind-protect
1267 (progn ,@body)
1268 (free-dc-log ,copy))))
1269
1270;; last-undo is 0 if there's nothing to do.
1271;; Otherwise, it's the LSN of the last undoable log entry for
1272;; the transaction whose begin-transaction log entry is at LSN.
1273(defun undo-aborted-transaction (dc-log lsn last-undo)
1274 (with-dc-log-copy (log dc-log)
1275 (log-position log lsn)
1276 (let ((undo-ptr last-undo)
1277 (log-for (dc-log-log-for log)))
1278 (loop
1279 (if (eql 0 undo-ptr) (return))
1280 (log-position log undo-ptr)
1281 (let* ((type (log-read-byte log))
1282 (undo-function (svref *log-undo-functions* type)))
1283 (unless undo-function
1284 (error "Log entry ~s is not undoable" (log-type->name type)))
1285 (let ((undo-link (log-read-length log)))
1286 (decf undo-ptr undo-link))
1287 (funcall undo-function log log-for))))))
1288
1289;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1290;;
1291;; tables
1292;;
1293(defparameter *log-type->name*
1294 #(nil
1295 $begin-transaction-type ; 1
1296 $continue-transaction-type ; 2
1297 $abort-transaction-type ; 3
1298 $commit-transaction-type ; 4
1299 $write-byte ; 5
1300 $write-byte-with-undo ; 6
1301 $write-word ; 7
1302 $write-word-with-undo ; 8
1303 $write-long ; 9
1304 $write-long-with-undo ; 10
1305 $write-bytes ; 11
1306 $write-bytes-with-undo ; 12
1307 $fill-byte ; 13
1308 $fill-byte-with-undo ; 14
1309 $fill-word ; 15
1310 $fill-word-with-undo ; 16
1311 $fill-long ; 17
1312 $fill-long-with-undo ; 18
1313 $checkpoint-type ; 19
1314 ))
1315
1316(defparameter *log-undo-functions*
1317 #(nil ; type 0 unused
1318 nil ; $begin-transaction-type = 1
1319 nil ; $continue-transaction-type = 2
1320 nil ; $abort-transaction-type = 3
1321 nil ; $commit-transaction-type = 4
1322 nil ; $write-byte = 5
1323 undo-write-byte ; $write-byte-with-undo = 6
1324 nil ; $write-word = 7
1325 undo-write-word ; $write-word-with-undo = 8
1326 nil ; $write-long = 9
1327 undo-write-long ; $write-long-with-undo = 10
1328 nil ; $write-bytes = 11
1329 undo-write-bytes ; $write-bytes-with-undo = 12
1330 nil ; $fill-byte = 13
1331 undo-fill-byte ; $fill-byte-with-undo = 14
1332 nil ; $fill-word = 15
1333 undo-fill-word ; $fill-word-with-undo = 16
1334 nil ; $fill-long = 17
1335 undo-fill-long ; $fill-long-with-undo = 18
1336 nil ; $checkpoint-type = 19
1337 ))
1338;;; 1 3/10/94 bill 1.8d247
1339;;; 2 3/23/95 bill 1.11d010
Note: See TracBrowser for help on using the repository browser.