| 1 | ;;;-*- Mode: Lisp -*-
|
|---|
| 2 |
|
|---|
| 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 4 | ;;
|
|---|
| 5 | ;; disk-cache-accessors.lisp
|
|---|
| 6 | ;; low-level accessors for disk-cache's
|
|---|
| 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.961
|
|---|
| 26 | ;; 09/19/96 bill The PPC version of %%load-pointer handles short floats now via %%load-short-float
|
|---|
| 27 | ;; 09/18/96 bill Fix brain-damage in PPC versions of read-double-float and (setf read-double-float)
|
|---|
| 28 | ;; ------------- 0.96
|
|---|
| 29 | ;; 06/14/96 bill AlanR's fix to read-double-float
|
|---|
| 30 | ;; ------------- 0.95
|
|---|
| 31 | ;; 03/20/96 bill Make work in MCL-PPC
|
|---|
| 32 | ;; ------------- 0.93
|
|---|
| 33 | ;; 05/25/95 bill more da -> da.l changes.
|
|---|
| 34 | ;; ------------- 0.9
|
|---|
| 35 | ;; 03/13/95 bill byte-array-p & ensure-byte-array-p move to "block-io-mcl.lisp"
|
|---|
| 36 | ;; 10/28/94 Moon Change without-interrupts to with-databases-locked.
|
|---|
| 37 | ;; 10/03/94 bill (setf wood::read-8-bits) no longer fails when writing
|
|---|
| 38 | ;; less than 4 bytes from the end of the buffer.
|
|---|
| 39 | ;; 09/21/94 bill without-interrupts as necessary for interlocking
|
|---|
| 40 | ;; ------------- 0.8
|
|---|
| 41 | ;; 08/10/93 bill eval-when around requires of lapmacros & lispequ.
|
|---|
| 42 | ;; ------------- 0.6
|
|---|
| 43 | ;; 12/09/92 bill fill-long, fill-word, & fill-byte return right away if (<= count 0).
|
|---|
| 44 | ;; ------------- 0.5
|
|---|
| 45 | ;; 07/23/92 bill array-data-and-offset -> lenient-array-data-and-offset
|
|---|
| 46 | ;; length -> uvector-bytes
|
|---|
| 47 | ;; These make the code that saves and restores non-array
|
|---|
| 48 | ;; ivectors (e.g. bignums, ratios, complex numbers)
|
|---|
| 49 | ;; work correctly.
|
|---|
| 50 | ;; 07/20/92 bill da -> da.l where necessary.
|
|---|
| 51 | ;; ------------ 0.1
|
|---|
| 52 | ;; 05/30/92 bill read-string & fill-xxx now skip $block-overhead
|
|---|
| 53 | ;; 03/16/92 bill New file.
|
|---|
| 54 | ;;
|
|---|
| 55 |
|
|---|
| 56 | (in-package :wood)
|
|---|
| 57 |
|
|---|
| 58 | (defun read-long (disk-cache address)
|
|---|
| 59 | (with-databases-locked
|
|---|
| 60 | (multiple-value-bind (array index count)
|
|---|
| 61 | (get-disk-page disk-cache address)
|
|---|
| 62 | (declare (fixnum index count))
|
|---|
| 63 | (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 64 | (error "Address odd or past eof: ~s" address))
|
|---|
| 65 | (%%load-long array index))))
|
|---|
| 66 |
|
|---|
| 67 | (defun check-byte-array-address (address size array)
|
|---|
| 68 | (unless (and (<= 0 address)
|
|---|
| 69 | (if (eql size 1)
|
|---|
| 70 | (< address (length array))
|
|---|
| 71 | (<= (+ address size) (length array))))
|
|---|
| 72 | (error "Attempt to access outside of buffer bounds")))
|
|---|
| 73 |
|
|---|
| 74 | (defun %load-long (array address)
|
|---|
| 75 | (ensure-byte-array array)
|
|---|
| 76 | (unless (typep address 'fixnum)
|
|---|
| 77 | (check-type address fixnum))
|
|---|
| 78 | (locally (declare (fixnum address))
|
|---|
| 79 | (check-byte-array-address address 4 array)
|
|---|
| 80 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 81 | (error "Odd address: ~s" address))
|
|---|
| 82 | (%%load-long array address)))
|
|---|
| 83 |
|
|---|
| 84 | (defun read-unsigned-long (disk-cache address)
|
|---|
| 85 | (with-databases-locked
|
|---|
| 86 | (multiple-value-bind (array index count)
|
|---|
| 87 | (get-disk-page disk-cache address)
|
|---|
| 88 | (declare (fixnum index count))
|
|---|
| 89 | (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 90 | (error "Address odd or past eof: ~s" address))
|
|---|
| 91 | (%%load-unsigned-long array index))))
|
|---|
| 92 |
|
|---|
| 93 | (defun %load-unsigned-long (array address)
|
|---|
| 94 | (ensure-byte-array array)
|
|---|
| 95 | (check-type address fixnum)
|
|---|
| 96 | (locally (declare (fixnum address))
|
|---|
| 97 | (check-byte-array-address address 4 array)
|
|---|
| 98 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 99 | (error "Odd address: ~s" address))
|
|---|
| 100 | (%%load-unsigned-long array address)))
|
|---|
| 101 |
|
|---|
| 102 | (defun (setf read-long) (value disk-cache address)
|
|---|
| 103 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 104 | (+ address 4))
|
|---|
| 105 | (extend-disk-cache disk-cache (+ address 4)))
|
|---|
| 106 | (with-databases-locked
|
|---|
| 107 | (multiple-value-bind (array index count)
|
|---|
| 108 | (get-disk-page disk-cache address t)
|
|---|
| 109 | (declare (fixnum index count))
|
|---|
| 110 | (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 111 | (error "Address odd or past eof: ~s" address))
|
|---|
| 112 | (%%store-long value array index)))
|
|---|
| 113 | value)
|
|---|
| 114 |
|
|---|
| 115 | (defsetf read-unsigned-long (disk-cache address) (value)
|
|---|
| 116 | `(setf (read-long ,disk-cache ,address) ,value))
|
|---|
| 117 |
|
|---|
| 118 | (defun %store-long (value array address)
|
|---|
| 119 | (ensure-byte-array array)
|
|---|
| 120 | (check-type address fixnum)
|
|---|
| 121 | (locally (declare (fixnum address))
|
|---|
| 122 | (check-byte-array-address address 4 array)
|
|---|
| 123 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 124 | (error "Odd address: ~s" address))
|
|---|
| 125 | (%%store-long value array address))
|
|---|
| 126 | value)
|
|---|
| 127 |
|
|---|
| 128 |
|
|---|
| 129 | (defun read-word (disk-cache address)
|
|---|
| 130 | (with-databases-locked
|
|---|
| 131 | (multiple-value-bind (array index count)
|
|---|
| 132 | (get-disk-page disk-cache address)
|
|---|
| 133 | (declare (fixnum index count))
|
|---|
| 134 | (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 135 | (error "Address odd or past eof: ~s" address))
|
|---|
| 136 | (%%load-word array index))))
|
|---|
| 137 |
|
|---|
| 138 | (defun %load-word (array address)
|
|---|
| 139 | (ensure-byte-array array)
|
|---|
| 140 | (check-type address fixnum)
|
|---|
| 141 | (locally (declare (fixnum address))
|
|---|
| 142 | (check-byte-array-address address 2 array)
|
|---|
| 143 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 144 | (error "Odd address: ~s" address))
|
|---|
| 145 | (%%load-word array address)))
|
|---|
| 146 |
|
|---|
| 147 | (defun read-unsigned-word (disk-cache address)
|
|---|
| 148 | (with-databases-locked
|
|---|
| 149 | (multiple-value-bind (array index count)
|
|---|
| 150 | (get-disk-page disk-cache address)
|
|---|
| 151 | (declare (fixnum index count))
|
|---|
| 152 | (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 153 | (error "Address odd or past eof: ~s" address))
|
|---|
| 154 | (%%load-unsigned-word array index))))
|
|---|
| 155 |
|
|---|
| 156 | (defun %load-unsigned-word (array address)
|
|---|
| 157 | (ensure-byte-array array)
|
|---|
| 158 | (check-type address fixnum)
|
|---|
| 159 | (locally (declare (fixnum address))
|
|---|
| 160 | (check-byte-array-address address 2 array)
|
|---|
| 161 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 162 | (error "Odd address: ~s" address))
|
|---|
| 163 | (%%load-unsigned-word array address)))
|
|---|
| 164 |
|
|---|
| 165 | (defun (setf read-word) (value disk-cache address)
|
|---|
| 166 | (check-type value fixnum)
|
|---|
| 167 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 168 | (+ address 4))
|
|---|
| 169 | (extend-disk-cache disk-cache (+ address 4)))
|
|---|
| 170 | (with-databases-locked
|
|---|
| 171 | (multiple-value-bind (array index count)
|
|---|
| 172 | (get-disk-page disk-cache address t)
|
|---|
| 173 | (declare (fixnum index count))
|
|---|
| 174 | (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 175 | (error "Odd address: ~s" address))
|
|---|
| 176 | (%%store-word value array index))))
|
|---|
| 177 |
|
|---|
| 178 | (defsetf read-unsigned-word (disk-cache address) (value)
|
|---|
| 179 | `(setf (read-word ,disk-cache ,address) ,value))
|
|---|
| 180 |
|
|---|
| 181 | (defun %store-word (value array address)
|
|---|
| 182 | (ensure-byte-array array)
|
|---|
| 183 | (check-type address fixnum)
|
|---|
| 184 | (locally (declare (fixnum address))
|
|---|
| 185 | (check-byte-array-address address 2 array)
|
|---|
| 186 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 187 | (error "Address not word aligned: ~s" address))
|
|---|
| 188 | (%%store-word value array address)))
|
|---|
| 189 |
|
|---|
| 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 191 |
|
|---|
| 192 | ; Avoid consing bignums by not boxing immediate data from the file.
|
|---|
| 193 | ; Second value is true if the result was immediate.
|
|---|
| 194 | (defun read-pointer (disk-cache address #+LispWorks &optional #+LispWorks ignore)
|
|---|
| 195 | #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation.
|
|---|
| 196 | (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
|
|---|
| 197 | (with-databases-locked
|
|---|
| 198 | (multiple-value-bind (array index count)
|
|---|
| 199 | (get-disk-page disk-cache address)
|
|---|
| 200 | (declare (fixnum index count))
|
|---|
| 201 | (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 202 | (error "Address odd or past eof: ~s" address))
|
|---|
| 203 | (%%load-pointer array index))))
|
|---|
| 204 |
|
|---|
| 205 | ; load directly from a byte array.
|
|---|
| 206 | (defun %load-pointer (array address)
|
|---|
| 207 | (ensure-byte-array array)
|
|---|
| 208 | (setq address (require-type address 'fixnum))
|
|---|
| 209 | (locally (declare (fixnum address))
|
|---|
| 210 | (check-byte-array-address address 4 array)
|
|---|
| 211 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 212 | (error "Odd address: ~s" address))
|
|---|
| 213 | (%%load-pointer array address)))
|
|---|
| 214 |
|
|---|
| 215 | (defun (setf read-pointer) (value disk-cache address &optional immediate?)
|
|---|
| 216 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 217 | (+ address 4))
|
|---|
| 218 | (extend-disk-cache disk-cache (+ address 4)))
|
|---|
| 219 | (with-databases-locked
|
|---|
| 220 | (multiple-value-bind (array index count)
|
|---|
| 221 | (get-disk-page disk-cache address t)
|
|---|
| 222 | (declare (fixnum index count))
|
|---|
| 223 | (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
|
|---|
| 224 | (error "Address odd or past eof: ~s" address))
|
|---|
| 225 | (%%store-pointer value array index immediate?)))
|
|---|
| 226 | value)
|
|---|
| 227 |
|
|---|
| 228 | (defun %store-pointer (value array address &optional immediate?)
|
|---|
| 229 | (ensure-byte-array array)
|
|---|
| 230 | (setq address (require-type address 'fixnum))
|
|---|
| 231 | (locally (declare (fixnum address))
|
|---|
| 232 | (check-byte-array-address address 4 array)
|
|---|
| 233 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 234 | (error "Odd address: ~s" address))
|
|---|
| 235 | (%%store-pointer value array address immediate?))
|
|---|
| 236 | value)
|
|---|
| 237 |
|
|---|
| 238 | (defun read-low-24-bits (disk-cache address)
|
|---|
| 239 | (with-databases-locked
|
|---|
| 240 | (multiple-value-bind (array index count)
|
|---|
| 241 | (get-disk-page disk-cache address)
|
|---|
| 242 | (declare (fixnum index count))
|
|---|
| 243 | (unless (>= count 4)
|
|---|
| 244 | (error "Address past eof or not longword aligned: ~s" address))
|
|---|
| 245 | (%%load-low-24-bits array index))))
|
|---|
| 246 |
|
|---|
| 247 | (defun (setf read-low-24-bits) (value disk-cache address)
|
|---|
| 248 | (check-type value fixnum)
|
|---|
| 249 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 250 | (+ address 4))
|
|---|
| 251 | (extend-disk-cache disk-cache (+ address 4)))
|
|---|
| 252 | (with-databases-locked
|
|---|
| 253 | (multiple-value-bind (array index count)
|
|---|
| 254 | (get-disk-page disk-cache address t)
|
|---|
| 255 | (declare (fixnum index count))
|
|---|
| 256 | (unless (>= count 4)
|
|---|
| 257 | (error "Address not longword aligned: ~s" address))
|
|---|
| 258 | (%%store-low-24-bits value array index)))
|
|---|
| 259 | value)
|
|---|
| 260 |
|
|---|
| 261 | ; Read an unsigned byte. Can't call it read-byte as Common Lisp
|
|---|
| 262 | ; already exports that symbol
|
|---|
| 263 | (defun read-8-bits (disk-cache address)
|
|---|
| 264 | (with-databases-locked
|
|---|
| 265 | (multiple-value-bind (array index count)
|
|---|
| 266 | (get-disk-page disk-cache address)
|
|---|
| 267 | (declare (fixnum index count)
|
|---|
| 268 | (type (simple-array (unsigned-byte 8) (*)) array)
|
|---|
| 269 | (optimize (speed 3) (safety 0)))
|
|---|
| 270 | (unless (>= count 1)
|
|---|
| 271 | (error "Address past eof"))
|
|---|
| 272 | (aref array index))))
|
|---|
| 273 |
|
|---|
| 274 | (defun read-8-bits-signed (disk-cache address)
|
|---|
| 275 | (with-databases-locked
|
|---|
| 276 | (multiple-value-bind (array index count)
|
|---|
| 277 | (get-disk-page disk-cache address)
|
|---|
| 278 | (declare (fixnum index count)
|
|---|
| 279 | (type (simple-array (signed-byte 8) (*)) array) ;lie
|
|---|
| 280 | (optimize (speed 3) (safety 0)))
|
|---|
| 281 | (unless (>= count 1)
|
|---|
| 282 | (error "Address past eof"))
|
|---|
| 283 | (aref array index))))
|
|---|
| 284 |
|
|---|
| 285 | (defun %load-8-bits (array address)
|
|---|
| 286 | (ensure-byte-array array)
|
|---|
| 287 | (setq address (require-type address 'fixnum))
|
|---|
| 288 | (locally (declare (fixnum address)
|
|---|
| 289 | (type (simple-array (unsigned-byte 8) (*)) array)
|
|---|
| 290 | (optimize (speed 3) (safety 0)))
|
|---|
| 291 | (check-byte-array-address address 1 array)
|
|---|
| 292 | (aref array address)))
|
|---|
| 293 |
|
|---|
| 294 | (defun (setf read-8-bits) (value disk-cache address)
|
|---|
| 295 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 296 | (+ address 4))
|
|---|
| 297 | (extend-disk-cache disk-cache (+ address 4)))
|
|---|
| 298 | (with-databases-locked
|
|---|
| 299 | (multiple-value-bind (array index count)
|
|---|
| 300 | (get-disk-page disk-cache address t)
|
|---|
| 301 | (declare (fixnum index count)
|
|---|
| 302 | (type (simple-array (unsigned-byte 8) (*)) array)
|
|---|
| 303 | (optimize (speed 3) (safety 0)))
|
|---|
| 304 | (unless (>= count 1)
|
|---|
| 305 | (error "Address past eof"))
|
|---|
| 306 | (setf (aref array index) value))))
|
|---|
| 307 |
|
|---|
| 308 | (defsetf read-8-bits-signed (disk-cache address) (value)
|
|---|
| 309 | `(setf (read-8-bits ,disk-cache ,address) ,value))
|
|---|
| 310 |
|
|---|
| 311 | (defun %store-8-bits (value array address)
|
|---|
| 312 | (ensure-byte-array array)
|
|---|
| 313 | (setq address (require-type address 'fixnum))
|
|---|
| 314 | (locally (declare (fixnum address)
|
|---|
| 315 | (type (simple-array (unsigned-byte 8) (*)) array)
|
|---|
| 316 | (optimize (speed 3) (safety 0)))
|
|---|
| 317 | (check-byte-array-address address 1 array)
|
|---|
| 318 | (setf (aref array address) value)))
|
|---|
| 319 |
|
|---|
| 320 | (defun read-string (disk-cache address length &optional string)
|
|---|
| 321 | (setq length (require-type length 'fixnum))
|
|---|
| 322 | (locally (declare (fixnum length))
|
|---|
| 323 | (when (> (+ address length) (disk-cache-size disk-cache))
|
|---|
| 324 | (error "Attempt to read past EOF"))
|
|---|
| 325 | (let ((offset 0)
|
|---|
| 326 | inner-string)
|
|---|
| 327 | (declare (fixnum offset))
|
|---|
| 328 | (cond ((and string
|
|---|
| 329 | (progn
|
|---|
| 330 | (setq string (require-type string 'string))
|
|---|
| 331 | (array-has-fill-pointer-p string)))
|
|---|
| 332 | (if (> length (array-total-size string))
|
|---|
| 333 | (setq string (adjust-array string length))
|
|---|
| 334 | (setf (fill-pointer string) length))
|
|---|
| 335 | (multiple-value-setq (inner-string offset)
|
|---|
| 336 | (array-data-and-offset string)))
|
|---|
| 337 | (string
|
|---|
| 338 | (unless (>= (length string) length)
|
|---|
| 339 | (error "~s is < ~s characters long" string length))
|
|---|
| 340 | (multiple-value-setq (inner-string offset)
|
|---|
| 341 | (array-data-and-offset string)))
|
|---|
| 342 | (t (setq inner-string
|
|---|
| 343 | (setq string (make-string length :element-type 'base-character)))))
|
|---|
| 344 | (loop
|
|---|
| 345 | (with-databases-locked
|
|---|
| 346 | (multiple-value-bind (array index count)
|
|---|
| 347 | (get-disk-page disk-cache address)
|
|---|
| 348 | (declare (fixnum count index))
|
|---|
| 349 | (copy-as-byte-vector
|
|---|
| 350 | array index inner-string offset
|
|---|
| 351 | (if (< count length) count length))
|
|---|
| 352 | (when (<= (decf length count) 0)
|
|---|
| 353 | (return))
|
|---|
| 354 | (incf address (the fixnum (+ count $block-overhead)))
|
|---|
| 355 | (incf offset count))))))
|
|---|
| 356 | string)
|
|---|
| 357 |
|
|---|
| 358 | ; Same as array-data-and-offset but works for
|
|---|
| 359 | ; non-array uvectors.
|
|---|
| 360 | (defun lenient-array-data-and-offset (array)
|
|---|
| 361 | (if (arrayp array)
|
|---|
| 362 | (array-data-and-offset array)
|
|---|
| 363 | (values array 0)))
|
|---|
| 364 |
|
|---|
| 365 | (defun-inline load-bytes-to-string (disk-cache address length string)
|
|---|
| 366 | (ensure-byte-array string)
|
|---|
| 367 | (if (> length (byte-vector-length string))
|
|---|
| 368 | (error "(~s ~s) < ~s" 'byte-vector-length string length))
|
|---|
| 369 | (load-bytes-to-ivector disk-cache address length string))
|
|---|
| 370 |
|
|---|
| 371 | (defun-inline load-bytes-to-bit-vector (disk-cache address num-bytes bitvector)
|
|---|
| 372 | (assert (typep bitvector '(simple-array (unsigned-byte 1) (*))))
|
|---|
| 373 | (load-bytes-to-ivector disk-cache address num-bytes bitvector))
|
|---|
| 374 |
|
|---|
| 375 | (defun load-bytes-to-ivector (disk-cache address length ivector)
|
|---|
| 376 | (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*))
|
|---|
| 377 | (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector)
|
|---|
| 378 | (let* ((subtype (uvector-subtype ivector))
|
|---|
| 379 | (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype))
|
|---|
| 380 | #+LispWorks (svref *subtype->array-byte-offset* subtype))))
|
|---|
| 381 | (load-bytes-as-byte-vector disk-cache address length inner-array byte-offset)))
|
|---|
| 382 | ivector)
|
|---|
| 383 |
|
|---|
| 384 | (defun load-bytes-as-byte-vector (disk-cache address length ivector byte-offset)
|
|---|
| 385 | (setq length (require-type length 'fixnum))
|
|---|
| 386 | (setq byte-offset (require-type byte-offset 'fixnum))
|
|---|
| 387 | (locally (declare (fixnum length byte-offset))
|
|---|
| 388 | (when (> (+ address length) (disk-cache-size disk-cache))
|
|---|
| 389 | (error "Attempt to read past EOF"))
|
|---|
| 390 | (loop
|
|---|
| 391 | (with-databases-locked
|
|---|
| 392 | (multiple-value-bind (array index count)
|
|---|
| 393 | (get-disk-page disk-cache address)
|
|---|
| 394 | (declare (fixnum count index))
|
|---|
| 395 | (copy-as-byte-vector array index ivector byte-offset
|
|---|
| 396 | (if (< count length) count length))
|
|---|
| 397 | (when (<= (decf length count) 0)
|
|---|
| 398 | (return))
|
|---|
| 399 | (incf address (the fixnum (+ count $block-overhead)))
|
|---|
| 400 | (incf byte-offset count))))))
|
|---|
| 401 |
|
|---|
| 402 |
|
|---|
| 403 | ; Copy length bytes from from at from-index to to at to-index.
|
|---|
| 404 | ; from-index, length, and to-index must be fixnums
|
|---|
| 405 | ; if (eq from to), the copying will be done in the correct order.
|
|---|
| 406 | ; If either array is not a byte array or string, you will likely crash
|
|---|
| 407 | ; sometime in the future.
|
|---|
| 408 | (defun %copy-byte-array-portion (from from-index length to to-index &optional to-page)
|
|---|
| 409 | (declare (ignore to-page)) ; for logging/recovery
|
|---|
| 410 | (setq from-index (require-type from-index 'fixnum))
|
|---|
| 411 | (setq length (require-type length 'fixnum))
|
|---|
| 412 | (setq to-index (require-type to-index 'fixnum))
|
|---|
| 413 | (locally (declare (fixnum from-index length to-index))
|
|---|
| 414 | (when (> length 0)
|
|---|
| 415 | (unless (and (>= from-index 0)
|
|---|
| 416 | (<= (the fixnum (+ from-index length)) (byte-vector-length from))
|
|---|
| 417 | (>= to-index 0)
|
|---|
| 418 | (<= (the fixnum (+ to-index length)) (byte-vector-length to)))
|
|---|
| 419 | (error "Attempt to index off end of one of the arrays"))
|
|---|
| 420 | (multiple-value-bind (from off) (lenient-array-data-and-offset from)
|
|---|
| 421 | (incf from-index off)
|
|---|
| 422 | (multiple-value-bind (to off) (lenient-array-data-and-offset to)
|
|---|
| 423 | (incf to-index off)
|
|---|
| 424 | (ensure-byte-array from)
|
|---|
| 425 | (ensure-byte-array to)
|
|---|
| 426 | (copy-as-byte-vector
|
|---|
| 427 | from from-index to to-index length)))))
|
|---|
| 428 | to)
|
|---|
| 429 |
|
|---|
| 430 | (defun %load-string (array index length &optional string)
|
|---|
| 431 | (unless string
|
|---|
| 432 | (setq string (make-string length :element-type 'base-character)))
|
|---|
| 433 | (%copy-byte-array-portion array index length string 0))
|
|---|
| 434 |
|
|---|
| 435 | (defun %store-string (string array index &optional (length (length string)))
|
|---|
| 436 | (%copy-byte-array-portion string 0 length array index)
|
|---|
| 437 | string)
|
|---|
| 438 |
|
|---|
| 439 | (defun (setf read-string) (string disk-cache address &optional length)
|
|---|
| 440 | (if length
|
|---|
| 441 | (when (> (setq length (require-type length 'fixnum)) (length string))
|
|---|
| 442 | (error "~s > the length of the string." 'length))
|
|---|
| 443 | (setq length (length string)))
|
|---|
| 444 | (unless (>= (disk-cache-size disk-cache)
|
|---|
| 445 | (+ address length))
|
|---|
| 446 | (extend-disk-cache disk-cache (+ address length)))
|
|---|
| 447 | (multiple-value-bind (string offset) (array-data-and-offset string)
|
|---|
| 448 | (declare (fixnum offset))
|
|---|
| 449 | (loop
|
|---|
| 450 | (with-databases-locked
|
|---|
| 451 | (multiple-value-bind (array index count)
|
|---|
| 452 | (get-disk-page disk-cache address t)
|
|---|
| 453 | (declare (fixnum count index))
|
|---|
| 454 | (copy-as-byte-vector
|
|---|
| 455 | string offset array index
|
|---|
| 456 | (if (< count length) count length))
|
|---|
| 457 | (when (<= (decf length count) 0)
|
|---|
| 458 | (return))
|
|---|
| 459 | (incf address (the fixnum (+ count wood::$block-overhead)))
|
|---|
| 460 | (incf offset count)))))
|
|---|
| 461 | string)
|
|---|
| 462 |
|
|---|
| 463 |
|
|---|
| 464 | (defun-inline store-bytes-from-string (byte-array disk-cache address length)
|
|---|
| 465 | (ensure-byte-array byte-array)
|
|---|
| 466 | (store-bytes-from-ivector byte-array disk-cache address length))
|
|---|
| 467 |
|
|---|
| 468 | (defun-inline store-bytes-from-bit-vector (bitvector disk-cache address length)
|
|---|
| 469 | (assert (typep bitvector '(simple-array (unsigned-byte 1) (*))))
|
|---|
| 470 | (store-bytes-from-ivector bitvector disk-cache address length))
|
|---|
| 471 |
|
|---|
| 472 | (defun store-bytes-from-ivector (ivector disk-cache address length)
|
|---|
| 473 | (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*))
|
|---|
| 474 | (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector)
|
|---|
| 475 | (let* ((subtype (uvector-subtype ivector))
|
|---|
| 476 | (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype))
|
|---|
| 477 | #+LispWorks (svref *subtype->array-byte-offset* subtype))))
|
|---|
| 478 | (store-bytes-as-byte-vector inner-array disk-cache address length byte-offset))))
|
|---|
| 479 |
|
|---|
| 480 | (defun store-bytes-as-byte-vector (byte-array disk-cache address length start)
|
|---|
| 481 | (setq length (require-type length 'fixnum))
|
|---|
| 482 | (setq start (require-type start 'fixnum))
|
|---|
| 483 | (locally (declare (fixnum length))
|
|---|
| 484 | (when (> (+ address length) (disk-cache-size disk-cache))
|
|---|
| 485 | (error "Attempt to read past EOF"))
|
|---|
| 486 | (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset byte-array)
|
|---|
| 487 | (incf offset start)
|
|---|
| 488 | (loop
|
|---|
| 489 | (with-databases-locked
|
|---|
| 490 | (multiple-value-bind (array index count)
|
|---|
| 491 | (get-disk-page disk-cache address t)
|
|---|
| 492 | (declare (fixnum count index))
|
|---|
| 493 | (copy-as-byte-vector
|
|---|
| 494 | inner-array offset array index
|
|---|
| 495 | (if (< count length) count length))
|
|---|
| 496 | (when (<= (decf length count) 0)
|
|---|
| 497 | (return))
|
|---|
| 498 | (incf address (the fixnum (+ count $block-overhead)))
|
|---|
| 499 | (incf offset count))))))
|
|---|
| 500 | byte-array)
|
|---|
| 501 |
|
|---|
| 502 |
|
|---|
| 503 | (defun fill-long (disk-cache address value count &optional immediate?)
|
|---|
| 504 | (let ((count (require-type count 'fixnum)))
|
|---|
| 505 | (declare (fixnum count))
|
|---|
| 506 | (unless (eql 0 (logand 1 address))
|
|---|
| 507 | (error "Odd address: ~s" address))
|
|---|
| 508 | (when (<= count 0) (return-from fill-long) nil)
|
|---|
| 509 | (let ((min-size (+ address (ash count 2))))
|
|---|
| 510 | (when (< (disk-cache-size disk-cache) min-size)
|
|---|
| 511 | (extend-disk-cache disk-cache min-size)))
|
|---|
| 512 | (loop
|
|---|
| 513 | (with-databases-locked
|
|---|
| 514 | (multiple-value-bind (vector offset size)
|
|---|
| 515 | (get-disk-page disk-cache address t)
|
|---|
| 516 | (declare (fixnum offset size))
|
|---|
| 517 | (when (<= size 0)
|
|---|
| 518 | (error "attempt to write past end of ~s" disk-cache))
|
|---|
| 519 | (let ((words (ash size -2)))
|
|---|
| 520 | (declare (fixnum words))
|
|---|
| 521 | (if (< count words) (setq words count))
|
|---|
| 522 | (if immediate?
|
|---|
| 523 | (dotimes (i words)
|
|---|
| 524 | (%%store-pointer value vector offset t)
|
|---|
| 525 | (incf offset 4))
|
|---|
| 526 | (dotimes (i words)
|
|---|
| 527 | (%%store-long value vector offset)
|
|---|
| 528 | (incf offset 4)))
|
|---|
| 529 | (if (<= (decf count words) 0) (return)))
|
|---|
| 530 | (incf address (the fixnum (+ size $block-overhead))))))))
|
|---|
| 531 |
|
|---|
| 532 | (defun fill-word (disk-cache address value count &optional immediate?)
|
|---|
| 533 | (declare (ignore immediate?))
|
|---|
| 534 | (check-type count fixnum)
|
|---|
| 535 | (check-type value fixnum)
|
|---|
| 536 | (let ((address address))
|
|---|
| 537 | (declare (fixnum count))
|
|---|
| 538 | (unless (eql 0 (logand 1 address))
|
|---|
| 539 | (error "Odd address: ~s" address))
|
|---|
| 540 | (when (<= count 0) (return-from fill-word) nil)
|
|---|
| 541 | (let ((min-size (+ address (ash count 1))))
|
|---|
| 542 | (when (< (disk-cache-size disk-cache) min-size)
|
|---|
| 543 | (extend-disk-cache disk-cache min-size)))
|
|---|
| 544 | (loop
|
|---|
| 545 | (with-databases-locked
|
|---|
| 546 | (multiple-value-bind (vector offset size)
|
|---|
| 547 | (get-disk-page disk-cache address t)
|
|---|
| 548 | (declare (fixnum offset size))
|
|---|
| 549 | (when (<= size 0)
|
|---|
| 550 | (error "attempt to write past end of ~s" disk-cache))
|
|---|
| 551 | (let ((words (ash size -1)))
|
|---|
| 552 | (declare (fixnum words))
|
|---|
| 553 | (if (< count words) (setq words count))
|
|---|
| 554 | (dotimes (i words)
|
|---|
| 555 | (%%store-word value vector offset)
|
|---|
| 556 | (incf offset 2))
|
|---|
| 557 | (if (<= (decf count words) 0) (return)))
|
|---|
| 558 | (incf address (the fixnum (+ size $block-overhead))))))))
|
|---|
| 559 |
|
|---|
| 560 | (defun fill-byte (disk-cache address value count &optional immediate?)
|
|---|
| 561 | (declare (ignore immediate?))
|
|---|
| 562 | (let ((count (require-type count 'fixnum))
|
|---|
| 563 | (address address)
|
|---|
| 564 | (value (require-type value 'fixnum)))
|
|---|
| 565 | (declare (fixnum count))
|
|---|
| 566 | (when (<= count 0) (return-from fill-byte) nil)
|
|---|
| 567 | (let ((min-size (+ address count)))
|
|---|
| 568 | (when (< (disk-cache-size disk-cache) min-size)
|
|---|
| 569 | (extend-disk-cache disk-cache min-size)))
|
|---|
| 570 | (loop
|
|---|
| 571 | (with-databases-locked
|
|---|
| 572 | (multiple-value-bind (vector offset size)
|
|---|
| 573 | (get-disk-page disk-cache address t)
|
|---|
| 574 | (declare (fixnum offset size))
|
|---|
| 575 | (when (<= size 0)
|
|---|
| 576 | (error "attempt to write past end of ~s" disk-cache))
|
|---|
| 577 | (if (< count size) (setq size count))
|
|---|
| 578 | (locally (declare (type (simple-array (unsigned-byte 8) (*)) vector)
|
|---|
| 579 | (optimize (speed 3) (safety 0)))
|
|---|
| 580 | (dotimes (i size)
|
|---|
| 581 | (setf (aref vector offset) value)
|
|---|
| 582 | (incf offset)))
|
|---|
| 583 | (if (<= (decf count size) 0) (return))
|
|---|
| 584 | (incf address (the fixnum (+ size $block-overhead))))))))
|
|---|
| 585 |
|
|---|
| 586 | (defun array-fill-long (array address value count &optional immediate?)
|
|---|
| 587 | (ensure-byte-array array)
|
|---|
| 588 | (let ((count (require-type count 'fixnum))
|
|---|
| 589 | (address (require-type address 'fixnum))
|
|---|
| 590 | (value (require-type value 'fixnum)))
|
|---|
| 591 | (declare (fixnum count address))
|
|---|
| 592 | (check-byte-array-address address (* 4 count) array)
|
|---|
| 593 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 594 | (error "Odd address: ~s" address))
|
|---|
| 595 | (let ((offset address))
|
|---|
| 596 | (declare (fixnum offset))
|
|---|
| 597 | (if immediate?
|
|---|
| 598 | (dotimes (i count)
|
|---|
| 599 | (%%store-pointer value array offset t)
|
|---|
| 600 | (incf offset 4))
|
|---|
| 601 | (dotimes (i count)
|
|---|
| 602 | (%%store-long value array offset)
|
|---|
| 603 | (incf offset 4)))))
|
|---|
| 604 | nil)
|
|---|
| 605 |
|
|---|
| 606 | (defun array-fill-word (array address value count)
|
|---|
| 607 | (ensure-byte-array array)
|
|---|
| 608 | (check-type value fixnum)
|
|---|
| 609 | (let ((count (require-type count 'fixnum))
|
|---|
| 610 | (address (require-type address 'fixnum)))
|
|---|
| 611 | (declare (fixnum count address))
|
|---|
| 612 | (check-byte-array-address address (* 2 count) array)
|
|---|
| 613 | (unless (eql 0 (the fixnum (logand 1 address)))
|
|---|
| 614 | (error "Odd address: ~s" address))
|
|---|
| 615 | (dotimes (i count)
|
|---|
| 616 | (declare (fixnum i))
|
|---|
| 617 | (%%store-word value array address)
|
|---|
| 618 | (incf address 2)))
|
|---|
| 619 | nil)
|
|---|
| 620 |
|
|---|
| 621 | (defun array-fill-byte (array address value count)
|
|---|
| 622 | (ensure-byte-array array)
|
|---|
| 623 | (let ((count (require-type count 'fixnum))
|
|---|
| 624 | (address (require-type address 'fixnum))
|
|---|
| 625 | (value (require-type value 'fixnum)))
|
|---|
| 626 | (declare (fixnum count address))
|
|---|
| 627 | (check-byte-array-address address count array)
|
|---|
| 628 | (let ((offset address))
|
|---|
| 629 | (declare (fixnum offset)
|
|---|
| 630 | (type (simple-array (unsigned-byte 8) (*)) array)
|
|---|
| 631 | (optimize (speed 3) (safety 0)))
|
|---|
| 632 | (dotimes (i count)
|
|---|
| 633 | (setf (aref array offset) value)
|
|---|
| 634 | (incf offset))))
|
|---|
| 635 | nil)
|
|---|
| 636 |
|
|---|
| 637 |
|
|---|
| 638 | ; some macros to make using this take less typing.
|
|---|
| 639 | (export '(accessing-disk-cache))
|
|---|
| 640 |
|
|---|
| 641 | (defmacro accessing-disk-cache ((disk-cache &optional base) &body body)
|
|---|
| 642 | (let* ((b (gensym)))
|
|---|
| 643 | `(let ((-*dc*- ,disk-cache)
|
|---|
| 644 | ,@(when base
|
|---|
| 645 | `((,b ,base))))
|
|---|
| 646 | (macrolet ((-*addr*- (address)
|
|---|
| 647 | (if ',base
|
|---|
| 648 | `(+ ,',b ,address)
|
|---|
| 649 | address))
|
|---|
| 650 | (-*select*- (operation disk-cache-code array-code)
|
|---|
| 651 | (declare (ignore array-code))
|
|---|
| 652 | (if (eq disk-cache-code :error)
|
|---|
| 653 | (error "~s not supported for disk-cache's" operation))
|
|---|
| 654 | disk-cache-code))
|
|---|
| 655 | ,@body))))
|
|---|
| 656 |
|
|---|
| 657 | (defmacro accessing-byte-array ((byte-array &optional base disk-page) &body body)
|
|---|
| 658 | (let* ((b (gensym)))
|
|---|
| 659 | `(let ((-*dc*- ,byte-array)
|
|---|
| 660 | ,@(when base
|
|---|
| 661 | `((,b ,base))))
|
|---|
| 662 | (macrolet ((-*addr*- (address)
|
|---|
| 663 | (if ',base
|
|---|
| 664 | `(+ ,',b ,address)
|
|---|
| 665 | address))
|
|---|
| 666 | (-*select*- (operation disk-cache-code array-code)
|
|---|
| 667 | (declare (ignore disk-cache-code))
|
|---|
| 668 | (if (eq array-code :error)
|
|---|
| 669 | (error "~s not supported for arrays" operation))
|
|---|
| 670 | array-code))
|
|---|
| 671 | ,disk-page
|
|---|
| 672 | ,@body))))
|
|---|
| 673 |
|
|---|
| 674 | (defun ensure-accessing-disk-cache (accessor env)
|
|---|
| 675 | (unless (and (eq :lexical (variable-information '-*dc*- env))
|
|---|
| 676 | #+ccl (eq :macro (function-information '-*addr*- env))
|
|---|
| 677 | #+ccl (eq :macro (function-information '-*select*- env)))
|
|---|
| 678 | (error "~s called ouside of ~s environment" accessor 'accessing-disk-cache)))
|
|---|
| 679 |
|
|---|
| 680 | (defmacro load.l (address &environment env)
|
|---|
| 681 | (ensure-accessing-disk-cache 'load.l env)
|
|---|
| 682 | `(-*select*-
|
|---|
| 683 | load.l
|
|---|
| 684 | (read-long -*dc*- (-*addr*- ,address))
|
|---|
| 685 | (%load-long -*dc*- (-*addr*- ,address))))
|
|---|
| 686 |
|
|---|
| 687 | (defmacro load.ul (address &environment env)
|
|---|
| 688 | (ensure-accessing-disk-cache 'load.ul env)
|
|---|
| 689 | `(-*select*-
|
|---|
| 690 | load.ul
|
|---|
| 691 | (read-unsigned-long -*dc*- (-*addr*- ,address))
|
|---|
| 692 | (%load-unsigned-long -*dc*- (-*addr*- ,address))))
|
|---|
| 693 |
|
|---|
| 694 | (defmacro load.p (address &environment env)
|
|---|
| 695 | (ensure-accessing-disk-cache 'load.ul env)
|
|---|
| 696 | `(-*select*-
|
|---|
| 697 | load.p
|
|---|
| 698 | (read-pointer -*dc*- (-*addr*- ,address))
|
|---|
| 699 | (%load-pointer -*dc*- (-*addr*- ,address))))
|
|---|
| 700 |
|
|---|
| 701 | (defmacro load.w (address &environment env)
|
|---|
| 702 | (ensure-accessing-disk-cache 'load.w env)
|
|---|
| 703 | `(the fixnum
|
|---|
| 704 | (-*select*-
|
|---|
| 705 | load.w
|
|---|
| 706 | (read-word -*dc*- (-*addr*- ,address))
|
|---|
| 707 | (%load-word -*dc*- (-*addr*- ,address)))))
|
|---|
| 708 |
|
|---|
| 709 | (defmacro load.uw (address &environment env)
|
|---|
| 710 | (ensure-accessing-disk-cache 'load.uw env)
|
|---|
| 711 | `(the fixnum
|
|---|
| 712 | (-*select*-
|
|---|
| 713 | load.uw
|
|---|
| 714 | (read-unsigned-word -*dc*- (-*addr*- ,address))
|
|---|
| 715 | (%load-unsigned-word -*dc*- (-*addr*- ,address)))))
|
|---|
| 716 |
|
|---|
| 717 | (defmacro load.b (address &environment env)
|
|---|
| 718 | (ensure-accessing-disk-cache 'load.b env)
|
|---|
| 719 | `(the fixnum
|
|---|
| 720 | (-*select*-
|
|---|
| 721 | load.b
|
|---|
| 722 | (read-8-bits -*dc*- (-*addr*- ,address))
|
|---|
| 723 | (%load-8-bits -*dc*- (-*addr*- ,address)))))
|
|---|
| 724 |
|
|---|
| 725 | (defmacro load.string (address length &optional string &environment env)
|
|---|
| 726 | (ensure-accessing-disk-cache 'load.string env)
|
|---|
| 727 | `(-*select*-
|
|---|
| 728 | load.string
|
|---|
| 729 | (read-string -*dc*- (-*addr*- ,address) ,length
|
|---|
| 730 | ,@(if string `(,string)))
|
|---|
| 731 | (%load-string -*dc*- (-*addr*- ,address) ,length
|
|---|
| 732 | ,@(if string `(,string)))))
|
|---|
| 733 |
|
|---|
| 734 | (defmacro store.l (value address &environment env)
|
|---|
| 735 | (ensure-accessing-disk-cache 'store.l env)
|
|---|
| 736 | `(-*select*-
|
|---|
| 737 | store.l
|
|---|
| 738 | (let ((-*temp*- ,value))
|
|---|
| 739 | (setf (read-long -*dc*- (-*addr*- ,address)) -*temp*-))
|
|---|
| 740 | (%store-long ,value -*dc*- (-*addr*- ,address))))
|
|---|
| 741 |
|
|---|
| 742 | (defmacro store.p (value address &optional value-imm? &environment env)
|
|---|
| 743 | (ensure-accessing-disk-cache 'store.p env)
|
|---|
| 744 | `(-*select*-
|
|---|
| 745 | store.p
|
|---|
| 746 | (let ((-*temp*- ,value))
|
|---|
| 747 | (setf (read-pointer -*dc*- (-*addr*- ,address)
|
|---|
| 748 | ,@(if value-imm? `(,value-imm?)))
|
|---|
| 749 | -*temp*-))
|
|---|
| 750 | (%store-pointer ,value -*dc*- (-*addr*- ,address)
|
|---|
| 751 | ,@(if value-imm? `(,value-imm?)))))
|
|---|
| 752 |
|
|---|
| 753 | (defmacro store.w (value address &environment env)
|
|---|
| 754 | (ensure-accessing-disk-cache 'store.w env)
|
|---|
| 755 | `(-*select*-
|
|---|
| 756 | store.w
|
|---|
| 757 | (let ((-*temp*- ,value))
|
|---|
| 758 | (setf (read-word -*dc*- (-*addr*- ,address)) -*temp*-))
|
|---|
| 759 | (%store-word ,value -*dc*- (-*addr*- ,address))))
|
|---|
| 760 |
|
|---|
| 761 | (defmacro store.b (value address &environment env)
|
|---|
| 762 | (ensure-accessing-disk-cache 'store.b env)
|
|---|
| 763 | `(-*select*-
|
|---|
| 764 | store.b
|
|---|
| 765 | (let ((-*temp*- ,value))
|
|---|
| 766 | (setf (read-8-bits -*dc*- (-*addr*- ,address)) -*temp*-))
|
|---|
| 767 | (%store-8-bits ,value -*dc*- (-*addr*- ,address))))
|
|---|
| 768 |
|
|---|
| 769 | (defmacro store.string (string address &optional length &environment env)
|
|---|
| 770 | (ensure-accessing-disk-cache 'store.string env)
|
|---|
| 771 | `(-*select*-
|
|---|
| 772 | store.string
|
|---|
| 773 | (funcall #'(setf read-string)
|
|---|
| 774 | ,string -*dc*- (-*addr*- ,address)
|
|---|
| 775 | ,@(if length `(,length)))
|
|---|
| 776 | (%store-string ,string -*dc*- (-*addr*- ,address)
|
|---|
| 777 | ,@(if length `(,length)))))
|
|---|
| 778 |
|
|---|
| 779 | (defmacro fill.l (address value count &optional imm? &environment env)
|
|---|
| 780 | (ensure-accessing-disk-cache 'fill.l env)
|
|---|
| 781 | `(-*select*-
|
|---|
| 782 | fill.l
|
|---|
| 783 | (fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)
|
|---|
| 784 | (array-fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)))
|
|---|
| 785 |
|
|---|
| 786 | (defmacro fill.w (address value count &environment env)
|
|---|
| 787 | (ensure-accessing-disk-cache 'fill.w env)
|
|---|
| 788 | `(-*select*-
|
|---|
| 789 | fill.w
|
|---|
| 790 | (fill-word -*dc*- (-*addr*- ,address) ,value ,count)
|
|---|
| 791 | (array-fill-word -*dc*- (-*addr*- ,address) ,value ,count)))
|
|---|
| 792 |
|
|---|
| 793 | (defmacro fill.b (address value count &environment env)
|
|---|
| 794 | (ensure-accessing-disk-cache 'fill.b env)
|
|---|
| 795 | `(-*select*-
|
|---|
| 796 | fill.b
|
|---|
| 797 | (fill-byte -*dc*- (-*addr*- ,address) ,value ,count)
|
|---|
| 798 | (array-fill-byte -*dc*- (-*addr*- ,address) ,value ,count)))
|
|---|
| 799 |
|
|---|
| 800 | (defmacro svref.p (vector index &environment env)
|
|---|
| 801 | (ensure-accessing-disk-cache 'svref.p env)
|
|---|
| 802 | `(-*select*-
|
|---|
| 803 | svref.p
|
|---|
| 804 | (dc-%svref -*dc*- ,vector ,index)
|
|---|
| 805 | :error))
|
|---|
| 806 |
|
|---|
| 807 | (defmacro svset.p (vector index value &optional immediate? &environment env)
|
|---|
| 808 | (ensure-accessing-disk-cache 'svset.p env)
|
|---|
| 809 | `(-*select*-
|
|---|
| 810 | svset.p
|
|---|
| 811 | (setf (dc-%svref -*dc*- ,vector ,index ,@(if immediate? `(,immediate?)))
|
|---|
| 812 | ,value)
|
|---|
| 813 | :error))
|
|---|
| 814 |
|
|---|
| 815 | (defmacro %vector-size.p (vector &environment env)
|
|---|
| 816 | (ensure-accessing-disk-cache '%vector-size.p env)
|
|---|
| 817 | `(-*select*-
|
|---|
| 818 | %vector-size.p
|
|---|
| 819 | (dc-%vector-size -*dc*- ,vector)
|
|---|
| 820 | :error))
|
|---|
| 821 |
|
|---|
| 822 |
|
|---|
| 823 | #|
|
|---|
| 824 | (close-disk-cache dc)
|
|---|
| 825 | (setq wood::dc (wood::open-disk-cache "temp.dc"
|
|---|
| 826 | :if-exists :overwrite
|
|---|
| 827 | :if-does-not-exist :create))
|
|---|
| 828 |
|
|---|
| 829 | (defun wood::wi (&optional (count 100000))
|
|---|
| 830 | (declare (special wood::dc))
|
|---|
| 831 | (let ((index 0))
|
|---|
| 832 | (declare (fixnum index))
|
|---|
| 833 | (dotimes (i count)
|
|---|
| 834 | (setf (wood::read-long wood::dc index) i)
|
|---|
| 835 | (incf index 4))))
|
|---|
| 836 |
|
|---|
| 837 | (defun wood::ri (&optional (count 100000))
|
|---|
| 838 | (declare (special wood::dc))
|
|---|
| 839 | (let ((index 0))
|
|---|
| 840 | (declare (fixnum index))
|
|---|
| 841 | (dotimes (i count)
|
|---|
| 842 | (let ((was (wood::read-long wood::dc index)))
|
|---|
| 843 | (incf index 4)
|
|---|
| 844 | (unless (eql i was)
|
|---|
| 845 | (cerror "continue" "SB: ~d, Was: ~d" i was))))))
|
|---|
| 846 |
|
|---|
| 847 | #-ppc-target
|
|---|
| 848 | (progn
|
|---|
| 849 |
|
|---|
| 850 | (require :lapmacros)
|
|---|
| 851 |
|
|---|
| 852 | (defun time-moves (&optional (count 100))
|
|---|
| 853 | (setq count (require-type count 'fixnum))
|
|---|
| 854 | (macrolet ((moves (count)
|
|---|
| 855 | `(ccl::lap-inline (,count)
|
|---|
| 856 | (ccl::getint ccl::arg_z)
|
|---|
| 857 | (ccl::move.l (ccl::$ 0) ccl::atemp0)
|
|---|
| 858 | (ccl::dbfloop ccl::arg_z
|
|---|
| 859 | ,@(make-list 1000
|
|---|
| 860 | :initial-element
|
|---|
| 861 | '(ccl::move.l ccl::atemp0@+ ccl::da))))))
|
|---|
| 862 | (moves count)
|
|---|
| 863 | (* count 1000)))
|
|---|
| 864 |
|
|---|
| 865 | )
|
|---|
| 866 |
|
|---|
| 867 |
|
|---|
| 868 | ; Timing on a mac IIfx running System 7.0.
|
|---|
| 869 | ;
|
|---|
| 870 | ; (wi) first time: 2080 usec/long (file allocation)
|
|---|
| 871 | ; (wi) second time: 372 usec/long (read every block. write half of them)
|
|---|
| 872 | ; (ri) first time: 200 usec/long (read every block. write half of them)
|
|---|
| 873 | ; (ri) second time: 144 usec/long (read every block)
|
|---|
| 874 | ; (ri 20000) 2nd time: 66 usec/long (no disk I/O)
|
|---|
| 875 | ; (time-moves): 270 nanoseconds/long
|
|---|
| 876 |
|
|---|
| 877 | (defun wood::ws (&optional (count most-positive-fixnum) (package :ccl))
|
|---|
| 878 | (declare (special wood::dc))
|
|---|
| 879 | (let ((address 0))
|
|---|
| 880 | (do-symbols (sym package)
|
|---|
| 881 | (let* ((name (symbol-name sym))
|
|---|
| 882 | (length (length name))
|
|---|
| 883 | (rounded-length (logand -4 (+ length 3))))
|
|---|
| 884 | (setf (wood::read-long wood::dc address) (length name))
|
|---|
| 885 | (incf address 4)
|
|---|
| 886 | (setf (wood::read-string wood::dc address) name)
|
|---|
| 887 | (incf address rounded-length)
|
|---|
| 888 | (if (<= (decf count) 0) (return))))
|
|---|
| 889 | (setf (wood::read-long wood::dc address) 0)
|
|---|
| 890 | address))
|
|---|
| 891 |
|
|---|
| 892 | (defun wood::rs ()
|
|---|
| 893 | (declare (special wood::dc))
|
|---|
| 894 | (let ((address 0)
|
|---|
| 895 | (string (make-array 50 :fill-pointer t :adjustable t
|
|---|
| 896 | :element-type 'base-character)))
|
|---|
| 897 | (loop
|
|---|
| 898 | (let ((length (wood::read-long wood::dc address)))
|
|---|
| 899 | (if (eql length 0) (return))
|
|---|
| 900 | (incf address 4)
|
|---|
| 901 | (print (wood::read-string wood::dc address length string))
|
|---|
| 902 | (incf address (logand -4 (+ length 3)))))))
|
|---|
| 903 |
|
|---|
| 904 |
|
|---|
| 905 | |#
|
|---|
| 906 | ;;; 1 3/10/94 bill 1.8d247
|
|---|
| 907 | ;;; 2 10/04/94 bill 1.9d071
|
|---|
| 908 | ;;; 3 11/01/94 Derek 1.9d085 Bill's Saving Library Task
|
|---|
| 909 | ;;; 4 11/03/94 Moon 1.9d086
|
|---|
| 910 | ;;; 2 3/23/95 bill 1.11d010
|
|---|
| 911 | ;;; 3 6/02/95 bill 1.11d040
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
