source: trunk/recovery.lisp @ 3

Revision 3, 48.3 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
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.