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