close Warning: Error with navigation contributor "AccountModule"

source: trunk/disk-cache-accessors.lisp

Last change on this file was 39, checked in by gz, 4 years ago

use cl:base-char type where appropriate, as this does the right thing in both ccl (where it's equivalent to cl:character) and lispworks (where it's equivalent to lw:base-character).

assorted other minor tweaks from merging back with lispworks version.

  • Property svn:eol-style set to native
File size: 34.8 KB
Line 
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
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-char)))))
344      (loop
345        (with-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-char)))
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-disk-cache-locked (disk-cache)
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-char)))
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
Note: See TracBrowser for help on using the repository browser.