source: trunk/block-io-mcl.lisp @ 2

Revision 2, 20.6 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;; block-io-mcl.lisp
6;; low-level block I/O - MCL version.
7;;
8;; Copyright © 1996-1999 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;; 01/29/00 akh  fix example at end of this file
24;; 01/10/00 akh fix for possible non fixnum file address
25;; ------------- 0.96
26;; 07/20/96 bill databases-locked-p, with-databases-unlocked, & funcall-with-databases-unlocked
27;;               are already part of CCL 4.0. Bind *warn-if-redefine*, etc. appropriately.
28;; 07/06/96 bill provide block-io-mcl, not block-io.
29;; 05/21/96 bill PPC versions of %fread-bytes & %fwrite-bytes now work correctly
30;;               if the starting file or buffer position is odd.
31;;               They use %copy-ivector-to-ivector instead of local code.
32;; ------------- 0.95
33;; 05/09/96 bill databases-locked-p
34;;               funcall-with-databases-locked-p comes out-of-line from with-databases-unlocked.
35;;               It now binds *database-locked-p* nil during its body.
36;; 05/03/96 bill multi-process with-databases-locked
37;; 05/01/96 slh  don't require lapmacros on PPC
38;; ------------- 0.94 = MCL-PPC 3.9
39;; 03/09/96 bill Eliminate LAP for ppc-target
40;; ------------- 0.93
41;; 07/21/95 bill inhibited-event-dispatch now processes *inhibited-foreground-switch*
42;; 05/31/95 bill wood:with-database-locked now calls new inhibted-event-dispatch
43;;               function if event processing happenned while it was inhibited.
44;;               This makes interactive response time as good as it can be
45;;               given this locking mechanism.
46;; 05/25/95 bill %fread-bytes & %fwrite-bytes use #_BlockMove instead
47;;               of a move.b loop; it's faster.
48;;               set-minimum-file-length never makes the file shorter.
49;; ------------- 0.9
50;; 03/13/95 bill byte-array-p and ensure-byte-array move here from "disk-cache-accessors.lisp"
51;;               byte-array-p updated to work in MCL 3.0.
52;;               Former lap uses of $v_subtype changed to calls of ensure-byte-array
53;; 10/25/94 Moon without-interrupts -> with-databases-locked
54;; 09/21/94 bill without-interrupts around part of %fread-bytes and %fwrite-bytes
55;; 01/31/94 bill %fread-bytes & %fwrite-bytes support offsets > 64K and
56;;               will read/write more than just the first 512 bytes.
57;; ------------  0.8
58;; ------------  0.6
59;; ------------  0.5
60;; 03/05/92 bill New file
61;;
62
63(in-package :ccl)
64
65;; N.B. there is another of this in disk-page-hash.lisp!!! - gone now
66; Assume fixnum addresses.
67; Comment out this form to compile Wood for files larger than 256 megs.
68(eval-when (:compile-toplevel :execute :load-toplevel)
69  (pushnew :wood-fixnum-addresses *features*))
70
71
72(export '(stream-read-bytes stream-write-bytes set-minimum-file-length))
73
74(provide :block-io-mcl)
75
76(defvar *inhibit-event-dispatch* nil)
77(defvar *event-dispatch-inhibited* nil)
78
79; Set non-NIL if a suspend or resume event comes in while
80; *event-dispatch-inhibited* is true. 0 means it was
81; suspend, non-zero means resume.
82(defvar *inhibited-foreground-switch* nil)
83
84;;; This macro provides the interlocking so the WOOD database
85;;; doesn't get screwed up by being used reentrantly by an event
86;;; handler.  Change this macro and recompile to change the
87;;; implementation of the interlocking.
88;;; Defined here since WOOD doesn't seem to have
89;;; a file specifically for macros like this.
90#-ccl-3
91(progn
92
93(defmacro wood::with-databases-locked (&body body)
94  ;; The following is surprisingly slow on 68040s
95  ;`(without-interrupts ,@body)
96  ;; So do it this way instead.
97  `(multiple-value-prog1                ; Wish this could be prog1
98     (let ((*inhibit-event-dispatch* t))
99       ,@body)
100     (locally (declare (optimize (speed 3) (safety 0)))         ; force inline value cell reference
101       (when (and *event-dispatch-inhibited*
102                  (not *inhibit-event-dispatch*))
103         (inhibited-event-dispatch)))))
104
105(defmacro wood::with-databases-unlocked (&body body)
106  `(let ((ccl::*inhibit-event-dispatch* nil))
107     (declare (special ccl::*inhibit-event-dispatch*))          ; fix build problem
108     ,@body))
109
110(defun wood::databases-locked-p (&optional by-locker)
111  (declare (ignore by-locker))
112  (and (boundp 'ccl::*inhibit-event-dispatch*)
113       ccl::*inhibit-event-dispatch*))
114
115)  ; end of #-ccl-3 progn
116
117; with-databases-(un)locked is a NOP is CCL 3.0, since store-conditional
118; doesn't exists there yet.
119#+(and ccl-3 (not ppc-target))
120(progn
121
122(defmacro wood:with-databases-locked (&body body)
123  `(progn ,@body))
124
125(defmacro wood:with-databases-unlocked (&body body)
126  `(progn ,@body))
127
128(defun wood::databases-locked-p (&optional by-locker)
129  (declare (ignore by-locker))
130  nil)
131
132)  ; end of #+(and ccl-3 (not ppc-target)) progn
133
134#+ppc-target
135(progn
136
137(defvar *database-lock* (make-lock))
138(defvar *database-queue* (make-process-queue "*database-queue*"))
139(defvar *database-locked-p* nil)
140
141(declaim (type lock *database-lock)
142         (type boolean *database-locked-p*))
143
144(declaim (inline lock-databases unlock-databases))
145
146; You should only call this inside a binding of *database-locked-p* to true.
147; Otherwise, another process will steal the lock from you.
148; with-databases-locked uses it correctly.
149; Returns when it has the *database-lock*.
150; A true value means that it is newly grabbed.
151; NIL means that this process already had the lock when lock-databases was called.
152(defun lock-databases ()
153  (declare (type process *current-process*))
154  (let ((process *current-process*)
155        (lock *database-lock*))
156    (declare (type lock lock))
157    (unless (eq (lock.value lock) process)
158      (unless (store-conditional lock nil process)
159        (lock-databases-out-of-line))
160      t)))
161
162(defun unlock-databases ()
163  (declare (type lock *database-lock*)
164           (type process *current-process*))
165  (unless (store-conditional *database-lock* *current-process* nil)
166    (error "~s not held by ~s" '*database-lock* *current-process*)))
167
168(declaim (ftype (function (&optional t)) wood::with-databases-locked-p))
169
170(let ((*warn-if-redefine* nil)
171      (*warn-if-redefine-kernel* nil))
172
173(defun wood::databases-locked-p (&optional by-locker)
174  (without-interrupts
175   (let* ((lock *database-lock*)
176          (locker (lock.value lock)))
177     (cond ((null locker) nil)
178           ((or (process-exhausted-p locker)
179                (not (symbol-value-in-process '*database-locked-p* locker)))
180            (setf (lock.value lock) nil))
181           (by-locker (eq locker by-locker))
182           (t t)))))
183
184)
185
186; This is so hairy because we're trying to avoid an unwind-protect (too slow)
187; yet we still want to notice when the holder of the *database-lock*
188; has thrown out of wood::with-databases-locked.
189(defun lock-databases-out-of-line ()
190  (let ((lock *database-lock*)
191        (queue *database-queue*)
192        (enqueued nil))
193    (declare (type lock lock))
194    ; In case we threw out of a with-databases-locked
195    (unwind-protect
196      (loop
197        (wood::databases-locked-p)      ; clear lock.value if it's not really locked
198        (unless enqueued
199          (setq enqueued (process-enqueue-with-timeout queue 30)))
200        (when enqueued
201          (when (store-conditional lock nil *current-process*)
202            (return t))
203          (process-wait-with-timeout "Lock"
204                                     30
205                                     #'(lambda (lock)
206                                         (null (lock.value lock)))
207                                     lock)))
208      (when enqueued
209        (process-dequeue queue)))))
210
211(defmacro wood::with-databases-locked (&body body)
212  (let ((needs-unlocking-p (gensym)))
213    `(let* ((*database-locked-p* t)
214            (,needs-unlocking-p (lock-databases)))
215       (multiple-value-prog1
216         (progn ,@body)
217         (when ,needs-unlocking-p
218           (unlock-databases))))))
219
220;;; Undo the effect of with-databases-locked temporarily, if possible
221(eval-when (:compile-toplevel :execute :load-toplevel)
222(unless (fboundp 'wood::with-databases-unlocked)
223
224(defmacro wood::with-databases-unlocked (&body body)
225  (let ((thunk (gensym)))
226    `(let ((,thunk #'(lambda () ,@body)))
227       (declare (dynamic-extent ,thunk))
228       (funcall-with-databases-unlocked ,thunk))))
229
230))
231
232(let ((*warn-if-redefine* nil)
233      (*warn-if-redefine-kernel* nil))
234     
235(defun funcall-with-databases-unlocked (thunk)
236  (let ((was-locked? nil))
237    (unwind-protect
238      (let ((*database-locked-p* *database-locked-p*))
239        (when (setq was-locked? (wood::databases-locked-p *current-process*))
240          (unlock-databases)
241          (setq *database-locked-p* nil))
242        (funcall thunk))
243      (when was-locked?
244        (lock-databases)))))
245
246)
247
248)  ; end of #+ppc-target progn
249
250; Separate function mostly so we can meter it
251(defun inhibited-event-dispatch ()
252  (setq *event-dispatch-inhibited* nil)
253  (let ((switch *inhibited-foreground-switch*))
254    (when switch
255      (setq *inhibited-foreground-switch* nil)
256      (unless (eq *foreground*
257                  (setq *foreground* (not (eql switch 0))))
258        (when (fboundp 'establish-*foreground*)
259          (funcall 'establish-*foreground*)))))
260  (event-dispatch))
261
262;; (stream-read-bytes stream address vector offset length)
263;;   read length bytes into vector at offset from stream at address.
264;;
265;; (stream-write-bytes stream address vector offset length)
266;;   write length bytes from stream at address into vector at offset.
267;;   Extend the length of the file if necessary.
268;;
269;; (set-minimum-file-length stream length)
270;;   Set the file length of stream to >= length.
271;;
272;; This implementation only supports vectors of type
273;; (array (unsigned-byte 8)), (array (signed-byte 8)), or simple-string
274
275(eval-when (eval compile)
276  #-ppc-target
277  (require 'lapmacros)
278  (require 'lispequ)
279
280;structure of fblock
281;from "ccl:level-1;l1-sysio.lisp"
282
283(let ((*warn-if-redefine* nil))
284
285(def-accessors (fblock) %svref
286  nil                                   ; 'fblock
287  fblock.pb                             ; a parameter block; nil if closed.
288  fblock.lastchar                       ; untyi char or nil
289  fblock.dirty                          ; non-nil when dirty
290  fblock.buffer                         ; macptr to buffer; nil when closed
291  fblock.bufvec                         ; buffer vector; nil when closed
292  fblock.bufsize                        ; size (in 8-bit bytes) of buffer
293  fblock.bufidx                         ; index of next element to read/write
294  fblock.bufcount                       ; # of elements in buffer
295  fblock.filepos                        ; 8-bit position at last read/write
296  fblock.fileeof                        ; file's logical eof.
297  fblock.stream                         ; backptr to file stream
298  fblock.element-type                   ; typespec
299  fblock.nbits-per-element              ; # of bits per element
300  fblock.elements-per-buffer            ; 512 or whatever
301  fblock.minval                         ; minimum value of element type or nil: < 0
302  fblock.maxval                         ; maximum value or nil
303  fblock.element-bit-offset             ; for non-arefable n-bit elements
304)
305
306) ; end of let
307
308) ; end of eval-when
309
310(declaim (inline byte-array-p ensure-byte-array))
311
312#-ppc-target
313(defun byte-array-p (array)
314  (and (uvectorp array)
315       (let ((subtype (%vect-subtype array)))
316         (or (eql subtype $v_sstr)
317             (eql subtype $v_ubytev)
318             (eql subtype $v_sbytev)))))
319
320#+ppc-target
321(defun byte-array-p (array)
322  (let ((typecode (extract-typecode array)))
323    (or (eql typecode ppc::subtag-simple-base-string)
324        (eql typecode ppc::subtag-s8-vector)
325        (eql typecode ppc::subtag-u8-vector))))
326
327(defun ensure-byte-array (array)
328  (unless (byte-array-p array)
329    (error "~s is not a byte array" array)))
330
331; Read length bytes into array at offset from stream at address.
332; Array must be a simple (byte 8) array.
333; stream must be an input stream for 8 bit elements.
334(defmethod stream-read-bytes ((stream input-file-stream)
335                                 address array offset length)
336  (%fread-bytes (slot-value stream 'fblock)
337                #+:wood-fixnum-addresses
338                (require-type address 'fixnum)
339                #-:wood-fixnum-addresses
340                (require-type address 'integer)
341                array
342                (require-type offset 'fixnum)
343                (require-type length 'fixnum)))
344
345#-ppc-target
346(defun %fread-bytes (fblock address array offset length)
347  (declare (fixnum offset length))
348  #+:wood-fixnum-addresses (declare (fixnum address))
349  (unless (eql 8 (fblock.nbits-per-element fblock))
350    (error "%fread-bytes only implemented for 8-bit bytes"))
351  (unless (>= (length array) (the fixnum (+ offset length)))
352    (error "array too small"))
353  (ensure-byte-array array)
354  (let ((max-length (- (%fsize fblock) address)))
355    #+:wood-fixnum-addresses (declare (fixnum max-length))
356    (if (< max-length length) (setq length max-length))
357    (if (< length 0) (setq length 0)))
358  (let ((bytes length)
359        (bufvec (fblock.bufvec fblock)))
360    (declare (fixnum bytes))
361    (loop
362      (when (<= length 0) (return bytes))
363      (wood::with-databases-locked
364       (%fpos fblock address)
365       (let* ((vec-index (- address (the #+:wood-fixnum-addresses fixnum
366                                         #-:wood-fixnum-addresses integer
367                                         (fblock.filepos fblock))))
368              (vec-left (- (the fixnum (fblock.bufcount fblock)) vec-index)))
369         (declare (fixnum vec-index vec-left))
370         ;        (print-db vec-index vec-left)
371         (if (> vec-left length) (setq vec-left length))
372         (lap-inline ()
373           (:variable bufvec array offset vec-index vec-left)
374           (move.l (varg bufvec) atemp0)
375           (move.l (varg vec-index) acc)
376           (getint acc)
377           (lea (atemp0 acc.l $v_data) atemp0)
378           (move.l (varg array) atemp1)
379           (move.l (varg offset) acc)
380           (getint acc)
381           (lea (atemp1 acc.l $v_data) atemp1)
382           (move.l (varg vec-left) acc)
383           (getint acc)
384           (dc.w #_BlockMove)
385           )
386         (incf address vec-left)
387         (incf offset vec-left)
388         (decf length vec-left))))))
389
390#+ppc-target
391(defun %fread-bytes (fblock address array offset length)
392  (declare (fixnum offset length))
393  #+:wood-fixnum-addresses (declare (fixnum address))
394  (unless (eql 8 (fblock.nbits-per-element fblock))
395    (error "%fread-bytes only implemented for 8-bit bytes"))
396  (unless (>= (length array) (the fixnum (+ offset length)))
397    (error "array too small"))
398  (ensure-byte-array array)
399  (let ((max-length (- (%fsize fblock) address)))
400     #+:wood-fixnum-addresses (declare (fixnum max-length))
401    (if (< max-length length) (setq length max-length))
402    (if (< length 0) (setq length 0)))
403  (let ((bytes length)
404        (bufvec (fblock.bufvec fblock)))
405    (declare (fixnum bytes))
406    (loop
407      (when (<= length 0) (return bytes))
408      (without-interrupts
409       (%fpos fblock address)
410       (let* ((vec-index (fblock.bufidx fblock))
411              (vec-left (- (the fixnum (fblock.bufcount fblock)) vec-index)))
412         (declare (fixnum vec-index vec-left))
413         (if (> vec-left length) (setq vec-left length))
414         (%copy-ivector-to-ivector bufvec vec-index array offset vec-left)
415         (incf address vec-left)
416         (incf offset vec-left)
417         (decf length vec-left))))))
418
419; same, but other direction
420(defmethod stream-write-bytes ((stream output-file-stream)
421                                  address array offset length)
422  (%fwrite-bytes (slot-value stream 'fblock)
423                 #+:wood-fixnum-addresses (require-type address 'fixnum)
424                 #-:wood-fixnum-addresses (require-type address 'integer)
425                 array
426                 (require-type offset 'fixnum)
427                 (require-type length 'fixnum)))
428
429#-ppc-target
430(defun %fwrite-bytes (fblock address array offset length)
431  (declare (fixnum offset length))
432   #+:wood-fixnum-addresses (declare (fixnum address))
433  (unless (eql 8 (fblock.nbits-per-element fblock))
434    (error "%fwrite-bytes only implemented for 8-bit bytes"))
435  (unless (>= (length array) (the fixnum (+ offset length)))
436    (error "array too small"))
437  (ensure-byte-array array)
438  (let ((min-size (+ address length)))
439     #+:wood-fixnum-addresses (declare (fixnum min-size))
440    (when (> min-size (%fsize fblock))
441      (%fsize fblock min-size)))
442  (let ((bytes length)
443        (bufvec (fblock.bufvec fblock)))
444    (declare (fixnum bytes))
445    (loop
446      (when (<= length 0) (return bytes))
447      (wood::with-databases-locked
448       (%fpos fblock address)
449       (let* ((vec-index (- address (the  #+:wood-fixnum-addresses fixnum
450                                          #-:wood-fixnum-addresses integer
451                                          (fblock.filepos fblock))))
452              (vec-left (- (the fixnum (fblock.elements-per-buffer fblock))
453                           vec-index)))
454         (declare (fixnum vec-index vec-left))
455         (if (> vec-left length) (setq vec-left length))
456         (lap-inline ()
457           (:variable bufvec array offset vec-index vec-left)
458           (move.l (varg bufvec) atemp1)
459           (move.l (varg vec-index) acc)
460           (getint acc)
461           (lea (atemp1 acc.l $v_data) atemp1)
462           (move.l (varg array) atemp0)
463           (move.l (varg offset) acc)
464           (getint acc)
465           (lea (atemp0 acc.l $v_data) atemp0)
466           (move.l (varg vec-left) acc)
467           (getint acc)
468           (dc.w #_BlockMove))
469         (let ((index (+ vec-index vec-left))
470               (bufcount (fblock.bufcount fblock)))
471           (declare (fixnum index bufcount))
472           (if (> index bufcount)
473             (setf (fblock.bufcount fblock) index))
474           (setf (fblock.bufidx fblock) index
475                 (fblock.dirty fblock) t))
476         (incf address vec-left)
477         (incf offset vec-left)
478         (decf length vec-left))))))
479
480#+ppc-target
481(defun %fwrite-bytes (fblock address array offset length)
482  (declare (fixnum offset length))
483  #+:wood-fixnum-addresses (declare (fixnum address))
484  (unless (eql 8 (fblock.nbits-per-element fblock))
485    (error "%fwrite-bytes only implemented for 8-bit bytes"))
486  (unless (>= (length array) (the fixnum (+ offset length)))
487    (error "array too small"))
488  (ensure-byte-array array)
489  (let ((min-size (+ address length)))
490    #+:wood-fixnum-addresses (declare (fixnum min-size))
491    (when (> min-size (%fsize fblock))
492      (%fsize fblock min-size)))
493  (let ((bytes length)
494        (bufvec (fblock.bufvec fblock)))
495    (declare (fixnum bytes))
496    (loop
497      (when (<= length 0) (return bytes))
498      (wood::with-databases-locked
499       (%fpos fblock address)
500       (let* ((vec-index (fblock.bufidx fblock))
501              (vec-left (- (the fixnum (fblock.elements-per-buffer fblock))
502                           vec-index)))
503         (declare (fixnum vec-index vec-left))
504         (if (> vec-left length) (setq vec-left length))
505         (%copy-ivector-to-ivector array offset bufvec vec-index vec-left)
506         (let ((index (+ vec-index vec-left))
507               (bufcount (fblock.bufcount fblock)))
508           (declare (fixnum index bufcount))
509           (if (> index bufcount)
510             (setf (fblock.bufcount fblock) index))
511           (setf (fblock.bufidx fblock) index
512                 (fblock.dirty fblock) t))
513         (incf address vec-left)
514         (incf offset vec-left)
515         (decf length vec-left))))))
516
517(defun set-minimum-file-length (stream length)
518  (unless (>= (file-length stream) length)
519    (file-length stream length)))
520
521#|
522(setq s (open "temp.lisp" :direction :io :if-exists :overwrite))
523
524(defun r (address length)
525  (declare (special s))
526  (let ((v (make-string length :element-type 'base-character)))
527    (let ((real-length (stream-read-bytes s address v 0 length)))
528      (if (eql length real-length)
529        (values v length)
530        (let ((res (make-string real-length)))
531          (dotimes (i real-length)
532            (setf (aref res i) (aref v i)))
533          (values res real-length))))))
534
535(defun w (string address &optional
536                 (offset 0) (length (- (length string) offset)))
537  (declare (special s))
538  (stream-write-bytes s address string offset length))
539
540|#
541;;;    1   3/10/94  bill         1.8d247
542;;;    2  10/04/94  bill         1.9d071
543;;;    3  11/03/94  Moon         1.9d086
544;;;    2   3/23/95  bill         1.11d010
545;;;    3   6/02/95  bill         1.11d040
546;;;    4   8/01/95  bill         1.11d065
Note: See TracBrowser for help on using the repository browser.