source: trunk/disk-cache-accessors.lisp @ 3

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

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

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: ccl -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; disk-cache-accessors.lisp
6;; low-level accessors for disk-cache's
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17;;
18
19;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;
21;; Modification History
22;;
23;; ------------- 0.961
24;; 09/19/96 bill The PPC version of %%load-pointer handles short floats now via %%load-short-float
25;; 09/18/96 bill Fix brain-damage in PPC versions of read-double-float and (setf read-double-float)
26;; ------------- 0.96
27;; 06/14/96 bill AlanR's fix to read-double-float
28;; ------------- 0.95
29;; 03/20/96 bill Make work in MCL-PPC
30;; ------------- 0.93
31;; 05/25/95 bill more da -> da.l changes.
32;; ------------- 0.9
33;; 03/13/95 bill byte-array-p & ensure-byte-array-p move to "block-io-mcl.lisp"
34;; 10/28/94 Moon Change without-interrupts to with-databases-locked.
35;; 10/03/94 bill (setf wood::read-8-bits) no longer fails when writing
36;;               less than 4 bytes from the end of the buffer.
37;; 09/21/94 bill without-interrupts as necessary for interlocking
38;; ------------- 0.8
39;; 08/10/93 bill eval-when around requires of lapmacros & lispequ.
40;; ------------- 0.6
41;; 12/09/92 bill fill-long, fill-word, & fill-byte return right away if (<= count 0).
42;; ------------- 0.5
43;; 07/23/92 bill array-data-and-offset -> lenient-array-data-and-offset
44;;               length -> uvector-bytes
45;;               These make the code that saves and restores non-array
46;;               ivectors (e.g. bignums, ratios, complex numbers)
47;;               work correctly.
48;; 07/20/92 bill da -> da.l where necessary.
49;; ------------  0.1
50;; 05/30/92 bill read-string & fill-xxx now skip $block-overhead
51;; 03/16/92 bill New file.
52;;
53
54(in-package :ccl)                       ; So LAP works easily
55
56(export '(wood::read-long wood::read-unsigned-long
57          wood::read-string wood::read-pointer
58          wood::read-low-24-bits wood::read-8-bits
59          wood::fill-long wood::fill-word wood::fill-byte)
60        'wood)
61
62(eval-when (:compile-toplevel :execute)
63  #-ppc-target
64  (require :lapmacros)
65  (require :lispequ))
66
67#+ppc-target
68(progn
69
70(declaim (inline %%load-long %%load-unsigned-long))
71
72(defun %%load-long (array address)
73  (declare (type (simple-array (unsigned-byte 16) (*)) array)
74           (fixnum address)
75           (optimize (speed 3) (safety 0)))
76  (let* ((index (ash address -1))
77         (high-word (aref array index))
78         (low-word (aref array (the fixnum (1+ index)))))
79    (declare (fixnum index high-word low-word))
80    (if (logbitp 15 high-word)
81      (progn
82        (setq high-word (- high-word (expt 2 16)))
83        (if (>= high-word (- (expt 2 (- 15 ppc::fixnum-shift))))
84          (the fixnum
85            (+ (the fixnum (ash high-word 16)) low-word))
86          (+ (ash high-word 16) low-word)))
87      (if (< high-word (expt 2 (- 15 ppc::fixnum-shift)))
88        (the fixnum
89          (+ (the fixnum (ash high-word 16)) low-word))
90        (+ (ash high-word 16) low-word)))))
91
92(defun %%load-unsigned-long (array address)
93  (declare (type (simple-array (unsigned-byte 16) (*)) array)
94           (fixnum address)
95           (optimize (speed 3) (safety 0)))
96  (let* ((index (ash address -1))
97         (high-word (aref array index))
98         (low-word (aref array (the fixnum (1+ index)))))
99    (declare (fixnum index high-word low-word))
100    (if (< high-word (expt 2 (- 15 ppc::fixnum-shift)))
101      (the fixnum
102        (+ (the fixnum (ash high-word 16)) low-word))
103      (+ (ash high-word 16) low-word))))
104
105)  ; end of #+ppc-target progn
106
107(defun wood::read-long (disk-cache address)
108  (wood::with-databases-locked
109   (multiple-value-bind (array index count)
110                        (wood::get-disk-page disk-cache address)
111     (declare (fixnum index count))
112     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
113       (error "Address odd or past eof: ~s" address))
114     #-ppc-target
115     (lap-inline ()
116       (:variable array index)
117       (move.l (varg array) atemp0)
118       (move.l (varg index) da)
119       (getint da)
120       (move.l (atemp0 da.l $v_data) arg_z)
121       (jsr_subprim $sp-mklong))
122     #+ppc-target
123     (%%load-long array index))))
124
125(defmacro check-byte-array-address (address size array)
126  (let ((addr (gensym)))
127    `(let ((,addr ,address))
128       (unless (and (<= 0 ,addr)
129                    ,(if (eql size 1)
130                       `(< ,addr (length ,array))
131                       `(<= (the fixnum (+ ,addr ,size)) (length ,array))))
132         (error "Attempt to access outside of buffer bounds")))))
133
134(defun wood::%load-long (array address)
135  (ensure-byte-array array)
136  (unless (fixnump address)
137    (setq address (require-type address 'fixnum)))
138  (locally (declare (fixnum address))
139    (check-byte-array-address address 4 array)
140    (unless (eql 0 (the fixnum (logand 1 address)))
141      (error "Odd address: ~s" address))
142    #-ppc-target
143    (lap-inline ()
144      (:variable array address immediate?)
145      (move.l (varg array) atemp0)
146      (move.l (varg address) da)
147      (getint da)
148      (move.l (atemp0 da.l $v_data) arg_z)
149      (jsr_subprim $sp-mklong))
150    #+ppc-target
151    (%%load-long array address)))
152
153(defun wood::read-unsigned-long (disk-cache address)
154  (wood::with-databases-locked
155   (multiple-value-bind (array index count)
156                        (wood::get-disk-page disk-cache address)
157     (declare (fixnum index count))
158     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
159       (error "Address odd or past eof: ~s" address))
160     #-ppc-target
161     (lap-inline ()
162       (:variable array index)
163       (move.l (varg array) atemp0)
164       (move.l (varg index) da)
165       (getint da)
166       (move.l (atemp0 da.l $v_data) arg_z)
167       (jsr_subprim $sp-mkulong))
168     #+ppc-target
169     (%%load-unsigned-long array index))))
170
171(defun wood::%load-unsigned-long (array address)
172  (ensure-byte-array array)
173  (setq address (require-type address 'fixnum))
174  (locally (declare (fixnum address))
175    (check-byte-array-address address 4 array)
176    (unless (eql 0 (the fixnum (logand 1 address)))
177      (error "Odd address: ~s" address))
178    #-ppc-target
179    (lap-inline ()
180      (:variable array address)
181      (move.l (varg array) atemp0)
182      (move.l (varg address) da)
183      (getint da)
184      (move.l (atemp0 da.l $v_data) arg_z)
185      (jsr_subprim $sp-mkulong))
186    #+ppc-target
187    (%%load-unsigned-long array address)))
188
189#+ppc-target
190(progn
191
192(declaim (inline %%store-long))
193
194(defun %%store-long (value array address)
195  (declare (type (simple-array (unsigned-byte 16) (*)) array)
196           (fixnum address)
197           (optimize (speed 3) (safety 0)))
198  (let ((index (ash address -1))
199        (low-word 0)
200        (high-word 0))
201    (if (fixnump value)
202      (locally (declare (fixnum low-word high-word address))
203        (setq low-word (logand value #xffff)
204              high-word (ash value -16)))
205      (setq low-word (logand value #xffff)
206            high-word (ash value -16)))
207    (setf (aref array index) high-word
208          (aref array (the fixnum (1+ index))) low-word))
209  value)
210
211)  ; end of #+ppc-target progn
212
213(defun (setf wood::read-long) (value disk-cache address)
214  (unless (>= (wood::disk-cache-size disk-cache)
215              (+ address 4))
216    (wood::extend-disk-cache disk-cache (+ address 4)))
217  (wood::with-databases-locked
218   (multiple-value-bind (array index count)
219                        (wood::get-disk-page disk-cache address t)
220     (declare (fixnum index count))
221     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
222       (error "Address odd or past eof: ~s" address))
223     #-ppc-target
224     (lap-inline ()
225       (:variable array index value)
226       (move.l (varg value) arg_z)
227       (jsr_subprim $sp-getxlong)
228       (move.l (varg array) atemp0)
229       (move.l (varg index) da)
230       (getint da)
231       (move.l acc (atemp0 da.l $v_data)))
232     #+ppc-target
233     (%%store-long value array index)))
234  value)
235
236(defsetf wood::read-unsigned-long (disk-cache address) (value)
237  `(setf (wood::read-long ,disk-cache ,address) ,value))
238
239(defun wood::%store-long (value array address)
240  (ensure-byte-array array)
241  (setq address (require-type address 'fixnum))
242  (locally (declare (fixnum address))
243    (check-byte-array-address address 4 array)
244    (unless (eql 0 (the fixnum (logand 1 address)))
245      (error "Odd address: ~s" address))
246    #-ppc-target
247    (lap-inline ()
248      (:variable array address value)
249        (move.l (varg value) arg_z)
250        (jsr_subprim $sp-getxlong)
251        (move.l (varg array) atemp0)
252        (move.l (varg address) da)
253        (getint da)
254        (move.l acc (atemp0 da.l $v_data)))
255    #+ppc-target
256    (%%store-long value array address))
257  value)
258
259(defun wood::read-word (disk-cache address)
260  (wood::with-databases-locked
261   (multiple-value-bind (array index count)
262                        (wood::get-disk-page disk-cache address)
263     (declare (fixnum index count))
264     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
265       (error "Address odd or past eof: ~s" address))
266     #-ppc-target
267     (lap-inline ()
268       (:variable array index)
269       (move.l (varg array) atemp0)
270       (move.l (varg index) da)
271       (getint da)
272       (move.w (atemp0 da.l $v_data) acc)
273       (ext.l acc)
274       (mkint acc))
275     #+ppc-target
276     (locally (declare (type (simple-array (signed-byte 16)  (*)) array)
277                       (optimize (speed 3) (safety 0)))
278       (setq index (ash index -1))
279       (aref array index)))))
280
281(defun wood::%load-word (array address)
282  (ensure-byte-array array)
283  (setq address (require-type address 'fixnum))
284  (locally (declare (fixnum address))
285    (check-byte-array-address address 2 array)
286    (unless (eql 0 (the fixnum (logand 1 address)))
287      (error "Odd address: ~s" address))
288    #-ppc-target
289    (lap-inline ()
290      (:variable array address)
291      (move.l (varg array) atemp0)
292      (move.l (varg address) da)
293      (getint da)
294      (move.w (atemp0 da.l $v_data) acc)
295      (ext.l acc)
296      (mkint acc))
297    #+ppc-target
298    (locally (declare (type (simple-array (signed-byte 16)  (*)) array)
299                       (optimize (speed 3) (safety 0)))
300       (setq address (ash address -1))
301       (aref array address))))
302
303(defun wood::read-unsigned-word (disk-cache address)
304  (wood::with-databases-locked
305   (multiple-value-bind (array index count)
306                        (wood::get-disk-page disk-cache address)
307     (declare (fixnum index count))
308     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
309       (error "Address odd or past eof: ~s" address))
310     #-ppc-target
311     (lap-inline ()
312       (:variable array index)
313       (move.l (varg array) atemp0)
314       (move.l (varg index) da)
315       (getint da)
316       (move.l ($ 0) acc)
317       (move.w (atemp0 da.l $v_data) acc)
318       (mkint acc))
319     #+ppc-target
320     (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array)
321                       (optimize (speed 3) (safety 0)))
322       (setq index (ash index -1))
323       (aref array index)))))
324
325(defun wood::%load-unsigned-word (array address)
326  (ensure-byte-array array)
327  (setq address (require-type address 'fixnum))
328  (locally (declare (fixnum address))
329    (check-byte-array-address address 2 array)
330    (unless (eql 0 (the fixnum (logand 1 address)))
331      (error "Odd address: ~s" address))
332    #-ppc-target
333    (lap-inline ()
334      (:variable array address)
335      (move.l (varg array) atemp0)
336      (move.l (varg address) da)
337      (getint da)
338      (move.l ($ 0) acc)
339      (move.w (atemp0 da.l $v_data) acc)
340      (mkint acc))
341    #+ppc-target
342    (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array)
343                      (optimize (speed 3) (safety 0)))
344      (setq address (ash address -1))
345      (aref array address))))
346
347(defun (setf wood::read-word) (value disk-cache address)
348  (setq value (require-type value 'fixnum))
349  (unless (>= (wood::disk-cache-size disk-cache)
350              (+ address 4))
351    (wood::extend-disk-cache disk-cache (+ address 4)))
352  (wood::with-databases-locked
353   (multiple-value-bind (array index count)
354                        (wood::get-disk-page disk-cache address t)
355     (declare (fixnum index count))
356     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
357       (error "Odd address: ~s" address))
358     #-ppc-target
359     (lap-inline ()
360       (:variable array index value)
361       (move.l (varg value) acc)
362       (getint acc)
363       (move.l (varg array) atemp0)
364       (move.l (varg index) da)
365       (getint da)
366       (move.w acc (atemp0 da.l $v_data))
367       (mkint acc))
368     #+ppc-target
369     (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array)
370                       (optimize (speed 3) (safety 0)))
371       (setq index (ash index -1))
372       (setf (aref array index) value)))))
373
374(defsetf wood::read-unsigned-word (disk-cache address) (value)
375  `(setf (wood::read-word ,disk-cache ,address) ,value))
376
377(defun wood::%store-word (value array address)
378  (ensure-byte-array array)
379  (setq address (require-type address 'fixnum))
380  (locally (declare (fixnum address))
381    (check-byte-array-address address 2 array)
382    (unless (eql 0 (the fixnum (logand 1 address)))
383      (error "Address not word aligned: ~s" address))
384    #-ppc-target
385    (lap-inline ()
386      (:variable value array address)
387      (move.l (varg array) atemp0)
388      (move.l (varg address) da)
389      (getint da)
390      (move.l (varg value) acc)
391      (getint acc)
392      (move.w acc (atemp0 da.l $v_data))
393      (mkint acc))
394    #+ppc-target
395    (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array)
396                      (optimize (speed 3) (safety 0)))
397      (setq address (ash address -1))
398      (setf (aref array address) value))))
399
400
401(declaim (inline wood::%%load-pointer wood::%%store-pointer))
402
403; same as %load-pointer, but does no type checking
404#-ppc-target
405(defun wood::%%load-pointer (array address)
406  (let (immediate?)
407    (values
408     (lap-inline ()
409       (:variable array address immediate?)
410       (move.l (varg array) atemp0)
411       (move.l (varg address) da)
412       (getint da)
413       (move.l (atemp0 da.l $v_data) arg_z)
414       (if# (ne (dtagp arg_z $t_fixnum $t_imm $t_sfloat))
415         (movereg arg_z acc)
416         (move.l '1 (varg immediate?))
417         else#
418         (jsr_subprim $sp-mkulong)))
419     immediate?)))
420
421; Same as %store-pointer, but doesn't type check
422#-ppc-target
423(defun wood::%%store-pointer (value array address &optional immediate?)
424  (lap-inline ()
425    (:variable array address value immediate?)
426    (move.l (varg value) arg_z)
427    (if# (eq (cmp.l (varg immediate?) nilreg))
428      (jsr_subprim $sp-getxlong))
429    (move.l (varg array) atemp0)
430    (move.l (varg address) da)
431    (getint da)
432    (move.l acc (atemp0 da.l $v_data))))
433
434#+ppc-target
435(progn
436
437; Load a Wood fixnum returning a lisp fixnum
438(defppclapfunction wood::%%load-fixnum ((array arg_y) (address arg_z))
439  (unbox-fixnum imm0 address)
440  (la imm0 ppc::misc-data-offset imm0)
441  (lwzx imm0 imm0 array)
442  (srawi imm0 imm0 3)
443  (box-fixnum arg_z imm0)
444  (blr))
445
446(defppclapfunction wood::%%store-fixnum ((value arg_x) (array arg_y) (address arg_z))
447  (unbox-fixnum imm0 address)
448  (la imm0 ppc::misc-data-offset imm0)
449  (slwi imm1 value (- 3 ppc::fixnum-shift))
450  (stwx imm1 imm0 array)
451  (mr arg_z arg_x)
452  (blr))
453
454; Load a Wood character returning a lisp character
455(defppclapfunction wood::%%load-character ((array arg_y) (address arg_z))
456  (unbox-fixnum imm0 address)
457  (la imm0 ppc::misc-data-offset imm0)
458  (lwzx imm0 imm0 array)
459  (li arg_z ppc::subtag-character)
460  (rlwimi arg_z imm0 0 0 15)
461  (blr))
462
463(defppclapfunction wood::%%store-character ((value arg_x) (array arg_y) (address arg_z))
464  (unbox-fixnum imm0 address)
465  (la imm0 ppc::misc-data-offset imm0)
466  (li imm1 $t_imm_char)
467  (rlwimi imm1 value 0 0 15)
468  (stwx imm1 imm0 array)
469  (mr arg_z arg_x)
470  (blr))
471
472(defun wood::%%load-pointer (array address)
473  (declare (optimize (speed 3) (safety 0))
474           (fixnum address))
475  (let* ((tag-byte
476          (locally (declare (type (simple-array (unsigned-byte 8) (*)) array)
477                            (optimize (speed 3) (safety 0)))
478            (aref array (the fixnum (+ address 3)))))
479         (tag (logand tag-byte 7)))
480    (declare (fixnum tag-byte tag))
481    (case tag
482      (#.wood::$t_fixnum
483       (values (wood::%%load-fixnum array address) t))
484      (#.wood::$t_imm
485       (values
486        (ecase tag-byte
487          (#.$undefined (%unbound-marker-8))
488          (#.$illegal (%illegal-marker))
489          (#.$t_imm_char (wood::%%load-character array address)))
490        t))
491      (#.wood::$t_sfloat
492       (values (wood::%%load-short-float array address) t))
493      (t (%%load-unsigned-long array address)))))
494
495(defun wood::%%load-short-float (array address)
496  (declare (fixnum address)
497           (type (simple-array (unsigned-byte 8) (*)) array)
498           (optimize (speed 3) (safety 0)))
499  (let* ((tag-byte (aref array (the fixnum (+ address 3))))
500         (expt-byte (aref array address))
501         (expt-bits (ash expt-byte -3))    ; 5 bits of exponent
502         (expt (+ expt-bits
503                  (the fixnum
504                    (if (logbitp 4 expt-bits)
505                      (- (ash 3 5) #x7f)
506                      (- (ash 4 5) #x7f)))))
507         (normalized-expt (+ expt #x3ff))
508         (byte-1 (aref array (the fixnum (+ address 1))))
509         (byte-2 (aref array (the fixnum (+ address 2))))
510         (mantissa (+ (the fixnum (ash tag-byte -4))
511                      (the fixnum (ash byte-2 4))
512                      (the fixnum (ash byte-1 12))
513                      (the fixnum (ash (the fixnum (logand expt-byte 7)) 20))))
514         (negative (logbitp 3 tag-byte))
515         (word-0 (+ (the fixnum (ash normalized-expt 4))
516                    (the fixnum (ash mantissa -19))))
517         (word-1 (logand (the fixnum (ash mantissa -3)) #xffff))
518         (word-2 (ash (logand mantissa 7) 13))
519         (res (%copy-float 0.0)))
520    (declare (type fixnum tag-byte expt-byte expt-bits expt normalized-expt byte-1 byte-2 mantissa
521                   word-0 word-1 word-2)
522             (type (simple-array (unsigned-byte 16) (*)) res)       ; lie
523             )
524    (when negative
525      (incf word-0 #x8000))
526    ;(print-db word-0 word-1 word-2)
527    (setf (aref res 2) word-0
528          (aref res 3) word-1
529          (aref res 4) word-2
530          (aref res 5) 0)
531    res))
532
533(defun wood::%%store-pointer (value array address &optional imm?)
534  (cond ((not imm?)
535         (%%store-long value array address))
536        ((fixnump value) (wood::%%store-fixnum value array address))
537        ((characterp value) (wood::%%store-character value array address))
538        ((eq value (%unbound-marker-8))
539         (%%store-long $undefined array address))
540        ((eq value (%illegal-marker))
541         (%%store-long $illegal array address))
542        (t (error "~s is not a valid immediate" value)))
543  value)
544
545)  ; end of #+ppc-target progn
546
547; Avoid consing bignums by not boxing immediate data from the file.
548; Second value is true if the result was immediate.
549(defun wood::read-pointer (disk-cache address)
550  (wood::with-databases-locked
551   (multiple-value-bind (array index count)
552                        (wood::get-disk-page disk-cache address)
553     (declare (fixnum index count))
554     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
555       (error "Address odd or past eof: ~s" address))
556     (wood::%%load-pointer array index))))
557
558; load directly from a byte array.
559(defun wood::%load-pointer (array address)
560  (ensure-byte-array array)
561  (setq address (require-type address 'fixnum))
562  (locally (declare (fixnum address))
563    (check-byte-array-address address 4 array)
564    (unless (eql 0 (the fixnum (logand 1 address)))
565      (error "Odd address: ~s" address))
566    (wood::%%load-pointer array address)))
567
568(defun (setf wood::read-pointer) (value disk-cache address &optional immediate?)
569  (unless (>= (wood::disk-cache-size disk-cache)
570              (+ address 4))
571    (wood::extend-disk-cache disk-cache (+ address 4)))
572  (wood::with-databases-locked
573   (multiple-value-bind (array index count)
574                        (wood::get-disk-page disk-cache address t)
575     (declare (fixnum index count))
576     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
577       (error "Address odd or past eof: ~s" address))
578     (wood::%%store-pointer value array index immediate?)))
579  value)
580
581(defun wood::%store-pointer (value array address &optional immediate?)
582  (ensure-byte-array array)
583  (setq address (require-type address 'fixnum))
584  (locally (declare (fixnum address))
585    (check-byte-array-address address 4 array)
586    (unless (eql 0 (the fixnum (logand 1 address)))
587      (error "Odd address: ~s" address))
588    (wood::%%store-pointer value array address immediate?))
589  value)
590
591(declaim (inline wood::%%load-low-24-bits %%store-low-24-bits))
592
593(defun wood::%%load-low-24-bits (array index)
594  (declare (optimize (speed 3) (safety 0))
595           (fixnum index))
596  (let* ((word-index (ash index -1))
597         (low-word
598          (locally (declare (type (simple-array (unsigned-byte 16) (*)) array))
599            (aref array (the fixnum (1+ word-index)))))
600         (high-word
601          (locally (declare (type (simple-array (unsigned-byte 8) (*)) array))
602            (aref array (the fixnum (1+ index))))))
603    (declare (fixnum word-index low-word high-word))
604    (the fixnum
605      (+ (the fixnum (ash high-word 16)) low-word))))
606
607(defun wood::%%store-low-24-bits (value array index)
608  (declare (optimize (speed 3) (safety 0))
609           (fixnum value index))
610  (let* ((word-index (ash index -1))
611         (low-word (logand value #xffff))
612         (high-word (ash value -16)))
613    (declare (fixnum word-index low-word high-word))
614    (locally (declare (type (simple-array (unsigned-byte 16) (*)) array))
615      (setf (aref array (the fixnum (1+ word-index))) low-word))
616    (locally (declare (type (simple-array (unsigned-byte 8) (*)) array))
617      (setf (aref array (the fixnum (1+ index))) high-word)))
618  value)
619
620(defun wood::read-low-24-bits (disk-cache address)
621  (wood::with-databases-locked
622   (multiple-value-bind (array index count)
623                        (wood::get-disk-page disk-cache address)
624     (declare (fixnum index count))
625     (unless (>= count 4)
626       (error "Address past eof or not longword aligned: ~s" address))
627     (wood::%%load-low-24-bits array index))))
628
629(defun (setf wood::read-low-24-bits) (value disk-cache address)
630  (unless (fixnump value)
631    (setq value (require-type value 'fixnum)))
632  (unless (>= (wood::disk-cache-size disk-cache)
633              (+ address 4))
634    (wood::extend-disk-cache disk-cache (+ address 4)))
635  (wood::with-databases-locked
636   (multiple-value-bind (array index count)
637                        (wood::get-disk-page disk-cache address t)
638     (declare (fixnum index count))
639     (unless (>= count 4)
640       (error "Address not longword aligned: ~s" address))
641     (wood::%%store-low-24-bits value array index)))
642  value)
643
644; Read an unsigned byte. Can't call it read-byte as Common Lisp
645; already exports that symbol
646(defun wood::read-8-bits (disk-cache address)
647  (wood::with-databases-locked
648   (multiple-value-bind (array index count)
649                        (wood::get-disk-page disk-cache address)
650     (declare (fixnum index count)
651              (type (simple-array (unsigned-byte 8) (*)) array)
652              (optimize (speed 3) (safety 0)))
653     (unless (>= count 1)
654       (error "Address past eof"))
655     (aref array index))))
656
657(defun wood::read-8-bits-signed (disk-cache address)
658  (wood::with-databases-locked
659   (multiple-value-bind (array index count)
660                        (wood::get-disk-page disk-cache address)
661     (declare (fixnum index count)
662              (type (simple-array (signed-byte 8) (*)) array)
663              (optimize (speed 3) (safety 0)))
664     (unless (>= count 1)
665       (error "Address past eof"))
666     (aref array index))))
667
668(defun wood::%load-8-bits (array address)
669  (ensure-byte-array array)
670  (setq address (require-type address 'fixnum))
671  (locally (declare (fixnum address)
672                    (type (simple-array (unsigned-byte 8) (*)) array)
673                    (optimize (speed 3) (safety 0)))
674    (check-byte-array-address address 1 array)
675    (aref array address)))
676
677(defun (setf wood::read-8-bits) (value disk-cache address)
678  (unless (>= (wood::disk-cache-size disk-cache)
679              (+ address 4))
680    (wood::extend-disk-cache disk-cache (+ address 4)))
681  (wood::with-databases-locked
682   (multiple-value-bind (array index count)
683                        (wood::get-disk-page disk-cache address t)
684     (declare (fixnum index count)
685              (type (simple-array (unsigned-byte 8) (*)) array)
686              (optimize (speed 3) (safety 0)))
687     (unless (>= count 1)
688       (error "Address past eof"))
689     (setf (aref array index) value))))
690
691(defsetf wood::read-8-bits-signed (disk-cache address) (value)
692  `(setf (wood::read-8-bits ,disk-cache ,address) ,value))
693
694(defun wood::%store-8-bits (value array address)
695  (ensure-byte-array array)
696  (setq address (require-type address 'fixnum))
697  (locally (declare (fixnum address)
698                    (type (simple-array (unsigned-byte 8) (*)) array)
699                    (optimize (speed 3) (safety 0)))
700    (check-byte-array-address address 1 array)
701    (setf (aref array address) value)))
702
703; These will get less ugly when we can stack cons float vectors
704#-ppc-target
705(defun wood::read-double-float (disk-cache address)
706  (let ((vector (make-array 2 :element-type '(signed-byte 32))))
707    (declare (dynamic-extent vector))
708    (wood::load-byte-array disk-cache address 8 vector 0 t)
709    (ccl::%typed-uvref ccl::$v_floatv vector 0)))
710
711#+ppc-target
712(defun wood::read-double-float (disk-cache address)
713  (let ((float (%copy-float 0.0)))
714    (wood::load-byte-array disk-cache address 8 float 4 t)
715    float))
716
717#-ppc-target
718(defun (setf wood::read-double-float) (value disk-cache address)
719  (let ((vector (make-array 2 :element-type '(signed-byte 32))))
720    (declare (dynamic-extent vector))
721    (ccl::%typed-uvset ccl::$v_floatv vector 0 value)
722    (wood::store-byte-array vector disk-cache address 8 0 t))
723  value)
724
725#+ppc-target
726(defun (setf wood::read-double-float) (value disk-cache address)
727  (unless (typep value 'double-float)
728    (setq value (require-type value 'double-float)))
729  (wood::store-byte-array value disk-cache address 8 4 t)
730  value)
731
732(defun wood::read-string (disk-cache address length &optional string)
733  (setq length (require-type length 'fixnum))
734  (locally (declare (fixnum length))
735    (when (> (+ address length) (wood::disk-cache-size disk-cache))
736      (error "Attempt to read past EOF"))
737    (let ((offset 0)
738          inner-string)
739      (declare (fixnum offset))
740      (cond ((and string
741                  (progn
742                    (setq string (require-type string 'string))
743                    (array-has-fill-pointer-p string)))
744             (if (> length (array-total-size string))
745               (setq string (adjust-array string length))
746               (setf (fill-pointer string) length))
747             (multiple-value-setq (inner-string offset)
748               (array-data-and-offset string)))
749            (string
750             (unless (>= (length string) length)
751               (error "~s is < ~s characters long" string length))
752             (multiple-value-setq (inner-string offset)
753               (array-data-and-offset string)))
754            (t (setq inner-string
755                     (setq string (make-string length :element-type 'base-character)))))
756      (loop
757        (wood::with-databases-locked
758         (multiple-value-bind (array index count)
759                              (wood::get-disk-page disk-cache address)
760           (declare (fixnum count index))
761           #-ppc-target
762           (lap-inline ()
763             (:variable array index count length inner-string offset)
764             (move.l (varg array) atemp0)
765             (move.l (varg index) da)
766             (getint da)
767             (lea (atemp0 da.l $v_data) atemp0)
768             (move.l (varg inner-string) atemp1)
769             (move.l (varg offset) da)
770             (getint da)
771             (lea (atemp1 da.l $v_data) atemp1)
772             (move.l (varg length) da)
773             (if# (gt (cmp.l (varg count) da))
774               (move.l (varg count) da))
775             (getint da)
776             (dbfloop.l da
777                     (move.b atemp0@+ atemp1@+)))
778           #+ppc-target
779           (%copy-ivector-to-ivector
780            array index inner-string offset
781            (if (< count length) count length))
782           (when (<= (decf length count) 0)
783             (return))
784           (incf address (the fixnum (+ count wood::$block-overhead)))
785           (incf offset count))))))
786  string)
787
788; Same as array-data-and-offset but works for
789; non-array uvectors.
790(defun lenient-array-data-and-offset (array)
791  (if #-ppc-target (eql $v_arrayh (%vect-subtype array))
792      #+ppc-target (let ((typecode (ppc-typecode array)))
793                     (declare (fixnum typecode))
794                     (or (eql typecode ppc::subtag-arrayh)
795                         (eql typecode ppc::subtag-vectorh)))
796    (array-data-and-offset array)
797    (values array 0)))
798
799#-ppc-target
800(defun uvector-bytes (uvector)
801  (lap-inline (uvector)
802    (if# (eq (dtagp arg_z $t_vector))
803      (wtaerr arg_z 'uvector))
804    (move.l arg_z atemp0)
805    (vsize atemp0 arg_z)
806    (mkint arg_z)))
807
808#+ppc-target
809(defun uvector-bytes (uvector)
810  (let* ((typecode (ppc-typecode uvector))
811         (typecode-tag (logand typecode ppc::fulltagmask))
812         (length (uvsize uvector)))
813    (declare (fixnum typecode t typecode-tag))
814    (if (eql typecode-tag ppc::fulltag-immheader)
815       (ppc-subtag-bytes typecode length)
816       (ash length 2))))
817
818(defun wood::load-byte-array (disk-cache address length byte-array &optional
819                                         (start 0) trust-me?)
820  (setq length (require-type length 'fixnum))
821  (setq start (require-type start 'fixnum))
822  (locally (declare (fixnum length))
823    (when (> (+ address length) (wood::disk-cache-size disk-cache))
824      (error "Attempt to read past EOF"))
825    (multiple-value-bind (inner-array offset)
826                         (lenient-array-data-and-offset byte-array)
827      (unless trust-me?                 ; for p-load-ivector
828        (ensure-byte-array byte-array)
829        (if (> (+ start length) (uvector-bytes byte-array))
830          (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length))))
831      (incf offset start)
832      (loop
833        (wood::with-databases-locked
834         (multiple-value-bind (array index count)
835                              (wood::get-disk-page disk-cache address)
836           (declare (fixnum count index))
837           #-ppc-target
838           (lap-inline ()
839             (:variable array index count length inner-array offset)
840             (move.l (varg array) atemp0)
841             (move.l (varg index) da)
842             (getint da)
843             (lea (atemp0 da.l $v_data) atemp0)
844             (move.l (varg inner-array) atemp1)
845             (move.l (varg offset) da)
846             (getint da)
847             (lea (atemp1 da.l $v_data) atemp1)
848             (move.l (varg length) da)
849             (if# (gt (cmp.l (varg count) da))
850               (move.l (varg count) da))
851             (getint da)
852             (dbfloop.l da
853                     (move.b atemp0@+ atemp1@+)))
854           #+ppc-target
855           (%copy-ivector-to-ivector
856            array index inner-array offset
857            (if (< count length) count length))
858           (when (<= (decf length count) 0)
859             (return))
860           (incf address (the fixnum (+ count wood::$block-overhead)))
861           (incf offset count))))))
862  byte-array)
863
864; Copy length bytes from from at from-index to to at to-index.
865; from-index, length, and to-index must be fixnums
866; if (eq from to), the copying will be done in the correct order.
867; If either array is not a byte array or string, you will likely crash
868; sometime in the future.
869(defun wood::%copy-byte-array-portion (from from-index length to to-index &optional to-page)
870  (declare (ignore to-page))            ; for logging/recovery
871  (setq from-index (require-type from-index 'fixnum))
872  (setq length (require-type length 'fixnum))
873  (setq to-index (require-type to-index 'fixnum))
874  (locally (declare (fixnum from-index length to-index))
875    (when (> length 0)
876      (unless (and (>= from-index 0)
877                   (<= (the fixnum (+ from-index length)) (uvector-bytes from))
878                   (>= to-index 0)
879                   (<= (the fixnum (+ to-index length)) (uvector-bytes to)))
880        (error "Attempt to index off end of one of the arrays"))
881      (multiple-value-bind (from off) (lenient-array-data-and-offset from)
882        (incf from-index off)
883        (multiple-value-bind (to off) (lenient-array-data-and-offset to)
884          (incf to-index off)
885          (ensure-byte-array from)
886          (ensure-byte-array to)
887          #-ppc-target
888          (lap-inline ()
889            (:variable from from-index length to to-index)
890            (move.l (varg from) atemp0)
891            (move.l atemp0 arg_x)             ; arg_x = from
892            (move.l (varg from-index) da)
893            (getint da)
894            (move.l da arg_y)                 ; arg_y = from-index
895            (lea (atemp0 da.l $v_data) atemp0)
896            (move.l (varg to) atemp1)
897            (move.l atemp1 arg_z)             ; arg_z = to
898            (move.l (varg to-index) da)
899            (getint da)
900            (move.l da db)                    ; db = to-index
901            (lea (atemp1 da.l $v_data) atemp1)
902            (move.l (varg length) da)
903            (getint da)
904            ; _BlockMove is slower for small moves
905            (if# (gt (cmp.l ($ 128) da))
906              (move.l da acc)
907              (dc.w #_BlockMove)
908              else#
909              (if# (and (eq (cmp.l arg_x arg_z))
910                        (gt (cmp.l arg_y db)))
911                (add.l da atemp0)
912                (add.l da atemp1)
913                (dbfloop.l da
914                        (move.b -@atemp0 -@atemp1))
915                else#
916                (dbfloop.l da
917                        (move.b atemp0@+ atemp1@+)))))
918          #+ppc-target
919          (%copy-ivector-to-ivector
920           from from-index to to-index length)))))
921  to)
922
923(defun wood::%load-string (array index length &optional string)
924  (unless string
925    (setq string (make-string length :element-type 'base-character)))
926  (wood::%copy-byte-array-portion array index length string 0))
927
928(defun wood::%store-string (string array index &optional (length (length string)))
929  (wood::%copy-byte-array-portion string 0 length array index)
930  string)
931 
932(defun (setf wood::read-string) (string disk-cache address &optional length)
933  (if length
934    (when (> (setq length (require-type length 'fixnum)) (length string))
935      (error "~s > the length of the string." 'length))
936    (setq length (length string)))
937  (unless (>= (wood::disk-cache-size disk-cache)
938              (+ address length))
939    (wood::extend-disk-cache disk-cache (+ address length)))
940  (multiple-value-bind (string offset) (array-data-and-offset string)
941    (declare (fixnum offset))
942    (loop
943      (wood::with-databases-locked
944       (multiple-value-bind (array index count)
945                            (wood::get-disk-page disk-cache address t)
946         (declare (fixnum count index))
947         #-ppc-target
948         (lap-inline ()
949           (:variable array index count length string offset)
950           (move.l (varg array) atemp0)
951           (move.l (varg index) da)
952           (getint da)
953           (lea (atemp0 da.l $v_data) atemp0)
954           (move.l (varg string) atemp1)
955           (move.l (varg offset) da)
956           (getint da)
957           (lea (atemp1 da.l $v_data) atemp1)
958           (move.l (varg length) da)
959           (if# (gt (cmp.l (varg count) da))
960             (move.l (varg count) da))
961           (getint da)
962           (dbfloop.l da
963                   (move.b atemp1@+ atemp0@+)))
964         #+ppc-target
965         (%copy-ivector-to-ivector
966          string offset array index
967          (if (< count length) count length))
968         (when (<= (decf length count) 0)
969           (return))
970         (incf address (the fixnum (+ count wood::$block-overhead)))
971         (incf offset count)))))
972  string)
973
974(defun wood::store-byte-array (byte-array disk-cache address length &optional
975                                          (start 0) trust-me?)
976  (setq length (require-type length 'fixnum))
977  (setq start (require-type start 'fixnum))
978  (locally (declare (fixnum length))
979    (when (> (+ address length) (wood::disk-cache-size disk-cache))
980      (error "Attempt to read past EOF"))
981    (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset byte-array)
982      (unless trust-me?                 ; for p-load-ivector
983        (ensure-byte-array byte-array)
984        (if (> (+ start length) (uvector-bytes byte-array))
985          (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length))))
986      (incf offset start)
987      (loop
988        (wood::with-databases-locked
989         (multiple-value-bind (array index count)
990                              (wood::get-disk-page disk-cache address t)
991           (declare (fixnum count index))
992           #-ppc-target
993           (lap-inline ()
994             (:variable array index count length inner-array offset)
995             (move.l (varg array) atemp0)
996             (move.l (varg index) da)
997             (getint da)
998             (lea (atemp0 da.l $v_data) atemp0)
999             (move.l (varg inner-array) atemp1)
1000             (move.l (varg offset) da)
1001             (getint da)
1002             (lea (atemp1 da.l $v_data) atemp1)
1003             (move.l (varg length) da)
1004             (if# (gt (cmp.l (varg count) da))
1005               (move.l (varg count) da))
1006             (getint da)
1007             (dbfloop.l da
1008                     (move.b atemp1@+ atemp0@+)))
1009           #+ppc-target
1010           (%copy-ivector-to-ivector
1011            inner-array offset array index
1012            (if (< count length) count length))
1013           (when (<= (decf length count) 0)
1014             (return))
1015           (incf address (the fixnum (+ count wood::$block-overhead)))
1016           (incf offset count))))))
1017  byte-array)
1018
1019(defun wood::fill-long (disk-cache address value count &optional immediate?)
1020  (let ((count (require-type count 'fixnum)))
1021    (declare (fixnum count))
1022    (unless (eql 0 (logand 1 address))
1023      (error "Odd address: ~s" address))
1024    (when (<= count 0) (return-from wood::fill-long) nil)
1025    (let ((min-size (+ address (ash count 2))))
1026      (when (< (wood::disk-cache-size disk-cache) min-size)
1027        (wood::extend-disk-cache disk-cache min-size)))
1028    (loop
1029      (wood::with-databases-locked
1030       (multiple-value-bind (vector offset size)
1031                            (wood::get-disk-page disk-cache address t)
1032         (declare (fixnum offset size))
1033         (when (<= size 0)
1034           (error "attempt to write past end of ~s" disk-cache))
1035         (let ((words (ash size -2)))
1036           (declare (fixnum words))
1037           (if (< count words) (setq words count))
1038           #-ppc-target
1039           (lap-inline ()
1040             (:variable vector offset words value immediate?)
1041             (move.l (varg value) arg_z)
1042             (if# (eq (cmp.l (varg immediate?) nilreg))
1043               (jsr_subprim $sp-getxlong)
1044               else#
1045               (movereg arg_z acc))
1046             (move.l (varg vector) atemp0)
1047             (move.l (varg offset) da)
1048             (getint da)
1049             (lea (atemp0 da.l $v_data) atemp0)
1050             (move.l (varg words) da)
1051             (getint da)
1052             (dbfloop.l da (move.l acc atemp0@+)))
1053           #+ppc-target
1054           (if immediate?
1055             (dotimes (i words)
1056               (wood::%%store-pointer value vector offset t)
1057               (incf offset 4))
1058             (dotimes (i words)
1059               (%%store-long value vector offset)
1060               (incf offset 4)))
1061           (if (<= (decf count words) 0) (return)))
1062         (incf address (the fixnum (+ size wood::$block-overhead))))))))
1063
1064(defun wood::fill-word (disk-cache address value count &optional immediate?)
1065  (declare (ignore immediate?))
1066  (let ((count (require-type count 'fixnum))
1067        (address address)
1068        (value (require-type value 'fixnum)))
1069    (declare (fixnum count))
1070    (unless (eql 0 (logand 1 address))
1071      (error "Odd address: ~s" address))
1072    (when (<= count 0) (return-from wood::fill-word) nil)
1073    (let ((min-size (+ address (ash count 1))))
1074      (when (< (wood::disk-cache-size disk-cache) min-size)
1075        (wood::extend-disk-cache disk-cache min-size)))
1076    (loop
1077      (wood::with-databases-locked
1078       (multiple-value-bind (vector offset size)
1079                            (wood::get-disk-page disk-cache address t)
1080         (declare (fixnum offset size))
1081         (when (<= size 0)
1082           (error "attempt to write past end of ~s" disk-cache))
1083         (let ((words (ash size -1)))
1084           (declare (fixnum words))
1085           (if (< count words) (setq words count))
1086           #-ppc-target
1087           (lap-inline ()
1088             (:variable vector offset words value)
1089             (move.l (varg vector) atemp0)
1090             (move.l (varg offset) da)
1091             (getint da)
1092             (lea (atemp0 da.l $v_data) atemp0)
1093             (move.l (varg words) da)
1094             (getint da)
1095             (move.l (varg value) acc)
1096             (getint acc)
1097             (dbfloop.l da (move.w acc atemp0@+)))
1098           #+ppc-target
1099           (locally (declare (type (simple-array (unsigned-byte 16) (*)) vector)
1100                             (optimize (speed 3) (safety 0)))
1101             (let ((word-offset (ash offset -1)))
1102               (declare (fixnum word-offset))
1103               (dotimes (i words)
1104                 (setf (aref vector word-offset) value)
1105                 (incf word-offset))))
1106           (if (<= (decf count words) 0) (return)))
1107         (incf address (the fixnum (+ size wood::$block-overhead))))))))
1108
1109(defun wood::fill-byte (disk-cache address value count &optional immediate?)
1110  (declare (ignore immediate?))
1111  (let ((count (require-type count 'fixnum))
1112        (address address)
1113        (value (require-type value 'fixnum)))
1114    (declare (fixnum count))
1115    (when (<= count 0) (return-from wood::fill-byte) nil)
1116    (let ((min-size (+ address count)))
1117      (when (< (wood::disk-cache-size disk-cache) min-size)
1118        (wood::extend-disk-cache disk-cache min-size)))
1119    (loop
1120      (wood::with-databases-locked
1121       (multiple-value-bind (vector offset size)
1122                            (wood::get-disk-page disk-cache address t)
1123         (declare (fixnum offset size))
1124         (when (<= size 0)
1125           (error "attempt to write past end of ~s" disk-cache))
1126         (if (< count size) (setq size count))
1127         #-ppc-target
1128         (lap-inline ()
1129           (:variable vector offset size value)
1130           (move.l (varg vector) atemp0)
1131           (move.l (varg offset) da)
1132           (getint da)
1133           (lea (atemp0 da.l $v_data) atemp0)
1134           (move.l (varg size) da)
1135           (getint da)
1136           (move.l (varg value) acc)
1137           (getint acc)
1138           (dbfloop.l da (move.b acc atemp0@+)))
1139         #+ppc-target
1140         (locally (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1141                           (optimize (speed 3) (safety 0)))
1142           (dotimes (i size)
1143             (setf (aref vector offset) value)
1144             (incf offset)))
1145         (if (<= (decf count size) 0) (return))
1146         (incf address (the fixnum (+ size wood::$block-overhead))))))))
1147
1148(defun wood::array-fill-long (array address value count &optional immediate?)
1149  (ensure-byte-array array)
1150  (let ((count (require-type count 'fixnum))
1151        (address (require-type address 'fixnum))
1152        (value (require-type value 'fixnum)))
1153    (declare (fixnum count address))
1154    (check-byte-array-address address (* 4 count) array)
1155    (unless (eql 0 (the fixnum (logand 1 address)))
1156      (error "Odd address: ~s" address))
1157    #-ppc-target
1158    (lap-inline ()
1159      (:variable array address value count immediate?)
1160      (move.l (varg array) atemp0)
1161      (move.l (varg value) acc)
1162      (if# (eq (cmp.l (varg immediate?) nilreg))
1163        (movereg acc arg_z)
1164        (jsr_subprim $sp-getxlong))
1165      (move.l (varg address) da)
1166      (getint da)
1167      (lea (atemp0 da.l $v_data) atemp0)
1168      (move.l (varg count) da)
1169      (dbfloop.l da (move.l acc atemp0@+)))
1170    #+ppc-target
1171    (let ((offset address))
1172      (declare (fixnum offset))
1173      (if immediate?
1174        (dotimes (i count)
1175          (wood::%%store-pointer value array offset t)
1176          (incf offset 4))
1177        (dotimes (i count)
1178          (%%store-long value array offset)
1179          (incf offset 4)))))
1180  nil)
1181
1182(defun wood::array-fill-word (array address value count)
1183  (ensure-byte-array array)
1184  (let ((count (require-type count 'fixnum))
1185        (address (require-type address 'fixnum))
1186        (value (require-type value 'fixnum)))
1187    (declare (fixnum count address))
1188    (check-byte-array-address address (* 2 count) array)
1189    (unless (eql 0 (the fixnum (logand 1 address)))
1190      (error "Odd address: ~s" address))
1191    #-ppc-target
1192    (lap-inline ()
1193      (:variable array address value count)
1194      (move.l (varg array) atemp0)
1195      (move.l (varg value) acc)
1196      (getint acc)
1197      (move.l (varg address) da)
1198      (getint da)
1199      (lea (atemp0 da.l $v_data) atemp0)
1200      (move.l (varg count) da)
1201      (dbfloop.l da (move.w acc atemp0@+)))
1202    #+ppc-target
1203    (let ((index (ash address -1)))
1204      (declare (fixnum offset)
1205               (type (simple-array (unsigned-byte 16) (*)) array)
1206               (optimize (speed 3) (safety 0)))
1207      (dotimes (i count)
1208        (setf (aref array index) value)
1209        (incf index))))
1210  nil)
1211
1212(defun wood::array-fill-byte (array address value count)
1213  (ensure-byte-array array)
1214  (let ((count (require-type count 'fixnum))
1215        (address (require-type address 'fixnum))
1216        (value (require-type value 'fixnum)))
1217    (declare (fixnum count address))
1218    (check-byte-array-address address count array)
1219    #-ppc-target
1220    (lap-inline ()
1221      (:variable array address value count)
1222      (move.l (varg array) atemp0)
1223      (move.l (varg value) acc)
1224      (getint acc)
1225      (move.l (varg address) da)
1226      (getint da)
1227      (lea (atemp0 da.l $v_data) atemp0)
1228      (move.l (varg count) da)
1229      (getint da)
1230      (dbfloop.l da (move.b acc atemp0@+)))
1231    #+ppc-target
1232    (let ((offset address))
1233      (declare (fixnum offset)
1234               (type (simple-array (unsigned-byte 8) (*)) array)
1235               (optimize (speed 3) (safety 0)))
1236      (dotimes (i count)
1237        (setf (aref array offset) value)
1238        (incf offset))))
1239  nil)
1240 
1241
1242; some macros to make using this take less typing.
1243
1244(in-package :wood)
1245
1246(export '(accessing-disk-cache))
1247
1248(defmacro accessing-disk-cache ((disk-cache &optional base) &body body)
1249  (let* ((b (gensym)))
1250    `(let ((-*dc*- ,disk-cache)
1251           ,@(when base
1252               `((,b ,base))))
1253       (macrolet ((-*addr*- (address)
1254                    (if ',base
1255                      `(+ ,',b ,address)
1256                      address))
1257                  (-*select*- (operation disk-cache-code array-code)
1258                    (declare (ignore array-code))
1259                    (if (eq disk-cache-code :error)
1260                      (error "~s not supported for disk-cache's" operation))
1261                    disk-cache-code))
1262         ,@body))))
1263
1264(defmacro accessing-byte-array ((byte-array &optional base disk-page) &body body)
1265  (let* ((b (gensym)))
1266    `(let ((-*dc*- ,byte-array)
1267           ,@(when base
1268               `((,b ,base))))
1269       (macrolet ((-*addr*- (address)
1270                    (if ',base
1271                      `(+ ,',b ,address)
1272                      address))
1273                  (-*select*- (operation disk-cache-code array-code)
1274                    (declare (ignore disk-cache-code))
1275                    (if (eq array-code :error)
1276                      (error "~s not supported for arrays" operation))
1277                    array-code))
1278         ,disk-page
1279         ,@body))))
1280
1281(defun ensure-accessing-disk-cache (accessor env)
1282  (unless (and (eq :lexical (variable-information '-*dc*- env))
1283               (eq :macro (function-information '-*addr*- env))
1284               (eq :macro (function-information '-*select*- env)))
1285    (error "~s called ouside of ~s environment"
1286           accessor 'accessing-disk-cache)))
1287
1288(defmacro load.l (address &environment env)
1289  (ensure-accessing-disk-cache 'load.l env)
1290  `(-*select*-
1291    load.l
1292    (read-long -*dc*- (-*addr*- ,address))
1293    (%load-long -*dc*- (-*addr*- ,address))))
1294
1295(defmacro load.ul (address &environment env)
1296  (ensure-accessing-disk-cache 'load.ul env)
1297  `(-*select*-
1298    load.ul
1299    (read-unsigned-long -*dc*- (-*addr*- ,address))
1300    (%load-unsigned-long -*dc*- (-*addr*- ,address))))
1301
1302(defmacro load.p (address &environment env)
1303  (ensure-accessing-disk-cache 'load.ul env)
1304  `(-*select*-
1305    load.p
1306    (read-pointer -*dc*- (-*addr*- ,address))
1307    (%load-pointer -*dc*- (-*addr*- ,address))))
1308
1309(defmacro load.w (address &environment env)
1310  (ensure-accessing-disk-cache 'load.w env)
1311  `(the fixnum
1312        (-*select*-
1313         load.w
1314         (read-word -*dc*- (-*addr*- ,address))
1315         (%load-word -*dc*- (-*addr*- ,address)))))
1316
1317(defmacro load.uw (address &environment env)
1318  (ensure-accessing-disk-cache 'load.uw env)
1319  `(the fixnum
1320        (-*select*-
1321         load.uw
1322         (read-unsigned-word -*dc*- (-*addr*- ,address))
1323         (%load-unsigned-word -*dc*- (-*addr*- ,address)))))
1324
1325(defmacro load.b (address &environment env)
1326  (ensure-accessing-disk-cache 'load.b env)
1327  `(the fixnum
1328        (-*select*-
1329         load.b
1330         (read-8-bits -*dc*- (-*addr*- ,address))
1331         (%load-8-bits -*dc*- (-*addr*- ,address)))))
1332
1333(defmacro load.string (address length &optional string &environment env)
1334  (ensure-accessing-disk-cache 'load.string env)
1335  `(-*select*-
1336    load.string
1337    (read-string -*dc*- (-*addr*- ,address) ,length
1338                 ,@(if string `(,string)))
1339    (%load-string -*dc*- (-*addr*- ,address) ,length
1340                 ,@(if string `(,string)))))
1341
1342(defmacro store.l (value address &environment env)
1343  (ensure-accessing-disk-cache 'store.l env)
1344  `(-*select*-
1345    store.l
1346    (let ((-*temp*- ,value))
1347      (setf (read-long -*dc*- (-*addr*- ,address)) -*temp*-))
1348    (%store-long ,value -*dc*- (-*addr*- ,address))))
1349
1350(defmacro store.p (value address &optional value-imm? &environment env)
1351  (ensure-accessing-disk-cache 'store.p env)
1352  `(-*select*-
1353    store.p
1354    (let ((-*temp*- ,value))
1355      (setf (read-pointer -*dc*- (-*addr*- ,address)
1356                          ,@(if value-imm? `(,value-imm?)))
1357            -*temp*-))
1358    (%store-pointer ,value -*dc*- (-*addr*- ,address)
1359                    ,@(if value-imm? `(,value-imm?)))))
1360
1361(defmacro store.w (value address &environment env)
1362  (ensure-accessing-disk-cache 'store.w env)
1363  `(-*select*-
1364    store.w
1365    (let ((-*temp*- ,value))
1366      (setf (read-word -*dc*- (-*addr*- ,address)) -*temp*-))
1367    (%store-word ,value -*dc*- (-*addr*- ,address))))
1368
1369(defmacro store.b (value address &environment env)
1370  (ensure-accessing-disk-cache 'store.b env)
1371  `(-*select*-
1372    store.b
1373    (let ((-*temp*- ,value))
1374      (setf (read-8-bits -*dc*- (-*addr*- ,address)) -*temp*-))
1375    (%store-8-bits ,value -*dc*- (-*addr*- ,address))))
1376
1377(defmacro store.string (string address &optional length &environment env)
1378  (ensure-accessing-disk-cache 'store.string env)
1379  `(-*select*-
1380    store.string
1381    (funcall #'(setf read-string)
1382             ,string -*dc*- (-*addr*- ,address)
1383             ,@(if length `(,length)))
1384    (%store-string ,string -*dc*- (-*addr*- ,address)
1385             ,@(if length `(,length)))))
1386
1387(defmacro fill.l (address value count &optional imm? &environment env)
1388  (ensure-accessing-disk-cache 'fill.l env)
1389  `(-*select*-
1390    fill.l
1391    (fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)
1392    (array-fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)))
1393
1394(defmacro fill.w (address value count &environment env)
1395  (ensure-accessing-disk-cache 'fill.w env)
1396  `(-*select*-
1397    fill.w
1398    (fill-word -*dc*- (-*addr*- ,address) ,value ,count)
1399    (array-fill-word -*dc*- (-*addr*- ,address) ,value ,count)))
1400
1401(defmacro fill.b (address value count &environment env)
1402  (ensure-accessing-disk-cache 'fill.b env)
1403  `(-*select*-
1404    fill.b
1405    (fill-byte -*dc*- (-*addr*- ,address) ,value ,count)
1406    (array-fill-byte -*dc*- (-*addr*- ,address) ,value ,count)))
1407
1408(defmacro svref.p (vector index &environment env)
1409  (ensure-accessing-disk-cache 'svref.p env)
1410  `(-*select*-
1411    svref.p
1412    (dc-%svref -*dc*- ,vector ,index)
1413    :error))
1414
1415(defmacro svset.p (vector index value &optional immediate? &environment env)
1416  (ensure-accessing-disk-cache 'svset.p env)
1417  `(-*select*-
1418    svset.p
1419    (setf (dc-%svref -*dc*- ,vector ,index ,@(if immediate? `(,immediate?)))
1420          ,value)
1421    :error))
1422
1423(defmacro %vector-size.p (vector &environment env)
1424  (ensure-accessing-disk-cache '%vector-size.p env)
1425  `(-*select*-
1426    %vector-size.p
1427    (dc-%vector-size -*dc*- ,vector)
1428    :error))
1429                 
1430
1431#|
1432(setq wood::dc (wood::open-disk-cache "temp.dc"
1433                                      :if-exists :overwrite
1434                                      :if-does-not-exist :create))
1435
1436(defun wood::wi (&optional (count 100000))
1437  (declare (special wood::dc))
1438  (let ((index 0))
1439    (declare (fixnum index))
1440    (dotimes (i count)
1441      (setf (wood::read-long wood::dc index) i)
1442      (incf index 4))))
1443
1444(defun wood::ri (&optional (count 100000))
1445  (declare (special wood::dc))
1446  (let ((index 0))
1447    (declare (fixnum index))
1448    (dotimes (i count)
1449      (let ((was (wood::read-long wood::dc index)))
1450        (incf index 4)
1451        (unless (eql i was)
1452          (cerror "continue" "SB: ~d, Was: ~d" i was))))))
1453
1454#-ppc-target
1455(progn
1456
1457(require :lapmacros)
1458
1459(defun wood::time-moves (&optional (count 100))
1460  (setq count (require-type count 'fixnum))
1461  (macrolet ((moves (count)
1462               `(lap-inline (,count)
1463                  (getint arg_z)
1464                  (move.l ($ 0) atemp0)
1465                  (dbfloop arg_z
1466                           ,@(make-list 1000
1467                                        :initial-element
1468                                        '(move.l atemp0@+ da))))))
1469    (moves count)
1470    (* count 1000)))
1471
1472)
1473           
1474
1475; Timing on a mac IIfx running System 7.0.
1476;
1477; (wi) first time:   2080 usec/long  (file allocation)
1478; (wi) second time:   372 usec/long  (read every block. write half of them)
1479; (ri) first time:    200 usec/long  (read every block. write half of them)
1480; (ri) second time:   144 usec/long  (read every block)
1481; (ri 20000) 2nd time: 66 usec/long  (no disk I/O)
1482; (time-moves):       270 nanoseconds/long
1483
1484(defun wood::ws (&optional (count most-positive-fixnum) (package :ccl))
1485  (declare (special wood::dc))
1486  (let ((address 0))
1487    (do-symbols (sym package)
1488      (let* ((name (symbol-name sym))
1489             (length (length name))
1490             (rounded-length (logand -4 (+ length 3))))
1491        (setf (wood::read-long wood::dc address) (length name))
1492        (incf address 4)
1493        (setf (wood::read-string wood::dc address) name)
1494        (incf address rounded-length)
1495        (if (<= (decf count) 0) (return))))
1496    (setf (wood::read-long wood::dc address) 0)
1497    address))
1498
1499(defun wood::rs ()
1500  (declare (special wood::dc))
1501  (let ((address 0)
1502        (string (make-array 50 :fill-pointer t :adjustable t
1503                            :element-type 'base-character)))
1504    (loop
1505      (let ((length (wood::read-long wood::dc address)))
1506        (if (eql length 0) (return))
1507        (incf address 4)
1508        (print (wood::read-string wood::dc address length string))
1509        (incf address (logand -4 (+ length 3)))))))
1510   
1511 
1512|#
1513;;;    1   3/10/94  bill         1.8d247
1514;;;    2  10/04/94  bill         1.9d071
1515;;;    3  11/01/94  Derek        1.9d085 Bill's Saving Library Task
1516;;;    4  11/03/94  Moon         1.9d086
1517;;;    2   3/23/95  bill         1.11d010
1518;;;    3   6/02/95  bill         1.11d040
Note: See TracBrowser for help on using the repository browser.