;;; -*- Mode:Common-Lisp; Package:SI; Base:10.; Cold-Load: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 01-31-86 ab -- Common Lisp conversion for VM2. ;;; 10-15-86 ab -- Changes for 2K page-size. ;;; 02-17-87 DAB -- Change to base 10. ;;; 04-21-87 ab *O IO 25 Fix MAKE-DISK-RQB to work correctly on region ;;; boundaries now that RETURN-STORAGE is a no-op. ;;; Also wrote %use-up-structure-region which fills ;;; a region with valid (scavengeable) data. (DEFVAR *IN-USE-RQBS-LIST* ()) ;busy rqbs stored here temporarily ;;; Area containing wirable buffers and RQBs (DEFVAR DISK-BUFFER-AREA (MAKE-AREA :NAME 'DISK-BUFFER-AREA :GC :STATIC :REGION-SIZE 524288.) "Area containing disk RQBs.") ;; Internally, RQBs are resources. (DEFRESOURCE RQB (N-BLOCKS LEADER-LENGTH) :CONSTRUCTOR MAKE-DISK-RQB :FREE-LIST-SIZE 50.) (DEFUN GET-DISK-RQB (&OPTIONAL (N-BLOCKS 1.) (LEADER-LENGTH (LENGTH DISK-RQ-LEADER-QS))) "Return an RQB of data length N-BLOCKS and leader length LEADER-LENGTH. The leader length is specified only for weird hacks. Use RETURN-DISK-RQB to release the RQB for re-use." (DOLIST (AN-RQB *IN-USE-RQBS-LIST*) (WHEN (%IO-DONE AN-RQB) (RETURN-DISK-RQB AN-RQB) ;rqb can be returned to resource (SETF *IN-USE-RQBS-LIST* (DELETE AN-RQB (THE LIST *IN-USE-RQBS-LIST*) :TEST #'EQ :COUNT 1.)))) (LET* ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA) (RQB (ALLOCATE-RESOURCE 'RQB N-BLOCKS LEADER-LENGTH))) (SETF (AREF RQB %IO-RQ-INFORMATION) (DPB 1. %%IO-RQ-DONE (AREF RQB %IO-RQ-INFORMATION))) RQB)) ;; Return a buffer to the free list (DEFUN RETURN-DISK-RQB (RQB) "Release RQB for reuse. Returns NIL." (WHEN (NOT (NULL RQB)) ;allow NIL's to be handed to the function just in case (IF (%IO-DONE RQB) ;it is safe to return the rqb to the resource (PROGN (UNWIRE-DISK-RQB RQB) (clear-rqb-command-block rqb) (DEALLOCATE-RESOURCE 'RQB RQB)) (PUSH RQB *IN-USE-RQBS-LIST*)));rqb still in use, queue it for later return ()) (DEFUN COUNT-FREE-RQBS (N-BLOCKS) "Return the number of free RQBs there are whose data length is N-BLOCKS." (WITHOUT-INTERRUPTS (LOOP WITH RESOURCE = (GET 'RQB 'DEFRESOURCE) WITH N-OBJECTS = (RESOURCE-N-OBJECTS RESOURCE) FOR I FROM 0. BELOW N-OBJECTS COUNT (= (CAR (RESOURCE-PARAMETERS RESOURCE I)) N-BLOCKS)))) (DEFUN rqb-scatter-table-size (rqb) "Returns the number of 2-word entries in RQB's scatter table." (FLOOR (%POINTER-DIFFERENCE (%POINTER-PLUS (LOGAND (%POINTER rqb) (- page-size)) Page-Size) (%POINTER-PLUS rqb (+ 1 (%P-LDB-OFFSET %%Array-Long-Length-Flag rqb 0) %IO-Rq-Parameter-List-Word))) 2)) (DEFUN clear-rqb-command-block (rqb) "Clears the RQB command block, including the scatter list." (SETF (rq-link rqb) 0) (SETF (rq-information rqb) 0) (SETF (rq-command rqb) 0) (SETF (rq-status rqb) 0) (SETF (rq-buffer rqb) 0) (SETF (rq-transfer-length rqb) 0) (SETF (rq-device-address rqb) 0) (SETF (rq-event-address rqb) 0) (DOTIMES (entry (rqb-scatter-table-size rqb)) (SETF (rq-scatter-entry-address rqb entry) 0) (SETF (rq-scatter-entry-bytes rqb entry) 0)) ) (DEFUN print-rqb (rqb &optional (print-base 16.) (stream *standard-output*)) "Prints information about RQB's contents." (LET ((*read-base* print-base) (*print-base* print-base)) (FORMAT stream "~2%RQB ~a at #x+~16r~ ~2%Leader N Half Words: ~25t~a~ ~%Leader N Blocks: ~25t~a~ ~%Leader Buffer: ~25t~a~ ~%Leader 8-Bit-Buffer: ~25t~a~ ~%Leader N Blocks Wired: ~25t~a~ ~2%Link: ~25t~a~ ~%Information: ~25t~a~ ~%Command: ~25t~a~ ~%Status: ~25t~a~ ~%Buffer: ~25t~a~ ~%Transfer Length: ~25t~a~ ~%Device Address: ~25t~a~ ~%Event Address: ~25t~a" rqb (%physical-address rqb) (rqb-n-half-words rqb) (rqb-n-blocks rqb) (rqb-buffer rqb) (IF (STRINGP (rqb-8-bit-buffer rqb)) "a string" "not a string") (rqb-n-blocks-wired rqb) (rq-link rqb) (rq-information rqb) (rq-command rqb) (rq-status rqb) (rq-buffer rqb) (rq-transfer-length rqb) (rq-device-address rqb) (rq-event-address rqb)) (FORMAT stream "~%Parameter List:") (IF (ZEROP (rq-scatter-entry-bytes rqb 0)) (FORMAT stream "~25tEmpty") (DOTIMES (entry (rqb-scatter-table-size rqb)) (IF (ZEROP (rq-scatter-entry-bytes rqb entry)) (RETURN) (FORMAT stream "~% Entry ~3,,:d ~25tAddress: ~11,,a Length: ~11,,a" entry (rq-scatter-entry-address rqb entry) (rq-scatter-entry-bytes rqb entry))) )) (VALUES) )) (DEFUN print-all-rqbs () (MAP-RESOURCE #'(lambda (rqb in-use ignore) (FORMAT t "~%--------------------------~%") (FORMAT t "~%RQB in use: ~a" in-use) (print-rqb rqb)) 'rqb) ) ;;; ;;; the constructor function for the RQB resource ;;; ;; RQB Data Structures ;; --------------------- ;;Page 0 of "Extended RQB" (all parts that are wired down during disk i/o) ;;Word # ;; +----------------------------------------------+ ---- ;; 0 | RQB Buffer array Header | ;; +----------------------------------------------+ RQB Buffer array overhead ;; 1 | (Ptr to start of data array) | (RQB Buffer is 16-b ;; +----------------------------------------------+ displaced-index-offset array ;; 2 | (Data buffer length in Qs) | overlaying actual data ;; +----------------------------------------------+ area of RQB) ;; 3 | (Indirect offset) | ;; +----------------------------------------------+ ---- ;; 4 | RQB 8-bit Buffer array Header | ;; +----------------------------------------------+ RQB 8-bit Buffer array overhead ;; 5 | (Ptr to start of data array) | (RQB 8-bit Buffer is STRING ;; +----------------------------------------------+ displaced-index-offset array ;; 6 | (Data buffer length in Qs) | overlaying actual data ;; +----------------------------------------------+ area of RQB) ;; 7 | (Indirect offset) | ;; +----------------------------------------------+ ---- ;; 8 | Array-Leader Header | Actual RQB array leader ;; +----------------------------------------------+ ;; 9 | %IO-RQ-Leader-N-Pages-Wired | Leader-4 Number of wired data pages ;; +----------------------------------------------+ ;; 10 | %IO-RQ-Leader-8-Bit-Buffer | Leader-3 Array pointer (to RQB 8-bit buffer header) ;; +----------------------------------------------+ ;; 11 | %IO-RQ-Leader-Buffer | Leader-2 Array pointer (to RQB Buffer header) ;; +----------------------------------------------+ ;; 12 | %IO-RQ-Leader-N-Blocks | Leader-1 Length of data area in disk blocks + 2 (cmd area) ;; +----------------------------------------------+ ;; 13 | %IO-RQ-Leader-N-Half-Words | Leader-0 Number of half-word elements of actual RQB array ;; +----------------------------------------------+ ;; 14 | (Leader length = 5) | ;; +----------------------------------------------+ ---- ;; 15 | RQB Array Header | Actual RQB array header & overhead ;; +----------------------------------------------+ ;; 16 | (Array index length) | (This exists only if number data pages > 1) ;; +----------------------------------------------+ ---- ;; 17 | %IO-RQ-Link | Array elements 0, 1 ;; These 2 words used by ;; +----------------------------------------------+ ;; Ucode device queueing. ;; 18 | %IO-RQ-Information | Array elements 2, 3 ;; +----------------------------------------------+ ;; 19 | %IO-RQ-Command | 4, 5 ;; NUPI cmd block proper ;; +----------------------------------------------+ ;; starts here ;; 20 | %IO-RQ-Status | 6, 7 ;; +----------------------------------------------+ ;; 21 | %IO-RQ-Buffer | 8, 9 Data buffer phys addr if no scatter list. Else ptr ;; +----------------------------------------------+ to %IO-RQ-Parameter list word. ;; 22 | %IO-RQ-Transfer-Length | 10, 11 Total i/o transfer length, in bytes ;; +----------------------------------------------+ ;; 23 | %IO-RQ-Device-Address | 12, 13 ;; +----------------------------------------------+ ;; 24 | %IO-RQ-Event-Address | 14, 15 ;; +----------------------------------------------+ ;; 25 | Spare | 16, 17 ;; +----------------------------------------------+ ;; 26 | Spare | 18, 19 ;; +----------------------------------------------+ ;; 27 | %IO-RQ-Parameter-List | 20 through 477 ;; . | | CCW or Scatter List. ;; . | | Pairs of words consisting of physical address ;; . | | and number of words for each scatter entry ;;511 | | NOTE: 485 words available = Max of 242 scatter list entries! ;; +----------------------------------------------+ (used to be 229 words and 114 entries w/256-word page) ;;Page 1 and following of "Extended RQB" contain actual data. ;;Note RQB data starts at RQB element number 478 (decimal). ;;Miscellaneous notes: ;;-------------------- ;; * In the diagram above, slot descriptions in parentheses indicate ;; array-header overhead words associated with indirect, displaced, and ;; long arrays. These words are not generally accessible by ordinary ;; array reference functions. ;; * The "Extended RQB" includes overhead associated with actual RQB leader, ;; and the indirect arrays that overlay the RQB data. This overhead ;; plus the command block and scatter table comprise one page. The actual ;; RQB array does not start at the beginning of this page. The "Extended ;; RQB" thus includes all Q's involved in the I/O transfer. Note that ;; the Ucode doesn't care about anything before the %IO-RQ-Link word. ;; Slots above that are used for Lisp disk i/o housekeeping. ;; * The total length of the "Extended RQB" is the number of data blocks ;; (as specified in the get-disk-rqb call) plus one page of overhead. ;; The "Extended RQB" always start on a page boundary. ;; * RQBs are guaranteed to be contiguous in virtual memory because of the ;; way they are allocated. The NUPI, however, must have physical addresses ;; for its transfers, and the virtual pages may not be physically ;; contiguous (hence the scatter list). ;; * For more information, see WIRE-NUPI-RQB (in SYS: IO; DISK-IO) ;; and UL-DEVICE if you're really interested in what the Ucode does. ;;AB 8/7/87. Fix RQB allocation not to loop endlessly when RQB won't fit into ;; a default-sized region. (DEFUN make-disk-rqb (ignore n-blocks leader-length &aux n-blocks-rounded) ;; Figure out how many blocks N-BLOCKS is modulo page-size. ;; N-blocks-rounded and N-blocks may be slighly different, since we must ;; create RQBs that are exactly multiples of page size. The N-BLOCKS in the ;; RQB leader, though, will be what user specified. Its just the data length ;; of the arrays that may be longer. (SETQ n-blocks-rounded (* (CEILING n-blocks disk-blocks-per-page) disk-blocks-per-page)) (LET (overhead array-length rqb-buffer rqb-8-bit-buffer rqb) ;; Compute how much overhead there is in the RQB-BUFFER, ;; RQB-8-BIT-BUFFER, and in the RQB's leader and header. 4 for the ;; RQB-BUFFER indirect-offset array, 4 for the RQB-8-BIT-BUFFER ;; indirect-offset array, 3 for the RQB's header, plus the RQB's leader. ;; Then set the length (in halfwords) of the array to be sufficient so ;; that it plus the overhead is a multiple of the page size, making it ;; possible to wire down RQB's. (SETQ overhead (+ 4. 4. 3. leader-length) array-length (* (- (+ (* n-blocks-rounded disk-block-word-size) ;data size in words Page-Size) ;command block size in words overhead) ;minus overhead (which isn't array elements) 2.)) ;=> gives number of 16-b array elements (COND ((> array-length %Array-Max-Short-Index-Length) (SETQ overhead (1+ overhead) array-length (- array-length 2.)) (OR (> array-length %Array-Max-Short-Index-Length) (FERROR nil "Impossible to make this RQB array fit")))) ;; See if the CCW (scatter) list (in the worst case) will run off the end of the first page, ;; and hence not be stored in consecutive physical addresses. NUPI requires that ;; the scatter list be physically contiguous. (IF (> (+ overhead ;Misc array overhead Q's (FLOOR %Io-Rq-Parameter-List 2.) ;CMD block Q's before CCW list (* n-blocks 2.)) ;Max num of Q's needed for this CCW list page-size) (FERROR 'rqb-too-large "CCW list doesn't fit on first RQB page, ~D pages (decimal) is too many" n-blocks)) (WITHOUT-INTERRUPTS (TAGBODY L (SETQ rqb-buffer ;; Allocate array header for displaced RQB-Buffer array. ;; This header must start on a page boundary. ;; The RQB-Buffer and RQB-8-Bit-Buffer arrays are displaced to the first DATA block. (MAKE-ARRAY 0 :type art-16b :area disk-buffer-area :displaced-to "" :displaced-index-offset 0) ;; Allocate array header for 8-b displaced. rqb-8-bit-buffer (MAKE-ARRAY 0 :type art-string :area disk-buffer-area :displaced-to "" :displaced-index-offset 0)) (LET* ((npages-needed (CEILING array-length (* 2 page-size))) (rn (%region-number rqb-buffer)) (npages-free (FLOOR (- (AREF #'region-length rn) (AREF #'region-free-pointer rn)) page-size)) (total-rqb-pages-needed (+ 2 (CEILING n-blocks disk-blocks-per-page))) old-area-region-size) (WHEN (< npages-free npages-needed) ;; Can't fit RQB in this region. Fill up this region & try again. (%use-up-structure-region rn) ;; NEW 8/5/87, -ab ;; Assure the object will fit in any region the microcode would make for us. (WHEN (< (SETQ old-area-region-size (AREF #'area-region-size disk-buffer-area)) (* total-rqb-pages-needed page-size)) (UNWIND-PROTECT (PROGN ;; Increase default region size then cause a region-cons to occur. (SETF (AREF #'area-region-size disk-buffer-area) (* (CEILING (* total-rqb-pages-needed page-size) %address-space-quantum-size) %address-space-quantum-size)) (RETURN-STORAGE (MAKE-ARRAY (1- page-size) :area disk-buffer-area) t)) ;; Set it back to the old size. (SETF (AREF #'area-region-size disk-buffer-area) old-area-region-size))) (GO L))) ;; Here we know we've got enough space. Make actual data portion. (SETQ rqb (MAKE-ARRAY array-length :area disk-buffer-area :type art-16b :leader-length leader-length)) ;; Fix up displaced-to array, size and index offset of RQB-BUFFER and RQB-8-BIT-BUFFER (%P-STORE-CONTENTS-OFFSET rqb rqb-buffer 1.) (%P-STORE-CONTENTS-OFFSET (* disk-block-word-size n-blocks 2.) rqb-buffer 2.) (%P-STORE-CONTENTS-OFFSET (- array-length (* disk-block-word-size n-blocks-rounded 2.)) rqb-buffer 3.) (%P-STORE-CONTENTS-OFFSET rqb rqb-8-bit-buffer 1.) (%P-STORE-CONTENTS-OFFSET (* disk-block-word-size n-blocks 4.) rqb-8-bit-buffer 2.) (%P-STORE-CONTENTS-OFFSET (* (- array-length (* disk-block-word-size n-blocks-rounded 2.)) 2.) rqb-8-bit-buffer 3.))) (make-sure-free-pointer-of-region-is-at-page-boundary 'disk-buffer-area (%REGION-NUMBER rqb)) ;; Initialize leader elements. (SETF (rqb-n-half-words rqb) (+ %Io-Rq-Parameter-List (* 2. n-blocks))) (SETF (rqb-n-blocks rqb) n-blocks) (SETF (rqb-buffer rqb) rqb-buffer) (SETF (rqb-8-bit-buffer rqb) rqb-8-bit-buffer) rqb)) ;;; Use this to recover if the free pointer is off a page boundary. ;;; Assumes REGION-NUMBER is the active consing region of the area. (DEFUN %use-up-structure-region (region-number &aux tem) (UNLESS (region-structure-p region-number (AREF #'region-bits region-number)) (FERROR nil "Region ~d is not a structure region." region-number)) (WITHOUT-INTERRUPTS (LET* ((area (LDB (BYTE (1- (BYTE-SIZE %%Q-pointer)) 0) (LOOP FOR r = region-number THEN (AREF #'region-list-thread r) UNTIL (MINUSP r) FINALLY (RETURN r)))) (len (AREF #'region-length region-number)) (fp (AREF #'region-free-pointer region-number)) (free (- len fp)) (long-len (IF (= free (+ %array-max-short-index-length 2)) nil (IF (> free (+ %array-max-short-index-length 2)) 1 0)))) (UNLESS long-len (SETQ tem (MAKE-ARRAY 0 :area area)) (SETQ long-len 0)) (SETQ tem (MAKE-ARRAY (- free 1 long-len) :type 'art-32b :area area)))) ;; Make sure we've done our work. (UNLESS (= (AREF #'region-free-pointer region-number) (AREF #'region-length region-number)) (FERROR "Unable to use up space in region ~d." region-number))) (DEFUN make-sure-free-pointer-of-region-is-at-page-boundary (area region-number) (WHEN (NOT (ZEROP (LOGAND (1- page-size) (region-free-pointer region-number)))) (FERROR nil "~%Area ~A(#~O), region ~O has free pointer ~O, which is not on a page boundary" area (SYMBOL-VALUE area) region-number (region-free-pointer region-number))))