source: branches/lispworks/recovery.lisp@ 18

Last change on this file since 18 was 3, checked in by Gail Zacharias, 17 years ago

Recovered version 0.961 from Sheldon Ball <s.ball@…>
  • 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; Will read a length from the log if the END arg is omitted.
685; If STRING is specified, it can be any 1-d array capable of holding
686; bytes (same limitations as %copy-byte-array-portion)
687; If STRING is not specified, will cons up a string.
688(defun log-read-string (dc-log &optional string (start 0) length)
689 (unless (fixnump start)
690 (setq start (require-type start 'fixnum)))
691 (if length
692 (setq length (require-type length 'fixnum)))
693 (unless (dc-log-p dc-log)
694 (setq dc-log (require-type dc-log 'dc-log)))
695 (locally (declare (fixnum start)
696 (optimize (speed 3) (safety 0)))
697 (let ((length (or length (log-read-length dc-log)))
698 (buf (dc-log-buffer dc-log))
699 (ptr (dc-log-ptr dc-log))
700 (bytes-left (dc-log-bytes-left dc-log)))
701 (declare (fixnum length ptr bytes-left))
702 (unless string (setq string (make-string length :element-type 'base-character)))
703 (unless (<= length 0)
704 (if (<= bytes-left 0)
705 (log-next-page dc-log))
706 (loop
707 (let ((bytes-to-move (if (< bytes-left length) bytes-left length)))
708 (declare (fixnum bytes-to-move))
709 (%copy-byte-array-portion buf ptr bytes-to-move string start)
710 (when (<= (decf length bytes-to-move) 0)
711 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-move))
712 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-move)))
713 (return))
714 (incf start bytes-to-move)
715 (log-next-page dc-log)
716 (setq buf (dc-log-buffer dc-log)
717 ptr (dc-log-ptr dc-log)
718 bytes-left (dc-log-bytes-left dc-log)))))
719 string)))
720
721; Again, STRING is as for %copy-byte-array-portion
722(defun log-write-string (dc-log string write-length? &optional
723 (start 0) length)
724 (let ((string-length (length string)))
725 (declare (fixnum string-length))
726 (setq start (require-type start 'fixnum))
727 (unless (<= 0 start string-length)
728 (error "~s not inside string" 'start))
729 (locally (declare (fixnum start))
730 (if length
731 (progn
732 (setq length (require-type length 'fixnum))
733 (locally (declare (fixnum length))
734 (unless (<= start (+ start length) string-length)
735 (error "(+ ~s ~s) not inside string" 'start 'length))))
736 (setq length (- string-length start)))))
737 (unless (dc-log-p dc-log)
738 (setq dc-log (require-type dc-log 'dc-log)))
739 (locally (declare (fixnum start length)
740 (optimize (speed 3) (safety 0)))
741 (when write-length?
742 (log-write-length dc-log length))
743 (when (> length 0)
744 (let ((buf (dc-log-buffer dc-log))
745 (ptr (dc-log-ptr dc-log))
746 (bytes-left (dc-log-bytes-left dc-log)))
747 (declare (fixnum ptr bytes-left))
748 (loop
749 (let ((bytes-to-write (if (< bytes-left length) bytes-left length)))
750 (declare (fixnum bytes-to-write))
751 (%copy-byte-array-portion string start bytes-to-write buf ptr)
752 (when (<= (decf length bytes-to-write) 0)
753 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-write))
754 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-write)))
755 (return))
756 (incf start bytes-to-write)
757 (setf (dc-log-modified dc-log) t)
758 (log-next-page dc-log t)
759 (setq buf (dc-log-buffer dc-log)
760 ptr (dc-log-ptr dc-log)
761 bytes-left (dc-log-bytes-left dc-log)))))))
762 string)
763
764(defun log-write-disk-cache-portion (dc-log address length)
765 (setq length (require-type length 'fixnum))
766 (locally (declare (fixnum length))
767 (let ((disk-cache (dc-log-log-for dc-log))
768 (buf (make-string 512 :element-type 'base-character))
769 (bytes-to-copy 0))
770 (declare (fixnum bytes-to-copy offset bytes-left))
771 (declare (dynamic-extent string))
772 (unless (<= length 0)
773 (loop
774 (with-locked-page (disk-cache address nil page-buf offset bytes-left)
775 (declare (fixnum offset bytes-left))
776 (setq bytes-to-copy 512)
777 (if (< bytes-left bytes-to-copy)
778 (setq bytes-to-copy bytes-left))
779 (if (< length bytes-to-copy)
780 (setq bytes-to-copy length))
781 (%copy-byte-array-portion page-buf offset bytes-to-copy buf 0))
782 (log-write-string dc-log buf nil 0 bytes-to-copy)
783 (if (<= (decf length bytes-to-copy) 0)
784 (return))
785 (incf address bytes-to-copy))))))
786
787(defun log-read-disk-cache-portion (dc-log address length)
788 (setq length (require-type length 'fixnum))
789 (locally (declare (fixnum length))
790 (let ((disk-cache (dc-log-log-for dc-log))
791 (buf (make-string 512 :element-type 'base-character))
792 (bytes-to-copy 0))
793 (declare (fixnum bytes-to-copy))
794 (declare (dynamic-extent string))
795 (unless (<= length 0)
796 (loop
797 (with-locked-page (disk-cache address t page-buf offset bytes-left)
798 (declare (fixnum offset bytes-left))
799 (setq bytes-to-copy 512)
800 (if (< bytes-left bytes-to-copy)
801 (setq bytes-to-copy bytes-left))
802 (if (< length bytes-to-copy)
803 (setq bytes-to-copy length))
804 (log-read-string dc-log buf 0 bytes-to-copy)
805 (%copy-byte-array-portion buf offset bytes-to-copy page-buf 0)
806 (if (<= (decf length bytes-to-copy) 0)
807 (return))
808 (incf address bytes-to-copy)))))))
809
810(defun log-position (dc-log &optional new-position)
811 (let* ((page (dc-log-page dc-log))
812 (pos (if page
813 (+ (disk-page-address page) (dc-log-ptr dc-log))
814 0))
815 (disk-cache (dc-log-disk-cache dc-log)))
816 (if (null new-position)
817 pos
818 (let ((eof (dc-log-eof dc-log))
819 (offset 0))
820 (declare (fixnum offset))
821 (if (> pos eof)
822 (setq eof (setf (dc-log-eof dc-log) pos)))
823 (if (> new-position eof)
824 (error "Attempt to set position past EOF"))
825 (when (eql new-position (disk-cache-size disk-cache))
826 (setq offset 1)
827 (decf new-position))
828 (when (dc-log-modified dc-log)
829 (mark-page-modified page)
830 (setf (dc-log-modified dc-log) nil))
831 (multiple-value-bind (buf ptr bytes-left new-page)
832 (get-disk-page disk-cache new-position)
833 (declare (fixnum ptr bytes-left))
834 (unless (eq page new-page)
835 (lock-page new-page)
836 (setf (dc-log-page dc-log) new-page
837 (dc-log-buffer dc-log) buf)
838 (when page (unlock-page page)))
839 (setf (dc-log-ptr dc-log) (the fixnum (+ ptr offset))
840 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left offset))))
841 new-position))))
842
843(defun force-log (dc-log)
844 (let* ((buf-0 (dc-log-buffer-0 dc-log))
845 (old-eof (%load-long buf-0 $log-eof-address))
846 (eof (max (dc-log-eof dc-log) (log-position dc-log))))
847 (unless (eql eof old-eof)
848 (%store-long eof buf-0 $log-eof-address)
849 (mark-page-modified (dc-log-page-0 dc-log)))
850 (when (dc-log-modified dc-log)
851 (mark-page-modified (dc-log-page dc-log))
852 (setf (dc-log-modified dc-log) nil))
853 (flush-disk-cache (dc-log-disk-cache dc-log))))
854
855#|
856Begin transaction:
857=========
858$begin-transaction-type ; <byte>
859<parent LSN> ; <long> - LSN of parent transaction or 0
860=========
861|#
862; Returns the LSN of the new transaction
863(defun begin-transaction-log-entry (dc-log &optional (parent-lsn 0))
864 (setq parent-lsn (require-type parent-lsn 'integer))
865 (let ((lsn (log-position dc-log)))
866 (log-write-byte dc-log $begin-transaction-type)
867 (log-write-long dc-log parent-lsn)
868 (push lsn (dc-log-active-transactions dc-log))
869 lsn))
870
871#|
872Continue transaction.
873A Continue transaction record is written when a different
874transaction needs to write log records.
875=========
876$continue-transaction-type ; <byte>
877<LSN> ; <long>
878=========
879|#
880(defun log-ensure-active-transaction (dc-log transaction-lsn)
881 (unless (member transaction-lsn (dc-log-active-transactions dc-log))
882 (error "~s is not an active transaction of ~s" transaction-lsn dc-log)))
883
884(defun continue-transaction-log-entry (dc-log transaction-lsn)
885 (log-ensure-active-transaction dc-log transaction-lsn)
886 (log-write-byte dc-log $continue-transaction-type)
887 (log-write-long dc-log transaction-lsn))
888
889#|
890Abort transaction:
891=========
892$abort-transaction-type ; <byte>
893<LSN> ; <long>
894=========
895|#
896(defun abort-transaction-log-entry (dc-log transaction-lsn)
897 (log-ensure-active-transaction dc-log transaction-lsn)
898 (setf (dc-log-active-transactions dc-log)
899 (delete transaction-lsn (dc-log-active-transactions dc-log)))
900 (log-write-byte dc-log $abort-transaction-type)
901 (log-write-long dc-log transaction-lsn))
902
903
904#|
905Commit transaction:
906=========
907$commit-transaction-type ; <byte>
908<LSN> ; <long>
909=========
910|#
911(defun commit-transaction-log-entry (dc-log transaction-lsn)
912 (log-ensure-active-transaction dc-log transaction-lsn)
913 (setf (dc-log-active-transactions dc-log)
914 (delete transaction-lsn (dc-log-active-transactions dc-log)))
915 (log-write-byte dc-log $commit-transaction-type)
916 (log-write-long dc-log transaction-lsn))
917
918#|
919Checkpoint:
920=========
921$checkpoint-type ; <byte>
922<open transaction count> ; <length>
923<lsn 0> ; <long>
924...
925<lsn n> ; <long>
926=========
927|#
928(defun checkpoint-log-entry (dc-log)
929 (let* ((lsn (log-position dc-log))
930 (active-transactions (dc-log-active-transactions dc-log))
931 (count (length active-transactions)))
932 (log-write-byte dc-log $checkpoint-type)
933 (log-write-length dc-log count)
934 (dolist (lsn active-transactions)
935 (log-write-long dc-log lsn))
936 (%store-long lsn (dc-log-buffer-0 dc-log) $log-checkpoint-address)
937 (mark-page-modified (dc-log-page-0 dc-log))
938 count))
939
940;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
941;;
942;; The undoable log entries each have an undo function.
943;; This function is called by undo-aborted-transaction with two args:
944;; a log positioned just after the <undo-link> and the disk-cache
945;; we're logging.
946;;
947
948#|
949Write byte:
950=========
951$write-byte ; <byte>
952<address> ; <long>
953<data> ; <byte>
954=========
955
956Write byte with undo:
957=========
958$write-byte-with-undo ; <byte>
959<undo-link) ; <length>
960<address> ; <long>
961<old data> ; <byte>
962<new data> ; <byte>
963=========
964|#
965
966(defun write-byte-log-entry (dc-log address byte &optional last-undo)
967 (if last-undo
968 (progn
969 (log-write-byte dc-log $write-byte-with-undo)
970 (log-write-length dc-log (- (log-position dc-log) last-undo))
971 (log-write-long dc-log address)
972 (log-write-byte dc-log (read-8-bits (dc-log-disk-cache dc-log) address)))
973 (progn
974 (log-write-byte dc-log $write-byte)
975 (log-write-long dc-log address)))
976 (log-write-byte dc-log byte))
977
978(defun undo-write-byte (log disk-cache)
979 (setf (read-8-bits disk-cache (log-read-long log)) (log-read-byte log)))
980
981#|
982Write word:
983=========
984$write-word ; <byte>
985<address> ; <long>
986<data> ; <word>
987=========
988
989Write word with undo:
990=========
991$write-word-with-undo ; <byte>
992<undo-link) ; <length>
993<address> ; <long>
994<old data> ; <word>
995<new data> ; <word>
996=========
997|#
998
999(defun write-word-log-entry (dc-log address word &optional last-undo)
1000 (if last-undo
1001 (progn
1002 (log-write-byte dc-log $write-word-with-undo)
1003 (log-write-length dc-log (- (log-position dc-log) last-undo))
1004 (log-write-long dc-log address)
1005 (log-write-word dc-log (read-word (dc-log-disk-cache dc-log) address)))
1006 (progn
1007 (log-write-byte dc-log $write-word)
1008 (log-write-long dc-log address)))
1009 (log-write-word dc-log word))
1010
1011(defun undo-write-word (log disk-cache)
1012 (setf (read-word disk-cache (log-read-long log)) (log-read-word log)))
1013
1014#|
1015Write long:
1016=========
1017$write-long ; <byte>
1018<address> ; <long>
1019<data> ; <long>
1020=========
1021
1022Write long with undo:
1023=========
1024$write-long-with-undo ; <byte>
1025<undo-link) ; <length>
1026<address> ; <long>
1027<old data> ; <long>
1028<new data> ; <long>
1029=========
1030|#
1031
1032(defun write-long-log-entry (dc-log address long &optional imm? last-undo)
1033 (if last-undo
1034 (progn
1035 (log-write-byte dc-log $write-byte-with-undo)
1036 (log-write-length dc-log (- (log-position dc-log) last-undo))
1037 (log-write-long dc-log address)
1038 (log-write-long dc-log (read-long (dc-log-disk-cache dc-log) address)))
1039 (progn
1040 (log-write-byte dc-log $write-long)
1041 (log-write-long dc-log address)))
1042 (if imm?
1043 (log-write-pointer dc-log long t)
1044 (log-write-long dc-log long)))
1045
1046(defun undo-write-long (log disk-cache)
1047 (setf (read-long disk-cache (log-read-long log)) (log-read-long log)))
1048
1049#|
1050Write bytes:
1051=========
1052$write-bytes ; <byte>
1053<address> ; <long>
1054<size> ; <length>
1055<data> ; <size> <byte>s
1056=========
1057
1058write bytes with undo:
1059=========
1060$write-bytes-with-undo ; <byte>
1061<undo-link> ; <length>
1062<address> ; <long>
1063<size> ; <length>
1064<old data> ; <size> <byte>s
1065<new data> ; <size> <byte>s
1066=========
1067|#
1068(defun write-bytes-log-entry (dc-log string start length address &optional last-undo)
1069 (if last-undo
1070 (progn
1071 (log-write-byte dc-log $write-bytes-with-undo)
1072 (log-write-length dc-log (- (log-position dc-log) last-undo))
1073 (log-write-long dc-log address)
1074 (log-write-length dc-log length)
1075 (log-write-disk-cache-portion dc-log address length)
1076 (log-write-string dc-log string nil start length))
1077 (progn
1078 (log-write-byte dc-log $write-bytes)
1079 (log-write-long dc-log address)
1080 (log-write-string dc-log string t start length)))
1081 string)
1082
1083(defun undo-write-bytes (log disk-cache)
1084 (declare (ignore disk-cache))
1085 (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
1086
1087#|
1088Fill bytes:
1089=========
1090$fill-byte ; <byte>
1091<address> ; <long>
1092<count> ; <length>
1093<data> ; <byte>
1094=========
1095
1096Fill bytes with undo:
1097=========
1098$fill-byte-with-undo ; <byte>
1099<undo-link> ; <length>
1100<address> ; <long>
1101<count> ; <length>
1102<old data> ; <count> <byte>s
1103<new data> ; <byte>
1104=========
1105|#
1106(defun fill-byte-log-entry (dc-log address value count &optional last-undo)
1107 (if last-undo
1108 (progn
1109 (log-write-byte dc-log $fill-byte-with-undo)
1110 (log-write-length dc-log (- (log-position dc-log) last-undo))
1111 (log-write-long dc-log address)
1112 (log-write-length dc-log count)
1113 (log-write-disk-cache-portion dc-log address count))
1114 (progn
1115 (log-write-byte dc-log $fill-byte)
1116 (log-write-long dc-log address)
1117 (log-write-length dc-log count)))
1118 (log-write-byte dc-log value))
1119
1120(defun undo-fill-byte (log disk-cache)
1121 (declare (ignore disk-cache))
1122 (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
1123
1124#|
1125Fill word:
1126=========
1127$fill-word ; <byte>
1128<address> ; <long>
1129<count> ; <length>
1130<data> ; <word>
1131=========
1132
1133Fill word with undo:
1134=========
1135$fill-word-with-undo ; <byte>
1136<undo-link> ; <length>
1137<address> ; <long>
1138<count> ; <length>
1139<old data> ; <count> <word>s
1140<new data> ; <word>
1141=========
1142|#
1143(defun fill-word-log-entry (dc-log address value count &optional last-undo)
1144 (if last-undo
1145 (progn
1146 (log-write-byte dc-log $fill-word-with-undo)
1147 (log-write-length dc-log (- (log-position dc-log) last-undo))
1148 (log-write-long dc-log address)
1149 (log-write-length dc-log count)
1150 (log-write-disk-cache-portion dc-log address count))
1151 (progn
1152 (log-write-byte dc-log $fill-word)
1153 (log-write-long dc-log address)
1154 (log-write-length dc-log count)))
1155 (log-write-word dc-log value))
1156
1157(defun undo-fill-word (log disk-cache)
1158 (declare (ignore disk-cache))
1159 (log-read-disk-cache-portion
1160 log (log-read-long log) (* 2 (the fixnum (log-read-length log)))))
1161
1162#|
1163Fill long:
1164=========
1165$fill-long ; <byte>
1166<address> ; <long>
1167<count> ; <length>
1168<data> ; <long>
1169=========
1170
1171Fill long with undo:
1172=========
1173$fill-long-with-undo ; <byte>
1174<undo-link> ; <length>
1175<address> ; <long>
1176<count> ; <length>
1177<old data> ; <count> <long>s
1178<new data> ; <long>
1179=========
1180|#
1181(defun fill-long-log-entry (dc-log address value count &optional imm? last-undo)
1182 (if last-undo
1183 (progn
1184 (log-write-byte dc-log $fill-long-with-undo)
1185 (log-write-length dc-log (- (log-position dc-log) last-undo))
1186 (log-write-long dc-log address)
1187 (log-write-length dc-log count)
1188 (log-write-disk-cache-portion dc-log address count))
1189 (progn
1190 (log-write-byte dc-log $fill-long)
1191 (log-write-long dc-log address)
1192 (log-write-length dc-log count)))
1193 (if imm?
1194 (log-write-pointer dc-log value t)
1195 (log-write-long dc-log value)))
1196
1197(defun undo-fill-long (log disk-cache)
1198 (declare (ignore disk-cache))
1199 (log-read-disk-cache-portion
1200 log (log-read-long log) (* 4 (the fixnum (log-read-length log)))))
1201
1202;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1203;;
1204;; Support for undoing aborted transactions
1205;;
1206
1207(eval-when (:compile-toplevel :execute)
1208 (require "LISPEQU")) ; ccl::%cons-pool & ccl::pool.data
1209
1210(defvar *dc-log-resource* (ccl::%cons-pool))
1211
1212(defun allocate-dc-log ()
1213 (let ((log (ccl::pool.data *dc-log-resource*)))
1214 (if log
1215 (progn
1216 (setf (ccl::pool.data *dc-log-resource*)
1217 (dc-log-log-for log))
1218 (setf (dc-log-log-for log) nil)
1219 log)
1220 (make-dc-log))))
1221
1222; The reason we copy a log is so that recovery can use it as a pointer.
1223; We need to lock the page a second time so that it remains locked
1224; when we move to a different page with either log.
1225(defun dc-log-copy (log)
1226 (let ((copy (allocate-dc-log))
1227 (page (dc-log-page log)))
1228 (setf (dc-log-log-for copy) (dc-log-log-for log)
1229 (dc-log-disk-cache copy) (dc-log-disk-cache log)
1230 (dc-log-page copy) page
1231 (dc-log-buffer copy) (dc-log-buffer log)
1232 (dc-log-ptr copy) (dc-log-ptr log)
1233 (dc-log-bytes-left copy) (dc-log-bytes-left log)
1234 (dc-log-modified copy) (dc-log-modified log)
1235 (dc-log-page-0 copy) (dc-log-page-0 log)
1236 (dc-log-buffer-0 copy) (dc-log-buffer-0 log)
1237 (dc-log-eof copy) (dc-log-eof log)
1238 (dc-log-active-transactions copy) (dc-log-active-transactions log))
1239 (when page (lock-page page))
1240 copy))
1241
1242(defun free-dc-log (log)
1243 (let ((page (dc-log-page log)))
1244 (when page
1245 (unlock-page page)))
1246 (setf (dc-log-disk-cache log) nil
1247 (dc-log-page log) nil
1248 (dc-log-buffer log) nil
1249 (dc-log-ptr log) 0
1250 (dc-log-bytes-left log) 0
1251 (dc-log-modified log) nil
1252 (dc-log-page-0 log) nil
1253 (dc-log-buffer-0 log) nil
1254 (dc-log-eof log) 0
1255 (dc-log-active-transactions log) nil)
1256 (let ((pool *dc-log-resource*))
1257 (setf (dc-log-log-for log) (ccl::pool.data pool)
1258 (ccl::pool.data pool) log))
1259 nil)
1260
1261(defmacro with-dc-log-copy ((copy log) &body body)
1262 `(let ((,copy (dc-log-copy ,log)))
1263 (unwind-protect
1264 (progn ,@body)
1265 (free-dc-log ,copy))))
1266
1267;; last-undo is 0 if there's nothing to do.
1268;; Otherwise, it's the LSN of the last undoable log entry for
1269;; the transaction whose begin-transaction log entry is at LSN.
1270(defun undo-aborted-transaction (dc-log lsn last-undo)
1271 (with-dc-log-copy (log dc-log)
1272 (log-position log lsn)
1273 (let ((undo-ptr last-undo)
1274 (log-for (dc-log-log-for log)))
1275 (loop
1276 (if (eql 0 undo-ptr) (return))
1277 (log-position log undo-ptr)
1278 (let* ((type (log-read-byte log))
1279 (undo-function (svref *log-undo-functions* type)))
1280 (unless undo-function
1281 (error "Log entry ~s is not undoable" (log-type->name type)))
1282 (let ((undo-link (log-read-length log)))
1283 (decf undo-ptr undo-link))
1284 (funcall undo-function log log-for))))))
1285
1286;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1287;;
1288;; tables
1289;;
1290(defparameter *log-type->name*
1291 #(nil
1292 $begin-transaction-type ; 1
1293 $continue-transaction-type ; 2
1294 $abort-transaction-type ; 3
1295 $commit-transaction-type ; 4
1296 $write-byte ; 5
1297 $write-byte-with-undo ; 6
1298 $write-word ; 7
1299 $write-word-with-undo ; 8
1300 $write-long ; 9
1301 $write-long-with-undo ; 10
1302 $write-bytes ; 11
1303 $write-bytes-with-undo ; 12
1304 $fill-byte ; 13
1305 $fill-byte-with-undo ; 14
1306 $fill-word ; 15
1307 $fill-word-with-undo ; 16
1308 $fill-long ; 17
1309 $fill-long-with-undo ; 18
1310 $checkpoint-type ; 19
1311 ))
1312
1313(defparameter *log-undo-functions*
1314 #(nil ; type 0 unused
1315 nil ; $begin-transaction-type = 1
1316 nil ; $continue-transaction-type = 2
1317 nil ; $abort-transaction-type = 3
1318 nil ; $commit-transaction-type = 4
1319 nil ; $write-byte = 5
1320 undo-write-byte ; $write-byte-with-undo = 6
1321 nil ; $write-word = 7
1322 undo-write-word ; $write-word-with-undo = 8
1323 nil ; $write-long = 9
1324 undo-write-long ; $write-long-with-undo = 10
1325 nil ; $write-bytes = 11
1326 undo-write-bytes ; $write-bytes-with-undo = 12
1327 nil ; $fill-byte = 13
1328 undo-fill-byte ; $fill-byte-with-undo = 14
1329 nil ; $fill-word = 15
1330 undo-fill-word ; $fill-word-with-undo = 16
1331 nil ; $fill-long = 17
1332 undo-fill-long ; $fill-long-with-undo = 18
1333 nil ; $checkpoint-type = 19
1334 ))
1335;;; 1 3/10/94 bill 1.8d247
1336;;; 2 3/23/95 bill 1.11d010
Note: See TracBrowser for help on using the repository browser.