;-*- Mode:LISP; Package:LMFS; Base:10 -*-

;Disk I/O primitives for Lisp machine

;Outside callable routines:
; MAKE-FILE-BUFFER
; FILE-DISK-READ
; FILE-DISK-WRITE
; FILE-DISK-READ-COMPARE

;This area contains page-boundary aligned buffers
;It is not expandable, so set the :SIZE attribute to what you want
;These are NOT Lisp objects, but just pages of storage
(DEFVAR FILE-BUFFER-AREA (MAKE-AREA ':NAME 'FILE-BUFFER-AREA
				    ':GC ':STATIC
				    'SYS:%%REGION-SCAVENGE-ENABLE 0
				    'SYS:%%REGION-SPACE-TYPE SYS:%REGION-SPACE-FIXED
				    ':SIZE 65536))

;Call this function to create a buffer.  If you want to allocate and free them,
;make a resource of buffers, since once created a buffer can never be gc'ed.
;Use the make-array-options to specify a leader which makes the buffer a named defstruct
;if that is useful.
(DEFUN MAKE-FILE-BUFFER-I (SIZE ARRAY-TYPE &REST MAKE-ARRAY-OPTIONS
			   &AUX TYPE-CODE EPQ REGION OLD-FREE NEW-FREE ARRAY)
  (CHECK-ARG ARRAY-TYPE
	     (SETQ TYPE-CODE (FIND-POSITION-IN-LIST ARRAY-TYPE ARRAY-TYPES))
	     "an array type symbol")
  (SETQ EPQ (ARRAY-ELEMENTS-PER-Q TYPE-CODE))
  (CHECK-ARG SIZE (ZEROP (\ SIZE (* SYS:PAGE-SIZE EPQ))) "a multiple of the size of a page")
  (WITHOUT-INTERRUPTS			;to protect free pointer
    (SETQ REGION (SYS:AREA-REGION-LIST FILE-BUFFER-AREA)
	  OLD-FREE (SYS:REGION-FREE-POINTER REGION)
	  NEW-FREE (+ OLD-FREE (// SIZE EPQ)))
    (COND ((> NEW-FREE (SYS:REGION-LENGTH REGION))
	   (FERROR NIL "FILE-BUFFER-AREA overflow"))
	  ((NOT (ZEROP (\ OLD-FREE SYS:PAGE-SIZE)))
	   (FERROR NIL "FILE-BUFFER-AREA not aligned on page boundary"))
	  (T (STORE (SYS:REGION-FREE-POINTER REGION) NEW-FREE))))
  (SETQ ARRAY (LEXPR-FUNCALL #'MAKE-ARRAY SIZE
			     ':TYPE ARRAY-TYPE
			     ':DISPLACED-TO (+ (SYS:REGION-ORIGIN REGION) OLD-FREE)
			     MAKE-ARRAY-OPTIONS))
  (COPY-ARRAY-CONTENTS "" ARRAY)	;Clear array to zero
  ARRAY)

;Special RQB used to do I/O on these buffers
(DEFVAR FILE-BUFFER-RQB (MAKE-ARRAY (* 2 (1- SYS:PAGE-SIZE))
				    ':AREA SI:DISK-BUFFER-AREA
				    ':TYPE 'ART-16B))

(DEFUN STORE32 (VALUE ARRAY INDEX)
  (ASET (LDB #o0020 VALUE) ARRAY INDEX)
  (ASET (LDB #o2020 VALUE) ARRAY (1+ INDEX)))

(DEFUN WIRE-FILE-BUFFERS-AND-RQB (FOR-READ BUFFERS)
  (SI:WIRE-PAGE FILE-BUFFER-RQB)
  (STORE32 (+ (SYS:%PHYSICAL-ADDRESS FILE-BUFFER-RQB) 1 (// SYS:%DISK-RQ-CCW-LIST 2))
	   FILE-BUFFER-RQB SYS:%DISK-RQ-CCW-LIST-POINTER-LOW)
  (LOOP FOR BUFFER IN BUFFERS
	WITH CCWX = SYS:%DISK-RQ-CCW-LIST
	DO (OR (AND (ARRAYP BUFFER) (ARRAY-DISPLACED-P BUFFER))
	       (FERROR NIL "~S is not a file-buffer" BUFFER))
	AS LOC = (%P-CONTENTS-OFFSET BUFFER 1)
	AS NPG = (// (ARRAY-LENGTH BUFFER)
		     (* (ARRAY-ELEMENTS-PER-Q (%P-LDB SYS:%%ARRAY-TYPE-FIELD BUFFER))
			SYS:PAGE-SIZE))
	DO (LOOP REPEAT NPG
		 DO (SI:WIRE-PAGE LOC T FOR-READ)
		    (STORE32 (1+ (SYS:%PHYSICAL-ADDRESS LOC)) FILE-BUFFER-RQB CCWX)
		    (INCF CCWX 2)
		    (INCF LOC SYS:PAGE-SIZE))
	FINALLY
	 (DECF CCWX 2)			;Turn off chain bit in last CCW
	 (ASET (LOGAND (AREF FILE-BUFFER-RQB CCWX) -2) FILE-BUFFER-RQB CCWX)))

(DEFUN UNWIRE-FILE-BUFFERS-AND-RQB (BUFFERS)
  (SI:UNWIRE-PAGE FILE-BUFFER-RQB)
  (LOOP FOR BUFFER IN BUFFERS
	DO (OR (AND (ARRAYP BUFFER) (ARRAY-DISPLACED-P BUFFER))
	       (FERROR NIL "~S is not a file-buffer" BUFFER))
	AS LOC = (%P-CONTENTS-OFFSET BUFFER 1)
	AS NPG = (// (ARRAY-LENGTH BUFFER)
		     (* (ARRAY-ELEMENTS-PER-Q (%P-LDB SYS:%%ARRAY-TYPE-FIELD BUFFER))
			SYS:PAGE-SIZE))
	DO (LOOP REPEAT NPG
		 DO (SI:UNWIRE-PAGE LOC)
		    (INCF LOC SYS:PAGE-SIZE))))

;The caller of these is responsible for locking so that only one operation is done
;at a time, since there is only one RQB.
(DEFUN FILE-DISK-READ (UNIT ADDRESS &REST BUFFERS)
  (WIRE-FILE-BUFFERS-AND-RQB T BUFFERS)
  (SI:DISK-RUN FILE-BUFFER-RQB UNIT ADDRESS (AREF SI:DISK-SECTORS-PER-TRACK-ARRAY UNIT)
	       (AREF SI:DISK-HEADS-PER-CYLINDER-ARRAY UNIT) SYS:%DISK-COMMAND-READ "read")
  (UNWIRE-FILE-BUFFERS-AND-RQB BUFFERS))

(DEFUN FILE-DISK-WRITE (UNIT ADDRESS &REST BUFFERS)
  (WIRE-FILE-BUFFERS-AND-RQB NIL BUFFERS)
  (SI:DISK-RUN FILE-BUFFER-RQB UNIT ADDRESS (AREF SI:DISK-SECTORS-PER-TRACK-ARRAY UNIT)
	       (AREF SI:DISK-HEADS-PER-CYLINDER-ARRAY UNIT) SYS:%DISK-COMMAND-WRITE "write")
  (UNWIRE-FILE-BUFFERS-AND-RQB BUFFERS))

(DEFUN FILE-DISK-READ-COMPARE (UNIT ADDRESS &REST BUFFERS)
  (WIRE-FILE-BUFFERS-AND-RQB NIL BUFFERS)
  (SI:DISK-RUN FILE-BUFFER-RQB UNIT ADDRESS (AREF SI:DISK-SECTORS-PER-TRACK-ARRAY UNIT)
	       (AREF SI:DISK-HEADS-PER-CYLINDER-ARRAY UNIT)
	       SYS:%DISK-COMMAND-READ-COMPARE "read-compare")
  (UNWIRE-FILE-BUFFERS-AND-RQB BUFFERS)
  (LDB-TEST SYS:%%DISK-STATUS-HIGH-READ-COMPARE-DIFFERENCE
	    (AREF FILE-BUFFER-RQB SYS:%DISK-RQ-STATUS-HIGH)))