source: trunk/disk-cache.lisp @ 3

Revision 3, 36.4 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;; disk-cache.lisp
6;; Code to support a cached byte I/O stream.
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;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;
21;; Modification History
22;;
23;; ------------- 0.96
24;; ------------- 0.95
25;; ------------- 0.94
26;; 03/27/96 bill Dylan changes add a :read-only-p keyword to open-disk-cache
27;; ------------- 0.93
28;; 05/31/95 bill Shared swapping space:
29;;               Move the page-size, max-pages, pages & locked-pages slots from the
30;;               disk-cache structure to the new shared-buffer structure. disk-cache
31;;               gets a new shared-buffer slot to hold a shared-buffer instance.
32;;               cons-disk-page works with a NIL disk-cache arg.
33;;               print-disk-page works if disk-page-stream is NIL.
34;;               New shared-buffer-pool structure.
35;;               New get-shared-buffer function, gets or allocates a shared-buffer of
36;;               a particular page size from a shared-buffer-pool instance.
37;;               open-disk-cache takes new shared-buffer & shared-buffer-pool keyword
38;;               args. If shared-buffer-pool is specified, uses get-shared-buffer
39;;               to get a shared-buffer. Otherwise, if shared-buffer is specified, uses
40;;               it. Otherwise, conses up a new shared-buffer with the given page-size
41;;               & swapping-space.
42;;               close-disk-cache call remove-disk-cache-from-shared-buffer, a new function
43;;               that removes all references to a disk-cache from the disk-page's in a shared-buffer.
44;;               add-disk-pages adds the new pages to the disk-cache-shared-buffer.
45;;               read-disk-page takes a new disk-cache argument and uses it to initialize the
46;;               disk-page-disk-cache & disk-page-stream slots.
47;;               flush-disk-page works if disk-page-disk-cache is NIL.
48;;               get-disk-page, lock-page, unlock-page updated for using the disk-cache-shared-buffer.
49;;               extend-disk-cache no longer calls add-disk-pages. It lets get-disk-page do so.
50;; 05/25/95 Moon New constant: $disk-page-flags_touched-bit, set when a page is
51;;               referenced.
52;;               New functions, disk-page-touched? & (setf disk-page-touched?), to access
53;;               the $disk-page-flags_touched-bit.
54;;               get-disk-page now uses a 1-bit clock algorithm instead of
55;;               least-recently-swapped to determine which page to swap out.
56;; 05/25/95 bill *default-page-size* moves here from "persistent-heap.lisp".
57;;               New parameter, *default-swapping-space*, is the default number
58;;               of bytes to use for swapping space.
59;;               New parameter, *big-io-buffers*, true if cl:open takes an
60;;               :elements-per-buffer keyword arg.
61;;               open-disk-cache defaults its page-size arg to
62;;               *default-page-size* instead of 512. It errors if the page size
63;;               is not at least 512. Doesn't pass an :external-format keyword
64;;               arg to open unless one was passed in. If *big-io-buffers* is
65;;               true, passes the page-size as the :elements-per-buffer keyword
66;;               arg to open.
67;;               extend-disk-cache takes a new, optional, extend-file? arg. If
68;;               true, calls set-minimum-file-length to extend the length of the file.
69;; ------------- 0.9
70;; 11/17/95 bill poor man's transactions.
71;;               open-disk-cache takes an :initial-transaction-p keyword.
72;;               If nil (NOT the default), errors on any disk writes that
73;;               happen outside of a start-disk-cache-transaction/commit-disk-cache-transaction
74;;               pair.
75;; 11/03/94 ows  open-disk-cache takes a mac-file-creator keyword,
76;;               which it passes on to open.
77;; 10/28/94 Moon Change without-interrupts to with-databases-locked.
78;;               Remove interlocking from get-disk-page; callers must.
79;;               Add comment "Must be called inside with-databases-locked"
80;;               to with-locked-page.
81;; 09/21/94 bill without-interrupts as necessary for interlocking
82;; 07/26/94 bill get-disk-page allocates a new page if all the pages
83;;               are locked. Hence, it can't fail unless out of memory.
84;; ------------- 0.8
85;; 03/27/93 bill with-open-disk-cache
86;; ------------- 0.6
87;; ------------- 0.5
88;; 07/09/92 bill Don't extend the file until flushing a page requires it.
89;;               Keep a lock count, not just a bit.
90;; 03/05/92 bill New file
91;;
92
93;;;;;;;;;;;;;;;;;;;;;;;;;;
94;;
95;; To do:
96;;
97;; with-databases-locked in just the right places.
98;; Add a journaling option.
99;; Multi-user support.
100;;
101
102(defpackage :wood)
103(in-package :wood)
104
105(export '(open-disk-cache close-disk-cache disk-cache-size
106          get-disk-page mark-page-modified extend-disk-cache))
107
108;;;;;;;;;;;;;
109;;
110;; (open-disk-cache filename &key shared-p page-size max-pages
111;;                  if-exists if-does-not-exist)
112;;
113;; filename            string or pathname
114;; shared-p            boolean. Open for shared I/O if specified and true.
115;; page-size           default: 512
116;; max-pages           default: 200
117;; if-exists           nil, :error, :supersede, or :overwrite.
118;;                     Default: :overwrite
119;; if-does-not-exist   Same as for OPEN. default: :error.
120;;
121;; returns one value, a DISK-CACHE structure
122
123;;;;;;;;;;;;;
124;;
125;; (close-disk-cache disk-cache)
126;;
127;; Flushes dirty pages and closes the stream for the given disk-cache.
128
129;;;;;;;;;;;;;
130;;
131;; (disk-cache-size disk-cache)
132;;
133;; Return the number of bytes in the file
134
135;;;;;;;;;;;;;
136;;
137;; (get-disk-page disk-cache address &optional modify-p)
138;;
139;; disk-cache    DISK-CACHE structure, as returned from OPEN-DISK-CACHE.
140;; address       fixnum. the address from/to you wish to I/O
141;; modify-p      boolean. True if you plan to write. Default: nil.
142;;
143;; returns four values:
144;; 1) array   an array of type (array (signed-byte 8)) containing the byte
145;;            at address
146;; 2) offset  fixnum. The offset in the array for the byte at address.
147;; 3) length  fixnum. The number of bytes of valid data in array at offset.
148;;                    Will be (- page-size (mod address page-size))
149;;                    unless the page is the last one or later.
150;; 4) page   a disk-page structure that can be passed to mark-page-modified
151
152;;;;;;;;;;;;;
153;;
154;; (mark-page-modified disk-page)
155;;
156;; disk-page    DISK-PAGE structure as returned in the fourth value from
157;;              GET-DISK-PAGE.
158;;
159;; Sometimes you don't know in advance whether you'll modify a page.
160;;
161;; Returns true if the page was not already marked as modified, NIL
162;; otherwise.
163
164;;;;;;;;;;;;;
165;;
166;; (extend-disk-cache disk-cache new-size)
167;;
168;; new-size   the new size of the file in bytes.
169;;            If smaller than the current size, this is a NOP.
170
171
172(defstruct (shared-buffer (:constructor cons-shared-buffer (page-size page-count max-pages pages))
173                             (:print-function print-shared-buffer))
174  (page-size 512)                       ; size of a disk-page in bytes
175  page-count                            ; number of disk pages
176  max-pages                             ; user's maximum
177  pages                                 ; head of the disk-page chain
178  locked-pages                          ; head of locked pages chain
179  users                                 ; a list of disk-cache instances
180  )
181
182(defun print-shared-buffer (shared-buffer stream level)
183  (declare (ignore level))
184  (print-unreadable-object (shared-buffer stream :type t :identity t)
185    (format stream "~s ~s/~s"
186            (shared-buffer-page-size shared-buffer)
187            (shared-buffer-page-count shared-buffer)
188            (shared-buffer-max-pages shared-buffer))))
189
190(defparameter *default-page-size* 512)
191(defparameter *default-swapping-space* (* 100 1024))
192
193(defun make-shared-buffer (&key (page-size *default-page-size*)
194                                   (swapping-space *default-swapping-space*)
195                                   max-pages)
196  (if (null max-pages)
197    (setq max-pages  (ceiling swapping-space page-size))
198    (setq swapping-space (* max-pages page-size)))
199  (unless (>= page-size 512)
200    (error "Page size must be at least 512"))
201  (unless (eql page-size (expt 2 (1- (integer-length page-size))))
202    (error "page-size must be a power of 2"))
203  (cons-shared-buffer
204   page-size 0 max-pages nil))
205
206(defstruct (shared-buffer-pool (:constructor cons-shared-buffer-pool
207                                                (swapping-space page-size auxiliary-swapping-space)))
208  (swapping-space *default-swapping-space*)
209  (page-size *default-page-size*)
210  (auxiliary-swapping-space *default-swapping-space*)
211  buffers)
212
213(defun make-shared-buffer-pool (&key (swapping-space *default-swapping-space*)
214                                         (page-size *default-page-size*)
215                                         (auxiliary-swapping-space
216                                          (min swapping-space *default-swapping-space*)))
217  (cons-shared-buffer-pool swapping-space page-size auxiliary-swapping-space))
218
219(defun get-shared-buffer (pool page-size)
220  (or (find page-size (shared-buffer-pool-buffers pool) :key 'shared-buffer-page-size)
221      (let* ((swapping-space (if (eql page-size (shared-buffer-pool-page-size pool))
222                               (shared-buffer-pool-swapping-space pool)
223                               (shared-buffer-pool-auxiliary-swapping-space pool)))
224             (buffer (make-shared-buffer :page-size page-size
225                                         :swapping-space swapping-space)))
226        (push buffer (shared-buffer-pool-buffers pool))
227        buffer)))
228
229(defstruct (disk-cache (:print-function print-disk-cache))
230  stream                                ; a stream to a file
231  size                                  ; the length of the file
232  (page-size 512)                       ; size of a disk-page in bytes
233  (mask -512)                           ; address mask
234  shared-buffer                         ; a shared-buffer instance
235  page-hash                             ; page-address -> disk-page structure
236  dirty-pages                           ; head of the dirty page chain
237  log                                   ; a LOG structure: see "recovery.lisp"
238  write-hook                            ; hook to call when a page is written to disk
239  file-eof                              ; current EOF on disk
240  transaction                           ; current transaction (just a counter for now)
241  )
242
243(defun print-disk-cache (disk-cache stream level)
244  (declare (ignore level))
245  (print-unreadable-object (disk-cache stream :type t :identity t)
246    (prin1 (pathname (disk-cache-stream disk-cache)) stream)))
247
248(defun disk-cache-read-only-p (disk-cache)
249  (eql (stream-direction (disk-cache-stream disk-cache))
250       :input))
251         
252(defstruct (disk-page (:print-function print-disk-page) (:constructor cons-disk-page))
253  disk-cache                            ; back pointer
254  stream                                ; the stream (did you guess?)
255  address                               ; file address of base of this page
256  (flags 0)                             ; bit 0 = dirty, bit 1 = touched
257  (size 0)                              ; actual size (smaller for last page)
258  next                                  ; next disk-page in the chain
259  prev                                  ; previous disk-page in the chain
260  next-dirty                            ; next dirty page
261  prev-dirty                            ; previous dirty page
262  data                                  ; an (unsigned-byte 8) array
263  (lock-count 0))                       ; non-zero means locked that many times.
264
265(defconstant $disk-page-flags_dirty-bit 0)
266(defconstant $disk-page-flags_touched-bit 1)
267
268(defun disk-page-dirty (disk-page)
269  (logbitp $disk-page-flags_dirty-bit
270           (the fixnum (disk-page-flags disk-page))))
271
272(defun (setf disk-page-dirty) (value disk-page)
273  (with-databases-locked
274   (setf (disk-page-flags disk-page)
275         (if value
276           (ccl::bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page))
277           (ccl::bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page))))
278   (not (null value))))
279
280(declaim (inline disk-page-touched? (setf disk-page-touched?)))
281
282(defun disk-page-touched? (disk-page)
283  (declare (optimize (speed 3) (safety 0)))
284  (logbitp $disk-page-flags_touched-bit
285           (the fixnum (disk-page-flags disk-page))))
286
287;; Must be called inside with-databases-locked
288(defun (setf disk-page-touched?) (value disk-page)
289  (declare (optimize (speed 3) (safety 0)))
290  (setf (disk-page-flags disk-page)
291        (if value
292          (ccl::bitset $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page)))
293          (ccl::bitclr $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page)))))
294  value)
295
296(defun disk-page-locked (disk-page)
297  (let ((count (disk-page-lock-count disk-page)))
298    (unless (eql 0 count)
299      count)))
300
301(defun print-disk-page (disk-page stream level)
302  (declare (ignore level))
303  (let* ((disk-page-stream (disk-page-stream disk-page))
304         (path (if disk-page-stream (pathname disk-page-stream) :no-file)))
305    (print-unreadable-object (disk-page stream :type t :identity t)
306      (format stream "~s~@{ ~s~}"
307              (disk-page-address disk-page)
308              (disk-page-size disk-page)
309              (disk-page-dirty disk-page)
310              path))))
311
312(defun make-disk-page (disk-cache size)
313  (cons-disk-page :disk-cache disk-cache
314                  :stream (and disk-cache (disk-cache-stream disk-cache))
315                  :data (make-array size :element-type '(unsigned-byte 8))))
316
317(defvar *open-disk-caches* nil)
318
319; New code
320(defparameter *big-io-buffers*
321  (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open)))))
322
323(defun open-disk-cache (filename &key shared-p read-only-p
324                                    (page-size *default-page-size* page-size-p)
325                                    max-pages
326                                    (swapping-space *default-swapping-space*)
327                                    shared-buffer
328                                    shared-buffer-pool
329                                    (if-exists :overwrite)
330                                    (if-does-not-exist :error)
331                                    (external-format :???? ef-p)
332                                    (mac-file-creator :ccl2)
333                                    write-hook
334                                    (initial-transaction-p t))
335  (when shared-buffer-pool
336    (setq shared-buffer (get-shared-buffer shared-buffer-pool page-size)))
337  (if shared-buffer
338    (let ((shared-buffer-page-size (shared-buffer-page-size shared-buffer)))
339      (when (and page-size-p (not (eql page-size shared-buffer-page-size)))
340        (error "Page size different from shared-buffer page size"))
341      (setq page-size shared-buffer-page-size))
342    (setq shared-buffer
343          (make-shared-buffer :page-size page-size
344                              :max-pages max-pages
345                              :swapping-space swapping-space)))
346  (setq max-pages (shared-buffer-max-pages shared-buffer))
347  (let ((mask (lognot (1- (expt 2 (1- (integer-length page-size)))))))
348    (if (probe-file filename)
349      (if (and ef-p (neq external-format (mac-file-type filename)))
350        (error "(mac-file-type ~s) was ~s, should be ~s"
351               filename (mac-file-type filename) external-format))
352      (setq ef-p t))
353    (let* ((ef (and ef-p (list :external-format external-format)))
354           (epb (and *big-io-buffers* (list :elements-per-buffer page-size)))
355           (rest (nconc ef epb))
356           (stream (apply #'open
357                          filename
358                         :direction (if read-only-p :input (if shared-p :shared :io))
359                         :if-exists if-exists
360                         :if-does-not-exist if-does-not-exist
361                         :mac-file-creator mac-file-creator
362                         rest)))
363      (when stream
364        (let* ((size (file-length stream))
365               (disk-cache (make-disk-cache :stream stream
366                                            :size size
367                                            :file-eof size
368                                            :page-size page-size
369                                            :mask mask
370                                            :shared-buffer shared-buffer
371                                            ;remove :max-pages max-pages
372                                            :write-hook write-hook)))
373          #+wood-fixnum-addresses
374          (unless (fixnump size)
375            (error "File ~s is too large for this compilation of Wood~%~
376                    Recompile Wood with :wood-fixnum-addresses removed from *features*"
377                   filename))
378          (setf (disk-cache-page-hash disk-cache)
379                (make-disk-page-hash :size (min (ceiling size page-size) max-pages)
380                                     :page-size page-size))
381          (when initial-transaction-p
382            (setf (disk-cache-transaction disk-cache) 1))
383          (push disk-cache *open-disk-caches*)
384          (push disk-cache (shared-buffer-users shared-buffer))
385          disk-cache)))))
386
387(defmacro with-open-disk-cache ((disk-cache filename &rest options) &body body)
388  `(let ((,disk-cache (open-disk-cache ,filename ,@options)))
389     (unwind-protect
390       (progn ,@body)
391       (close-disk-cache ,disk-cache))))
392
393(defun make-linked-disk-pages (disk-cache page-size page-count &optional file-length)
394  (when file-length
395    (setq page-count (max 1 (min page-count
396                                 (floor (+ file-length page-size -1)
397                                        page-size)))))
398  (let (page last-page)
399    (dotimes (i page-count)
400      (let ((new-page (make-disk-page disk-cache page-size)))
401        (setf (disk-page-next new-page) page)
402        (if page
403          (setf (disk-page-prev page) new-page)
404          (setq last-page new-page))
405        (setq page new-page)))
406    (setf (disk-page-next last-page) page
407          (disk-page-prev page) last-page)
408    (values page page-count)))
409
410(defun add-disk-pages (disk-cache count)
411  (let* ((shared-buffer (disk-cache-shared-buffer disk-cache))
412         (old-first-page (shared-buffer-pages shared-buffer))
413         (new-first-page (make-linked-disk-pages
414                          disk-cache
415                          (disk-cache-page-size disk-cache)
416                          count)))
417    (when old-first-page
418      (let ((old-last-page (disk-page-prev old-first-page))
419            (new-last-page (disk-page-prev new-first-page)))
420        (setf (disk-page-next new-last-page) old-first-page
421              (disk-page-prev old-first-page) new-last-page
422              (disk-page-next old-last-page) new-first-page
423              (disk-page-prev new-first-page) old-last-page)))
424    (setf (shared-buffer-pages shared-buffer) new-first-page)
425    (incf (shared-buffer-page-count shared-buffer) count)))
426
427(defun close-disk-cache (disk-cache)
428  (flush-disk-cache disk-cache)         ; work interruptably
429  (with-databases-locked
430   (flush-disk-cache disk-cache)        ; make sure
431   (remove-disk-cache-from-shared-buffer (disk-cache-shared-buffer disk-cache) disk-cache)
432   (close (disk-cache-stream disk-cache))
433   (setq *open-disk-caches* (delq disk-cache *open-disk-caches* 1))
434   (setf (disk-cache-page-hash disk-cache) nil)))
435
436(defun remove-disk-cache-from-shared-buffer (shared-buffer disk-cache)
437  (if (null (setf (shared-buffer-users shared-buffer)
438                  (delete disk-cache (shared-buffer-users shared-buffer) :test 'eq)))
439    (setf (shared-buffer-page-count shared-buffer) 0
440          (shared-buffer-pages shared-buffer) nil
441          (shared-buffer-locked-pages shared-buffer) nil)
442    (let ((page-hash (disk-cache-page-hash disk-cache)))
443      (when page-hash
444        (let* ((locked-pages nil)
445               (mapper #'(lambda (address page)
446                           (unless (eq disk-cache (disk-page-disk-cache page))
447                             (error "page in disk-page-hash doesn't belong to disk-cache"))
448                           (unless (eql 0 (disk-page-lock-count page))
449                             (push page locked-pages)
450                             (loop
451                               (unless (unlock-page page) (return))))
452                           (disk-page-remhash address page-hash)
453                           (setf (disk-page-disk-cache page) nil
454                                 (disk-page-address page) nil))))
455          (declare (dynamic-extent mapper))
456          (disk-page-maphash mapper page-hash)
457          (when locked-pages
458            (cerror "Continue" "Locked pages: ~s" locked-pages)))))))
459
460(defun flush-disk-cache (disk-cache)
461  (unless (disk-cache-read-only-p disk-cache)
462    (loop
463      (with-databases-locked
464        (let* ((page (disk-cache-dirty-pages disk-cache)))
465          (unless page (return))
466          (flush-disk-page page))))
467    (with-databases-locked
468      (finish-output (disk-cache-stream disk-cache)))))
469
470(defun read-disk-page (disk-cache disk-page address)
471  (flush-disk-page disk-page)
472  (when (> (the fixnum (disk-page-lock-count disk-page)) 0)
473    (error "Attempt to read locked page"))
474  (setf (disk-page-disk-cache disk-page) disk-cache
475        (disk-page-stream disk-page) (disk-cache-stream disk-cache)
476        (disk-page-address disk-page) address)
477  (let* ((size (disk-cache-size disk-cache))
478         (file-eof (disk-cache-file-eof disk-cache))
479         (page-size (min (disk-cache-page-size disk-cache) (- size address))))
480    (when (> file-eof address)
481      (stream-read-bytes (disk-page-stream disk-page)
482                         address
483                         (disk-page-data disk-page)
484                         0
485                         page-size))
486    (setf (disk-page-size disk-page) page-size)))
487
488(defun flush-disk-page (disk-page)
489  (when (disk-page-dirty disk-page)
490    (let* ((disk-cache (disk-page-disk-cache disk-page))
491           (write-hook (and disk-cache (disk-cache-write-hook disk-cache))))
492      (when write-hook
493        (funcall write-hook disk-page))
494      (when (or (not write-hook) (disk-page-dirty disk-page))   ; write-hook may have flushed this page
495        (let* ((address (disk-page-address disk-page))
496               (size (disk-page-size disk-page))
497               (end-of-page (+ address size))
498               (stream (disk-page-stream disk-page)))
499          (when (> end-of-page (disk-cache-file-eof disk-cache))
500            (set-minimum-file-length stream end-of-page)
501            (setf (disk-cache-file-eof disk-cache) end-of-page))
502          (stream-write-bytes stream
503                              address
504                              (disk-page-data disk-page)
505                              0
506                              size))
507        (let* ((next (disk-page-next-dirty disk-page))
508               (prev (disk-page-prev-dirty disk-page)))
509          (if (eq next disk-page)
510            (setf next nil)
511            (setf (disk-page-next-dirty prev) next
512                  (disk-page-prev-dirty next) prev))
513          (setf (disk-page-next-dirty disk-page) nil
514                (disk-page-prev-dirty disk-page) nil)
515          (when (eq disk-page (disk-cache-dirty-pages disk-cache))
516            (setf (disk-cache-dirty-pages disk-cache) next)))
517        (setf (disk-page-dirty disk-page) nil)))))
518
519; The caller must be inside of with-databases-locked, or the buffer returned
520; could be yanked out from under the caller.
521; 1-bit-clock page replacement algorithm.
522(defun get-disk-page (disk-cache address &optional modify-p)
523  (declare (optimize (speed 3)(safety 0)))
524  #+wood-fixnum-addresses
525  (unless (fixnump address)
526    (error "Address is not a fixnum"))
527  (locally #+wood-fixnum-addresses
528    (declare (fixnum address))
529    (let* ((hash (disk-cache-page-hash disk-cache))
530           (base-address (logand address (the fixnum (disk-cache-mask disk-cache))))
531           (page (disk-page-gethash base-address hash))
532           (offset (- address base-address))
533           (size 0))
534      #+wood-fixnum-addresses (declare (fixnum base-address))
535      (declare (fixnum offset size))
536      (block get-the-page
537        (if page
538          (setq size (disk-page-size page))
539          (let ((max-size (disk-cache-size disk-cache))
540                (shared-buffer (disk-cache-shared-buffer disk-cache)))
541            #+wood-fixnum-addresses (declare (fixnum max-size))
542            (if (>= address max-size)
543              (if (> address max-size)
544                (error "~s > size of ~s" address disk-cache)
545                (when (eql address base-address)
546                  ; If the address is the beginning of a page, and the end of
547                  ; the file, return a pointer off the end of the last page.
548                  (setq base-address (logand (1- address) (disk-cache-mask disk-cache))
549                        offset (- address base-address)
550                        page (disk-page-gethash base-address hash))
551                  (when page
552                    (setq size (disk-page-size page))
553                    (return-from get-the-page)))))
554            ; Keep adding pages till we max out.
555            (when (>= (shared-buffer-page-count shared-buffer)
556                      (shared-buffer-max-pages shared-buffer))
557              (setq page (shared-buffer-pages shared-buffer)))
558            (unless page
559              (add-disk-pages disk-cache 1)
560              (setq page (shared-buffer-pages shared-buffer)))
561            ;; Here's the page replacement algorithm, one-bit clock algorithm
562            (loop
563              (unless (disk-page-touched? page) (return))
564              (setf (disk-page-touched? page) nil)
565              (setq page (disk-page-next page)))
566            (setf (shared-buffer-pages shared-buffer) (disk-page-next page))
567            (let ((old-address (disk-page-address page)))
568              (when old-address
569                (disk-page-remhash
570                 old-address (disk-cache-page-hash (disk-page-disk-cache page)))))
571            (setq size (read-disk-page disk-cache page base-address))
572            (setf (disk-page-gethash base-address hash) page))))
573      (setf (disk-page-touched? page) t)
574      (when modify-p (mark-page-modified page))
575      (values (disk-page-data page)
576              offset
577              (- size offset)
578              page))))
579
580(defvar *error-on-non-transaction-writes* t)
581
582; The caller must be inside of with-databases-locked
583(defun mark-page-modified (disk-page)
584  (declare (optimize (speed 3) (safety 0)))
585  (unless (disk-page-dirty disk-page)
586    ; Link this disk-page as the last one in the dirty cache.
587    (let* ((disk-cache (disk-page-disk-cache disk-page))
588           (dirty-pages (disk-cache-dirty-pages disk-cache)))
589      (when (disk-cache-read-only-p disk-cache)
590        (error "Modifying a read-only database"))
591      (when (and *error-on-non-transaction-writes*
592                 (null (disk-cache-transaction disk-cache)))
593        (restart-case
594          (cerror "Let this write proceed"
595                  "Write outside of transaction to ~s"
596                  (or (disk-cache-pheap disk-cache) disk-cache))
597          (dont-repeat ()
598                       :report (lambda (s)
599                                 (format s "Let this write proceed and don't warn in the future."))
600                       (setq *error-on-non-transaction-writes* nil))))
601      (if dirty-pages
602        (let ((prev-dirty (disk-page-prev-dirty dirty-pages)))
603          (setf (disk-page-next-dirty prev-dirty) disk-page
604                (disk-page-prev-dirty disk-page) prev-dirty
605                (disk-page-next-dirty disk-page) dirty-pages
606                (disk-page-prev-dirty dirty-pages) disk-page))
607        (setf (disk-page-next-dirty disk-page) disk-page
608              (disk-page-prev-dirty disk-page) disk-page
609              (disk-cache-dirty-pages disk-cache) disk-page)))
610    (setf (disk-page-dirty disk-page) t)))
611
612; Return the lock count after locking.
613(defun lock-page (disk-page)
614  (let ((lock-count (disk-page-lock-count disk-page)))
615    (declare (fixnum lock-count))
616    (when (eql 0 lock-count)
617      (let* ((disk-cache (disk-page-disk-cache disk-page))
618             (shared-buffer (disk-cache-shared-buffer disk-cache))
619             (prev (disk-page-prev disk-page))
620             (next (disk-page-next disk-page))
621             (locked (shared-buffer-locked-pages shared-buffer))
622             (prev-locked (if locked (disk-page-prev locked) disk-page)))
623        (when (null locked)
624          (setf (shared-buffer-locked-pages shared-buffer) (setq locked disk-page)))
625        (setf (disk-page-next prev) next
626              (disk-page-prev next) prev
627              (disk-page-next prev-locked) disk-page
628              (disk-page-prev disk-page) prev-locked
629              (disk-page-prev locked) disk-page
630              (disk-page-next disk-page) locked)
631        (when (eq disk-page (shared-buffer-pages shared-buffer))
632          (setf (shared-buffer-pages shared-buffer)
633                (if (eq next disk-page) nil next)))))
634    (setf (disk-page-lock-count disk-page)
635          (the fixnum (1+ lock-count)))))
636
637; Return the lock count or NIL if the page unlocked when this returns.
638(defun unlock-page (disk-page)
639  (let ((count (disk-page-lock-count disk-page)))
640    (declare (fixnum count))
641    (when (not (eql 0 count))
642      (progn
643        (when (eql count 1)
644          (let* ((disk-cache (disk-page-disk-cache disk-page))
645                 (shared-buffer (disk-cache-shared-buffer disk-cache))
646                 (prev-locked (disk-page-prev disk-page))
647                 (next-locked (disk-page-next disk-page))
648                 (pages (shared-buffer-pages shared-buffer))
649                 (prev (if pages (disk-page-prev pages) disk-page)))
650            (when (null pages)
651              (setf (shared-buffer-pages shared-buffer) (setq pages disk-page)))
652            (setf (disk-page-next prev-locked) next-locked
653                  (disk-page-prev next-locked) prev-locked
654                  (disk-page-next prev) disk-page
655                  (disk-page-prev disk-page) prev
656                  (disk-page-prev pages) disk-page
657                  (disk-page-next disk-page) pages)
658            (when (eq disk-page (shared-buffer-locked-pages shared-buffer))
659              (setf (shared-buffer-locked-pages shared-buffer)
660                    (if (eq next-locked disk-page) nil next-locked)))))
661        (setf (disk-page-lock-count disk-page) (decf count))
662        (and (not (eql 0 count)) count)))))
663
664
665;;; Must be called inside with-databases-locked
666(defmacro with-locked-page ((disk-page-or-disk-cache
667                             &optional address modify-p array offset length page)
668                            &body body &environment env)
669  (if address
670    (let (ignored-params)
671      (multiple-value-bind (body-tail decls) (ccl::parse-body body env nil)
672        (flet ((normalize (param &optional (ignoreable? t))
673                 (or param
674                     (let ((res (gensym)))
675                       (if ignoreable? (push res ignored-params))
676                       res))))
677          `(multiple-value-bind (,(normalize array) ,(normalize offset)
678                                 ,(normalize length) ,(setq page (normalize page nil)))
679                                (get-disk-page ,disk-page-or-disk-cache ,address
680                                               ,@(if modify-p `(,modify-p)))
681             ,@(when ignored-params
682                `((declare (ignore ,@ignored-params))))
683             ,@decls
684             (with-locked-page (,page)
685               ,@body-tail)))))
686    (let ((page-var (gensym)))
687      `(let ((,page-var ,disk-page-or-disk-cache))
688         (unwind-protect
689           (progn
690             (lock-page ,page-var)
691             ,@body)
692           (unlock-page ,page-var))))))
693
694(defun lock-page-at-address (disk-cache address)
695  (with-databases-locked
696   (let ((page (nth-value 3 (get-disk-page disk-cache address))))
697     (values (lock-page page) page))))
698
699(defun unlock-page-at-address (disk-cache address)
700  (with-databases-locked
701   (let ((page (nth-value 3 (get-disk-page disk-cache address))))
702     (unlock-page page))))
703
704(defun extend-disk-cache (disk-cache new-size &optional extend-file?)
705  #+wood-fixnum-addresses
706  (unless (fixnump new-size)
707    (error "New size is not a fixnum"))
708  (with-databases-locked
709   (let ((size (disk-cache-size disk-cache)))
710     (when (> new-size size)
711       ; Update size of last page
712       (when (> size 0)
713         (let* ((page-address (logand (1- size) (disk-cache-mask disk-cache)))
714              (page (disk-page-gethash page-address (disk-cache-page-hash disk-cache))))
715         (when page
716           (setf (disk-page-size page)
717                 (min (length (disk-page-data page)) (- new-size page-address))))))
718       ; increase the file size & install the new size
719       (when extend-file?
720         (file-length (disk-cache-stream disk-cache) new-size))
721       (setf (disk-cache-size disk-cache) new-size)))))
722
723(defun flush-all-disk-caches ()
724  (dolist (dc *open-disk-caches*)
725    (if (eq :closed (stream-direction (disk-cache-stream dc)))
726      (setq *open-disk-caches* (delq dc *open-disk-caches*))
727      (flush-disk-cache dc))))
728
729(pushnew 'flush-all-disk-caches *lisp-cleanup-functions*)
730
731;;;;;;;;;;;;;;;;;;;;;;;
732;;;
733;;; Transaction support
734;;;
735
736; Not used yet, maybe it's unnecessary.
737(defmacro with-disk-cache-transaction ((disk-cache) &body body)
738  (let ((thunk (gensym)))
739    `(let ((,thunk #'(lambda () ,@body)))
740       (declare (dynamic-extent ,thunk))
741       (funcall-with-disk-cache-transaction ,disk-cache ,thunk))))
742
743(defun funcall-with-disk-cache-transaction (disk-cache thunk)
744  (let ((transaction (start-disk-cache-transaction disk-cache))
745        (done nil))
746    (unwind-protect
747      (multiple-value-prog1
748        (funcall thunk)
749        (setq done t))
750      (if done
751        (commit-disk-cache-transaction transaction)
752        (abort-disk-cache-transaction transaction)))))
753
754; These are dummies for now. Just keep a counter of how many there are.
755(defun start-disk-cache-transaction (disk-cache)
756  (with-databases-locked
757    (setf (disk-cache-transaction disk-cache)
758          (+ 1 (or (disk-cache-transaction disk-cache) 0)))
759    disk-cache))
760
761(defun commit-disk-cache-transaction (transaction &optional (flush t))
762  (let ((disk-cache transaction))
763    (with-databases-locked
764      (let ((count (1- (disk-cache-transaction disk-cache))))
765        (setf (disk-cache-transaction disk-cache)
766              (if (eql count 0) nil count))))
767    (when flush
768      (with-databases-locked
769        (flush-disk-cache disk-cache)))))
770
771(defun abort-disk-cache-transaction (transaction &optional (flush t))
772  (commit-disk-cache-transaction transaction flush))
773
774
775#|
776(setq dc (open-disk-cache "temp.lisp"))
777
778; read a string from dc
779(defun rc (address size)
780  (declare (optimize (debug 3)))
781  (declare (special dc))
782  (let ((file-size (disk-cache-size dc)))
783    (setq size (max 0 (min size (- file-size address)))))
784  (let ((string (make-string size))
785        (index 0))
786    (loop
787      (when (<= size 0) (return string))
788      (multiple-value-bind (array array-index bytes) (get-disk-page dc address)
789        (dotimes (i (min size bytes))
790          (setf (schar string index) (code-char (aref array array-index)))
791          (incf index)
792          (incf array-index))
793        (decf size bytes)
794        (incf address bytes)))))
795
796; write a string to dc
797(defun wc (string address)
798  (declare (special dc))
799  (let* ((length (length string))
800         (min-size (+ address length))
801         (index 0))
802    (when (> min-size (disk-cache-size dc))
803      (extend-disk-cache dc min-size))
804    (loop
805      (when (<= length 0) (return))
806      (multiple-value-bind (array array-index bytes) (get-disk-page dc address t)
807        (dotimes (i (min length bytes))
808          (declare (type (array (unsigned-byte 8)) array))
809          (setf (aref array array-index) (char-code (schar string index)))
810          (incf index)
811          (incf array-index))
812        (incf address bytes)
813        (decf length bytes)))))
814
815(close-disk-cache dc)
816
817|#
818;;;    1   3/10/94  bill         1.8d247
819;;;    2   7/26/94  Derek        1.9d027
820;;;    3  10/04/94  bill         1.9d071
821;;;    4  11/03/94  Moon         1.9d086
822;;;    5  11/05/94  kab          1.9d087
823;;;    2   2/18/95  RŽti         1.10d019
824;;;    3   3/23/95  bill         1.11d010
825;;;    4   6/02/95  bill         1.11d040
826;;;    5   8/01/95  bill         1.11d065
827;;;    6   8/18/95  bill         1.11d071
828;;;    7   8/25/95  Derek        Derek and Neil's massive bug fix upload
Note: See TracBrowser for help on using the repository browser.