;;; -*- Mode:Common-Lisp; Package:SI; Base:8.; 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. ;;; Patches integrated: ;;; 1-76 and 2-59 to Configure-Page-Bands ;;; 2-60 to Deallocate-Swap-Space ;;; 2-30 to Swap-Status ;;; Other fixes: ;;; Display logical disk unit in Show-Swap-Status ;;; 07-31-86 ab -- Removed old cold build special case code from ;;; Configure-Page-Bands. ;;; Rewrote Swap-Space-Daemon-Info to use %Free-Page-Cluster-Count ;;; variable so it will be faster. Also provide new name for ;;; that funcion, Swap-Space-Info. ;;; Rewrote Swap-Status to be much faster if called with ;;; stream argument of NIL (just return values). This case just ;;; becomes a call to Swap-Space-Info. ;;; 08-01-86 ab for rjf Added RJF's change to Configure-Page-Bands so that having ;;; too many page bands is a proceedable error instead of crash. ;;; 08-29-86 ab -- Coded %Add-Page-Device in Lisp. ;;; 09-22-86 ab -- New name for this file: PAGE-DEVICE. Previously was ;;; part of PAGE & a few fns from DISK-SAVE-INTERNAL. ;;; 04-21-87 ab *O GC 14 Ensure we only add EXPLORER page bands to memory system ;;; in Configure-Page-Bands (for LX support). ;;; 07-29-87 ab GC 11 o Add ADDRESS-HAS-SWAP-SPACE-P for fast determination if ;;; address has any page device assignment. ;;; o Implemented COUNT-CORE-PAGES-NEEDING-SWAP-SPACE for GC-PROCESS ;;; space calculations & for DISK-SAVE. ;;; 10-19-88 RJF/BC Fixes for add-page-device to allow more than 128MB of paging bands ;;; 10-31/88 ab VM 5-5 o Fix %ADD-PAGE-DEVICE, SWAP-SPACE-INFO, GET-SWAP-BAND-INFO and ;;; %DISK-ADDRESS not to assume that the starting-block and ending-block ;;; fields of the LPDIB are fixnums. ;;; This file contains the Lisp-level interfaces to logical page device manipulation. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Page (Swap) Band manipulation routines ;;;; (DEFUN Free-Page-Cluster-Count (logical-page-device) "Returns the number of free pages on swap band LOGICAL-PAGE-DEVICE." (UNLESS (< logical-page-device Number-of-Page-Devices) (FERROR nil "~d is not a valid swap device number" logical-page-device)) (LET* ((swap-device-lpdib-address (+ Address-of-Page-Device-Table (* %Logical-Page-Device-Information-Block-Length logical-page-device))) (bitmap-start-address (%p-ldb %%Q-Pointer (+ swap-device-lpdib-address %LPDIB-Bit-Map-Address))) (bitmap-end-address (%p-ldb %%Q-Pointer (+ swap-device-lpdib-address %LPDIB-Ending-Bit-Map-Address))) (lpdib-flag-word-address (+ swap-device-lpdib-address %LPDIB-Flag-Word)) (words (- bitmap-end-address bitmap-start-address)) (count 0)) (IF (OR (= %LPDIB-Read-Only-Device (%P-LDB %%LPDIB-Status-Type-Bit lpdib-flag-word-address)) (ZEROP bitmap-start-address)) 0 (DOTIMES (i words count) (LET* ((addr (+ bitmap-start-address i)) (low (%p-ldb %%Q-Low-Half addr)) (hi (%p-ldb %%Q-High-Half addr))) (INCF count (+ (IF (= #x+FFFF low) 16. (IF (ZEROP low) 0 (LOGCOUNT low))) (IF (= #x+FFFF hi) 16. (IF (ZEROP hi) 0 (LOGCOUNT hi)))))))) )) (DEFUN get-swap-band-info (logical-page-device) "Returns relevant information about the specified swap band." (DECLARE (VALUES status start-block end-block size usable-size free used lpdib-address real-unit type full bitmap-address)) (LET* ((pointer (+ address-of-page-device-table (* logical-page-device %logical-page-device-information-block-length))) (status (%P-LDB %%q-pointer (+ pointer %lpdib-flag-word))) (start (DPB (%P-LDB %%q-high-half (+ pointer %lpdib-starting-block)) ;ab 10/31/88. Allow BIGNUM. %%Q-HIGH-HALF (%P-LDB %%q-low-half (+ pointer %lpdib-starting-block)))) (end (DPB (%P-LDB %%q-high-half (+ pointer %lpdib-ending-block)) ;ab 10/31/88. Allow BIGNUM. %%Q-HIGH-HALF (%P-LDB %%q-low-half (+ pointer %lpdib-ending-block)))) (bitmap-adr (%P-LDB %%q-pointer (+ pointer %lpdib-bit-map-address))) (real-unit (%P-LDB %%lpdib-unit-number (+ pointer %lpdib-flag-word))) (type (%P-LDB %%lpdib-status-type-bit (+ pointer %lpdib-flag-word))) (full (%P-LDB %%lpdib-page-band-full-flag (+ pointer %lpdib-flag-word))) (block-size (- end start)) (size (CEILING block-size disk-blocks-per-page)) (usable-size (* (FLOOR size cluster-size) cluster-size)) (free ;; Must call Free-Page-Cluster-Count since %Free-Cluster-Count variable ;; only has aggregate for ALL swap bands. (* (free-page-cluster-count logical-page-device) cluster-size)) (used (- usable-size free))) (VALUES status start end size usable-size free used pointer real-unit type full bitmap-adr))) (DEFUN band-already-added? (unit-number start) (DOTIMES (band number-of-page-devices) (MULTIPLE-VALUE-BIND (nil band-start nil nil nil nil nil nil unit) (get-swap-band-info band) (WHEN (and (= unit-number unit) (= start band-start)) (RETURN band))) )) ;; Modified so that 1st page bands used will not be on same disk unit ;; as load band. This might help overlap i/o. Patch 1-76. ;; System patch 2-59, -ab ;; Modify to favor page bands on different formatter first, then on ;; same formatter but different unit, and lastly same disk (as LOD band). ;; ;; Added ferror if too many pages devices. When this is called ;; by lisp-reinitialize, it is too early to handle microcode ;; traps, so handle here. -rjf ;; ;; Make sure page bands are for CPU-type explorer (for proper LX support). ;; ;;; Find all of the page bands and add them to the page device table. ;;; This is called early on in Lisp-Reinitialize, right after the disk ;;; system is initialized. (DEFUN configure-page-bands () "Find all page bands and add to swap device table" (LET ((lod-band-formatter-number (LDB (BYTE 3. 3.) (get-real-unit *default-disk-unit*))) on-different-formatter on-same-formatter-but-different-unit on-same-formatter-and-unit) (DOLIST (band (DOLIST (item (GET-PARTITION-LIST %bt-page-band %cpu-explorer) (APPEND on-different-formatter on-same-formatter-but-different-unit on-same-formatter-and-unit)) ;; only consider page bands with length > 0 (WHEN (> (NTH 4 item) 0) (IF (NEQ (LDB (BYTE 3. 3.) (GET-REAL-UNIT (CAR item))) lod-band-formatter-number) ;; different formatter: best (PUSH item on-different-formatter) (IF (NEQ *default-disk-unit* (CAR item)) ;; different unit of same formatter: second best (PUSH item on-same-formatter-but-different-unit) ;; on same disk as lod band: worst (PUSH item on-same-formatter-and-unit)))))) ;; band is (unit name type start size comment) ;; Add bands in "best" order (IF (< number-of-page-devices maximum-page-devices) (UNLESS (band-already-added? (get-real-unit (CAR band)) ; Just in case we come through here twice... (NTH 3 band)) (%add-page-device (get-real-unit (CAR band)) (NTH 3 band) (NTH 4 band))) ;; Signal proceedable error if too many page bands. (PROGN (FSIGNAL "Too many page bands, system only allows ~d page bands." maximum-page-devices) (PRINT "Proceeding without adding page band")))) )) (DEFUN show-swap-status (&optional (logical-page-device 0) (stream *standard-output*)) "Display swap space statistics for logical swap band LOGICAL-PAGE-DEVICE, including the total usable size and the amount currently in use. If STREAM is nil, just returns the swap band's status, usable size, and pages used." (DECLARE (VALUES swap-band-status usable-size pages-used)) (MULTIPLE-VALUE-BIND (swap-band-status swap-band-start nil swap-band-size swap-band-usable-size nil swap-band-used) (get-swap-band-info logical-page-device) (WHEN stream (FORMAT stream "~2&Status for Logical Page Device ~d." logical-page-device) (FORMAT stream "~& On disk unit number ~d, ~[a LOD band (read-only)~;a PAGE band (read-write)~]" (get-logical-unit (LDB %%lpdib-unit-number swap-band-status)) (LDB %%lpdib-status-type-bit swap-band-status)) (FORMAT stream "~& Starting block: ~d, " swap-band-start) (IF (LDB-TEST %%lpdib-status-type-bit swap-band-status) ;; Page band (FORMAT stream "usable size: ~d pages, used: ~d pages (~d%)" swap-band-usable-size swap-band-used (IF (ZEROP swap-band-usable-size) 0 (ROUND (* swap-band-used 100.) swap-band-usable-size))) ;; Load band (FORMAT stream "size: ~d pages" swap-band-size))) (VALUES swap-band-status swap-band-usable-size swap-band-used))) (DEFUN swap-status (&optional (stream *standard-output*)) "Display the current swap space statistics for all of the logical swap bands in this system configuration. The LOD band and each PAGE band are all logical swap bands. The information displayed includes type of band (read-only or read-write), usable partition length in pages, and the amount currently in use. Three values are returned: the total usable swap space size, the number of pages still available, and the number of pages currently in use. If STREAM is NIL, just the values are returned." (DECLARE (VALUES total-usable-swap-size pages-free pages-used)) (IF (NULL stream) ;; If stream is nil, this will just return aggregate status info using ;; a faster calculation method. (swap-space-info) ;; For non-nil stream, info for each band will be displayed. (LET ((total-usable-size 0) (total-free 0) (number-of-swap-bands 0)) (DOTIMES (i number-of-page-devices) (MULTIPLE-VALUE-BIND (status usable-size used) (show-swap-status i stream) (WHEN (LDB-TEST %%lpdib-status-type-bit status) ;; read/write band (page band) (INCF total-usable-size usable-size) (INCF total-free (- usable-size used)) (INCF number-of-swap-bands)))) (IF (ZEROP total-usable-size) (FORMAT stream "~& ??? No swap space ???") (FORMAT stream "~3&Total Read-Write swap space ~d pages on ~d swap bands, free ~d pages (~d%)." total-usable-size number-of-swap-bands total-free (ROUND (* total-free 100.) total-usable-size))) (VALUES total-usable-size total-free (- total-usable-size total-free)))) ) (DEFUN swap-space-info () "Returns total number of pages of swap space available in the current configuration, the number of free swap pages, and the number in use." (DECLARE (VALUES usable-size free used)) (LET ((usable-size 0) (free (* %free-cluster-count cluster-size)) (used)) (DOTIMES (logical-page-device number-of-page-devices) (LET* ((swap-band-pointer (+ address-of-page-device-table (* logical-page-device %logical-page-device-information-block-length))) (swap-band-status (%p-ldb %%q-pointer swap-band-pointer)) (swap-band-start (DPB (%P-LDB %%q-high-half (+ swap-band-pointer %lpdib-starting-block)) ;ab 10/31/88. Allow BIGNUM. %%Q-HIGH-HALF (%P-LDB %%q-low-half (+ swap-band-pointer %lpdib-starting-block)))) (swap-band-end (DPB (%P-LDB %%q-high-half (+ swap-band-pointer %lpdib-ending-block)) ;ab 10/31/88. Allow BIGNUM. %%Q-HIGH-HALF (%P-LDB %%q-low-half (+ swap-band-pointer %lpdib-ending-block)))) (swap-band-num-blocks (- swap-band-end swap-band-start)) (swap-band-num-pages (CEILING swap-band-num-blocks disk-blocks-per-page)) (swap-band-usable-size (* (FLOOR swap-band-num-pages cluster-size) cluster-size))) (WHEN (LDB-TEST %%lpdib-status-type-bit swap-band-status) ;read/write band (INCF usable-size swap-band-usable-size)))) (SETQ used (- usable-size free)) (WHEN (MINUSP free) (FERROR nil "the amount of calculated free swap space (~a) cannot be negative." free)) (VALUES usable-size free used))) (DEFF swap-space-daemon-info 'swap-space-info) ;;;(make-obsolete swap-space-daemon-info 'swap-space-info) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Changing Swap Space allocation. ;;; (DEFUN change-swap-space-allocation () "Change the current swap space allocation using the new disk label(s). Use this to add paging bands to the system after editing the disk label(s)." (DOLIST (band (get-partition-list %bt-page-band)) (LET* ((unit-number (get-real-unit (CAR band))) (start (NTH 3 band)) (size-in-blocks (NTH 4 band)) (size-in-pages (CEILING size-in-blocks disk-blocks-per-page)) (logical-page-device (band-already-added? unit-number start))) (IF logical-page-device (MULTIPLE-VALUE-BIND (nil nil nil swap-band-size) (get-swap-band-info logical-page-device) (UNLESS (= swap-band-size size-in-pages) (FORMAT t "~&You are attempting to increase the size of Swap Band ~d. ~ ~%You cannot do this on a running system. You must reboot with ~ ~%the current disk label(s) in effect if you really want to do this." logical-page-device) (RETURN))) (%add-page-device unit-number start size-in-blocks)))) (check-swap-space-allocation) (swap-status)) (DEFUN check-swap-space-allocation (&aux page-bands-in-label) (SETQ page-bands-in-label (get-partition-list %bt-page-band)) ;; For each page device currently known to the system... (DOTIMES (swap-band Number-of-Page-Devices) (MULTIPLE-VALUE-BIND (nil start nil size nil nil used nil real-unit type) (get-swap-band-info swap-band) (WHEN (= type %LPDIB-Read-Write-Device) ;; If it is a page band.. ;; Check to see if there is currently a page partition in the label ;; on REAL-UNIT with size SIZE. If not, this page band has either ;; been edited out of the label entirely (or its start block moved) ;; or it has been made smaller. (LET (band-found-in-label label-has-smaller-size label-size deleted-band-in-use) (DOLIST (band page-bands-in-label) (WHEN (AND (= real-unit (get-real-unit (CAR band))) (= start (NTH 3 band))) ;; We've found one with same start. (SETQ band-found-in-label t) ;; One in label may have smaller size, though. (WHEN (> size (SETQ label-size (CEILING (NTH 4 band) disk-blocks-per-page))) (SETQ label-has-smaller-size t)) ;; In any case, we've found one so return. (RETURN))) ;; If a deleted or contracted page band is one the ;; system is using, it may mean real trouble!! (UNLESS (ZEROP used) (SETQ deleted-band-in-use t)) (COND ;; Band edited out of label, but fortunately not yet in use! ((AND (NOT band-found-in-label) (NOT deleted-band-in-use)) (FORMAT t "~%WARNING: The PAGE partition on unit ~d starting block ~d~ ~%(logical page device ~d) appears to have been deleted from the~ ~%disk label or moved. Fortunately the system has not started using that~ ~%PAGE band yet." (get-logical-unit real-unit) start swap-band)) ;; Band edited out of label completely, and we're using it! ((NOT band-found-in-label) (FORMAT t "~%*** WARNING *** ~ ~2%A PAGE band currently in use by the system~ ~%(logical page device ~d on unit ~d starting block ~d)~ ~%appears to have been deleted from the disk label or moved!~ ~%Disk and system integrety may be in jeopardy." swap-band (get-logical-unit real-unit) start)) ;; Band is in label, but shorter. None in use yet. ((AND label-has-smaller-size (NOT deleted-band-in-use)) (FORMAT t "~%WARNING: The PAGE partition on unit ~d starting block ~d~ ~%(logical page device ~d) appears to have been edited from a~ ~%size of ~d blocks down to ~d blocks. Fortunately the system~ ~%has not started using that PAGE band yet." real-unit start swap-band size label-size)) ;; Band is in label, shorter, but overlapping part not in use. ((AND label-has-smaller-size deleted-band-in-use (< used label-size)) (FORMAT t "~%WARNING: The PAGE partition on unit ~d starting block ~d~ ~%(logical page device ~d) appears to have been edited from a~ ~%size of ~d blocks down to ~d blocks. Fortunately the system~ ~%has not started using the overlapping blocks yet." real-unit start swap-band size label-size)) ;; Band is in label, shorter, and we're using it! ((AND label-has-smaller-size deleted-band-in-use) (FORMAT t "~%*** WARNING *** ~ ~2%A PAGE band currently in use by the system~ ~%(logical page device ~d on unit ~d starting block ~d)~ ~%appears to have been edited from a size of ~d blocks down to ~d blocks!~ ~%Disk and system integrety may be in jeopardy." swap-band (get-logical-unit real-unit) start size label-size)) ;; OK (t nil)))) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Swap Band allocation & management. ;;; (PROCLAIM '(SPECIAL %%dpmte-device-a-status %%dpmte-device-a-lpdib-index %%dpmte-device-b-lpdib-index %%dpmte-device-b-offset %%dpmte-device-assignment-bit-map %%dpmte-device-a-offset)) ;; Used by garbage collector. (DEFUN deallocate-swap-space (region) "Deallocates any space assigned to REGION in any read/write swap band and clears the disk page map entry for any virtual memory allocated to REGION." (LET ((dpmte-start (region-origin disk-page-map-area)) (all-pages-on-load-band #o177777)) (DO* ((cluster-start-address (convert-to-unsigned (region-origin region)) (+ cluster-start-address (* cluster-size page-size))) (dpmte-cluster-offset (* 2 (LDB %%va-cluster-number cluster-start-address)) (* 2 (LDB %%va-cluster-number cluster-start-address))) (dpmte-cluster-entry (+ dpmte-start dpmte-cluster-offset) (+ dpmte-start dpmte-cluster-offset)) (dpmte-cluster-device-offsets (+ dpmte-cluster-entry %dpmte-device-offsets) (+ dpmte-cluster-entry %dpmte-device-offsets)) (cluster-device-a-status (%P-LDB %%dpmte-device-a-status dpmte-cluster-entry) (%P-LDB %%dpmte-device-a-status dpmte-cluster-entry)) (cluster-device-a-index (%P-LDB %%dpmte-device-a-lpdib-index dpmte-cluster-entry) (%P-LDB %%dpmte-device-a-lpdib-index dpmte-cluster-entry)) (cluster-device-bitmap (%P-LDB %%dpmte-device-assignment-bit-map dpmte-cluster-entry) (%P-LDB %%dpmte-device-assignment-bit-map dpmte-cluster-entry)) (cluster-device-a-offset (%P-LDB %%dpmte-device-a-offset dpmte-cluster-device-offsets) (%P-LDB %%dpmte-device-a-offset dpmte-cluster-device-offsets))) ((= cluster-start-address (+ (CONVERT-TO-UNSIGNED (region-origin region)) (region-length region)))) ;; Set the disk page map entry to appear unallocated. At the present time, this means that ;; the device fields will be 0, the S-A field will be 3, the S-B field will be 1, the bit ;; map will be 0, and the offsets will be 0. (%P-DPB %dpmte-read-write-but-no-disk-block-assigned %%dpmte-device-a-status dpmte-cluster-entry) (%P-DPB 0 %%dpmte-device-a-lpdib-index dpmte-cluster-entry) (%P-DPB %dpmte-read-only-band %%dpmte-device-b-status dpmte-cluster-entry) (%P-DPB 0 %%dpmte-device-b-lpdib-index dpmte-cluster-entry) (%P-DPB 0 %%dpmte-device-assignment-bit-map dpmte-cluster-entry) (%P-DPB 0 %%dpmte-device-a-offset dpmte-cluster-device-offsets) (%P-DPB 0 %%dpmte-device-b-offset dpmte-cluster-device-offsets) ;;If this cluster is allocated on a read/write swap band, free up the space ;;it occupied for reuse. (UNLESS (= cluster-device-bitmap all-pages-on-load-band) (WHEN (= cluster-device-a-status %dpmte-read-write-band) ;;Mark the cluster as unallocated in the swap band bitmap. (%return-page-cluster cluster-device-a-index cluster-device-a-offset)))))) (DEFUN %add-page-device (real-unit band-start-block band-size) "Adds a swap band to the paging system. The swap band is a PAGE partition on real unit REAL-UNIT starting at BAND-START-BLOCK and BAND-SIZE blocks long." (CHECK-ARG real-unit (AND (FIXNUMP real-unit) (NOT (MINUSP real-unit))) "a non-negative number representing a physical disk-unit") (CHECK-ARG band-start-block (AND (INTEGERP band-start-block) (NOT (MINUSP band-start-block))) ;ab 10/31/88. Allow BIGNUM. "a non-negative integer.") (CHECK-ARG band-size (AND (FIXNUMP band-size) (NOT (MINUSP band-size))) "a non-negative integer.") (WHEN (> (1+ Number-of-Page-Devices) Maximum-Page-Devices) (IF (VARIABLE-BOUNDP Error-Stack-Group) (FERROR nil "Attempt to add page device beyond system limit of ~d." Maximum-Page-Devices) (PROGN (PRINT "Attempt to add page device beyond system limit.") (%crash Too-Many-Page-Devices Number-of-Page-Devices t)))) (LET* ((logical-device-number Number-of-Page-Devices) (lpdib-addr (+ Address-of-Page-Device-Table (* logical-device-number %Logical-Page-Device-Information-Block-Length))) (band-end-block (+ band-start-block band-size)) (band-size-in-pages (FLOOR band-size disk-blocks-per-page)) (nbr-of-clusters (FLOOR band-size-in-pages Cluster-Size)) (nbr-bitmap-words-needed (CEILING nbr-of-clusters 32.)) (bitmap-start-addr (allocate-device-descriptor-space nbr-bitmap-words-needed)) (bitmap-end-addr (+ bitmap-start-addr nbr-bitmap-words-needed)) (total-swap-pages (swap-space-info))) ;; Only add page device if page band will be non-empty, and if more ;; swap space will be useful. (WHEN (AND (NOT (ZEROP nbr-of-clusters)) (or (<= total-swap-pages (LDB %%VA-Page-Number -1)) (/= 0 (READ-METER '%MAX-EXTERNAL-WORLD-SIZE)))) (WITHOUT-INTERRUPTS ;; Set all bitmap words to all ones. Handle last word separately. (DO* ((adr bitmap-start-addr (1+ adr)) (cnt 0 (1+ cnt)) (full-words (FLOOR nbr-of-clusters 32.)) (last-word-adr (+ bitmap-start-addr full-words)) (bits-in-last-word (MOD nbr-of-clusters 32.))) ((>= cnt full-words) (PROGN (%P-DPB 0 %%Q-Low-Half last-word-adr) (%P-DPB 0 %%Q-High-Half last-word-adr) (DOTIMES (i bits-in-last-word) (%P-DPB 1 (BYTE 1 i) last-word-adr)))) (%P-DPB #x+FFFF %%Q-Low-Half adr) (%P-DPB #x+FFFF %%Q-High-Half adr)) ;; Zero out LPDIB first. This is to take care of cold-band condition. (DOTIMES (i %Logical-Page-Device-Information-Block-Length) (%P-DPB 0 %%Q-High-Half (+ lpdib-addr i)) (%P-DPB 0 %%Q-Low-Half (+ lpdib-addr i))) ;; Set up LPDIB (%P-DPB real-unit %%LPDIB-Unit-Number (+ lpdib-addr %LPDIB-Flag-Word)) (%P-DPB 0 %%LPDIB-Page-Band-Full-Flag (+ lpdib-addr %LPDIB-Flag-Word)) (%P-DPB (LDB %%Q-HIGH-HALF band-start-block) %%Q-HIGH-HALF (+ lpdib-addr %LPDIB-Starting-Block)) ;ab 10/31/88. Allow BIGNUM. (%P-DPB (LDB %%Q-LOW-HALF band-start-block) %%Q-LOW-HALF (+ lpdib-addr %LPDIB-Starting-Block)) (%P-DPB (LDB %%Q-HIGH-HALF band-end-block) %%Q-HIGH-HALF (+ lpdib-addr %LPDIB-Ending-Block)) ;ab 10/31/88. Allow BIGNUM. (%P-DPB (LDB %%Q-LOW-HALF band-end-block) %%Q-LOW-HALF (+ lpdib-addr %LPDIB-Ending-Block)) (%P-DPB bitmap-start-addr %%Q-Pointer (+ lpdib-addr %LPDIB-Bit-Map-Address)) (%P-DPB bitmap-start-addr %%Q-Pointer (+ lpdib-addr %LPDIB-Next-Bit-Map-Address)) (%P-DPB bitmap-end-addr %%Q-Pointer (+ lpdib-addr %LPDIB-Ending-Bit-Map-Address)) (%P-DPB %LPDIB-Read-Write-Device %%LPDIB-Status-Type-Bit (+ lpdib-addr %LPDIB-Flag-Word)) ;; Add device to global count, and increase nbr free clusters we know about. (INCF %Free-Cluster-Count nbr-of-clusters) (INCF Number-of-Page-Devices)))) ) (DEFUN %Return-Page-Cluster (swap-device-number device-cluster-offset) (WHEN (>= swap-device-number si:Number-of-Page-Devices) (FERROR nil "~d. is not a valid swap device number" swap-device-number)) (LET* ((swap-device-lpdib-address (+ Address-of-Page-Device-Table (* %Logical-Page-Device-Information-Block-Length swap-device-number))) (bitmap-start-address-word (+ swap-device-lpdib-address %LPDIB-Bit-Map-Address)) (bitmap-start-address (%p-ldb %%Q-Pointer bitmap-start-address-word)) (bitmap-end-address-word (+ swap-device-lpdib-address %LPDIB-Ending-Bit-Map-Address)) (bitmap-end-address (%p-ldb %%Q-Pointer bitmap-end-address-word)) (lpdib-flag-word-address (+ swap-device-lpdib-address %LPDIB-Flag-Word)) word bit) ;; Word offset into bitmap, and bit # in that word. (MULTIPLE-VALUE-SETQ (word bit) (FLOOR device-cluster-offset 32.)) ;; More error checking (WHEN (or (= %LPDIB-Read-Only-Device (%P-LDB %%LPDIB-Status-Type-Bit lpdib-flag-word-address)) (ZEROP bitmap-start-address)) (FERROR nil "Attempt to return page cluster to a read-only band, swap device ~d." swap-device-number)) (when (>= (+ bitmap-start-address word) bitmap-end-address) (FERROR nil "Cluster #o~o out of range for swap device ~d." device-cluster-offset swap-device-number)) ;; OK, do the real work now. (WITHOUT-INTERRUPTS ;; Turn on appropriate bit in bitmap (0 = used, 1 = free), & count this freed cluster. (%P-DPB 1 (byte 1 bit) (+ bitmap-start-address word)) (INCF %Free-Cluster-Count) ;; If band full flag set, clear it since there is now a cluster free. (WHEN (= 1 (%p-ldb %%LPDIB-Page-Band-Full-Flag lpdib-flag-word-address)) (%P-DPB 0 %%LPDIB-Page-Band-Full-Flag lpdib-flag-word-address))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Miscellaneous ;;; ;;AB 7/29/87. Add this for fast determination if address has any page device assignment. (DEFUN address-has-swap-space-p (va) "Given virtual address VA, returns non-NIL if the address has blocks assigned on any logical paging device. Specifically, :PAGE is returned if it is READ/WRITE swap space, and :LOD is returned if it is READ-ONLY page device assignment." (LET* ((dpmt-address (AREF #'region-origin disk-page-map-area)) (assignment-word-address (+ dpmt-address (* 2 (LDB %%VA-Cluster-Number VA)) %DPMTE-DEVICE-ASSIGNMENT)) (dev-B ;; T if load band (device B = 1) NIL if page band (device A = 0) (= %DPMT-ASSIGNED-TO-LOAD-BAND (LDB (BYTE 1 (LDB %%OFFSET-INTO-CLUSTER VA)) (%p-ldb %%DPMTE-DEVICE-ASSIGNMENT-BIT-MAP assignment-word-address)))) (dev-status (IF dev-B (%p-ldb %%DPMTE-DEVICE-B-STATUS assignment-word-address) (%p-ldb %%DPMTE-DEVICE-A-STATUS assignment-word-address)))) (COND ((= dev-status %DPMTE-Read-Only-Band) :LOD) ((= dev-status %DPMTE-Read-Write-Band) :PAGE)))) ;;AB 7/29/87. New, for GC-PROCESS space calculations. (DEFUN count-core-pages-needing-swap-space () "Returns number of physical memory pages which do not yet have page band blocks assigned." (LOOP with pht1 = nil with pht-slot = (get-pht-slot-addr) with pht-start = (get-pht-slot-offset) with max-va = *io-space-virtual-address* with total = 0 for pht-offset from 0 by 8. below (get-paging-parameter %pht-index-limit) do ;; Get bottom 25 bits. Will include VPN (in top 16., plus valid & mod bit. (SETQ pht1 (compiler:%phys-logldb %%q-pointer pht-slot (+ pht-start pht-offset))) (WHEN (AND (= 1 (%logldb %%PHT1-Valid-Bit pht1)) (= 1 (%logldb %%PHT1-Modified-Bit pht1)) (%pointer< pht1 max-va) (NOT (address-has-swap-space-p pht1))) (INCF total)) finally (RETURN total)) ) (Defun Count-Unmodified-Load-Band-Pages () "Returns the number of LOD band pages that have not been dirtied (modified) since the last cold boot." (do* ((cur-dpmt (make-array (calculate-dpmt-array-size) :type 'ART-16b :displaced-to #'disk-page-map-area)) (cluster (truncate (number-of-system-wired-pages) Cluster-Size) (1+ cluster)) (count 0)) ((> cluster (ldb %%VA-Cluster-Number -1)) count) (let* ((bitmap (get-dpmt-bitmap cluster cur-dpmt)) ;; Nbr of 1's in bitmap = nbr pages assigned to load band. (nbr-on-lod-band (logcount bitmap))) (incf count nbr-on-lod-band)) )) (DEFUN COUNT-PAGES-NEEDING-WRITABLE-PAGING-STORE (&OPTIONAL (LOAD-BAND-COVERAGE-OK NIL)) "Returns the number of band band pages needed to cover all currently allocated storage which does not currently have paging store assigned." (LET((cur-dpmt (make-array (calculate-dpmt-array-size) :type 'ART-16b :displaced-to #'disk-page-map-area)) (COUNT 0)) (DOLIST (AREA AREA-LIST) (LET ((AREA-NUMBER (SYMBOL-VALUE AREA))) (WHEN (>= AREA-NUMBER (SYMBOL-VALUE First-Non-Fixed-Area-Name)) (DO ((REGION (AREA-REGION-LIST AREA-NUMBER) (REGION-LIST-THREAD REGION))) ((MINUSP REGION)) (DO ((CLUSTER (LDB %%VA-Cluster-Number (REGION-ORIGIN REGION)) (1+ CLUSTER)) (CLUSTER-COUNTER 0 (1+ CLUSTER-COUNTER)) (NUMBER-OF-CLUSTERS (CEILING (REGION-FREE-POINTER REGION) Cluster-Size-In-Words))) ((= CLUSTER-COUNTER NUMBER-OF-CLUSTERS)) (UNLESS (OR (= (Get-DPMT-Device-A-Status cluster cur-dpmt) %DPMTE-Read-Write-Band) (AND LOAD-BAND-COVERAGE-OK (/= (get-dpmt-bitmap cluster cur-dpmt) 0) (= (Get-DPMT-Device-B-Status cluster cur-dpmt) %DPMTE-Read-Only-Band))) (INCF COUNT CLUSTER-SIZE))))))) COUNT)) ;; Changes Device-Type-Status in all page device LPDIBs to Read-Only. ;; Any attempt to swap out a page will crash the system after this function is run. ;; Used by Disk-Save. (Defun Make-All-Page-Devices-Read-Only () (dotimes (logical-device Number-of-Page-Devices) (%p-dpb %LPDIB-READ-ONLY-DEVICE %%LPDIB-STATUS-TYPE-BIT (+ Address-of-Page-Device-Table (* %LOGICAL-PAGE-DEVICE-INFORMATION-BLOCK-LENGTH logical-device))) )) ;; VA arg can be a FIXNUM or BIGNUM. (Defun %Disk-Address (VA) "Given virtual address VA, returns three values: the absolute disk block address of the page containing VA, the physical disk unit where the page resides, and the DPMT device status code for that page. If the status is UNASSIGNED, the first two values returned will be NIL." (let* ((dpmt-address (region-origin disk-page-map-area)) (assignment-word-address (+ dpmt-address (* 2 (ldb %%VA-Cluster-Number VA)) %DPMTE-DEVICE-ASSIGNMENT)) (device-offsets-word-address (+ dpmt-address (* 2 (ldb %%VA-Cluster-Number VA)) %DPMTE-DEVICE-OFFSETS)) (dev-B ;; T if load band (device B = 1) NIL if page band (device A = 0) (= %DPMT-ASSIGNED-TO-LOAD-BAND (ldb (byte 1 (ldb %%OFFSET-INTO-CLUSTER VA)) (%p-ldb %%DPMTE-DEVICE-ASSIGNMENT-BIT-MAP assignment-word-address)))) (dev-status (if dev-B (%p-ldb %%DPMTE-DEVICE-B-STATUS assignment-word-address) (%p-ldb %%DPMTE-DEVICE-A-STATUS assignment-word-address))) (dev-status-valid-p (or (= dev-status %DPMTE-READ-ONLY-BAND) (= dev-status %DPMTE-READ-WRITE-BAND))) (logical-device (if dev-B (%p-ldb %%DPMTE-DEVICE-B-LPDIB-INDEX assignment-word-address) (%p-ldb %%DPMTE-DEVICE-A-LPDIB-INDEX assignment-word-address))) LPDIB-address unit-number partition-offset partition-start-block-number disk-address) (when dev-status-valid-p (setq LPDIB-address (+ Address-of-Page-Device-Table (* %LOGICAL-PAGE-DEVICE-INFORMATION-BLOCK-LENGTH logical-device))) (setq unit-number (%p-ldb %%LPDIB-UNIT-NUMBER (+ LPDIB-address %LPDIB-FLAG-WORD))) (setq partition-offset (* Cluster-Size-in-Blocks (if dev-B (%p-ldb %%DPMTE-DEVICE-B-OFFSET device-offsets-word-address) (%p-ldb %%DPMTE-DEVICE-A-OFFSET device-offsets-word-address)))) (setq partition-start-block-number (DPB (%P-LDB %%Q-HIGH-HALF (+ LPDIB-address %LPDIB-STARTING-BLOCK)) ;ab 10/31/88. Allow BIGNUM. %%Q-HIGH-HALF (%P-LDB %%Q-LOW-HALF (+ LPDIB-address %LPDIB-STARTING-BLOCK)))) (setq disk-address (+ partition-start-block-number partition-offset (* (ldb %%OFFSET-INTO-CLUSTER VA) disk-blocks-per-page)))) (values disk-address unit-number dev-status) )) ;;;;;;;;;;;;;;;;;;;; ;;; ;;; Debug functions ;;; (Defun Dump-LPDIB-Bitmap (swap-band) (format t "~%") (show-swap-status swap-band) (format t "~2%Cluster Bitmap:") (do* ((bitmap-start-address-word (+ Address-of-Page-Device-Table (* %Logical-Page-Device-Information-Block-Length swap-band) %LPDIB-Bit-Map-Address)) (bitmap-end-address-word (+ Address-of-Page-Device-Table (* %Logical-Page-Device-Information-Block-Length swap-band) %LPDIB-Ending-Bit-Map-Address)) (start (%p-ldb %%Q-Pointer bitmap-start-address-word)) (end (%p-ldb %%Q-Pointer bitmap-end-address-word)) (wd start (1+ wd))) ((>= wd end)) (when (= 0 (mod (- wd start) 8.)) (format t "~%")) (format t "~16,8,'0,r " (dpb (%p-ldb %%Q-High-Half wd) %%Q-High-Half (%p-ldb %%Q-Low-Half wd))) )) (Defun Dump-All-Bitmaps () (dotimes (i Number-of-Page-Devices) (dump-lpdib-bitmap i) (format t "~%"))) (Defun select-DPMT-status (status) (select status (%DPMTE-No-Device-Assigned 'Unassigned) (%DPMTE-Read-Only-Band 'Read-Only) (%DPMTE-Read-Write-Band 'Read-Write) (%DPMTE-Read-Write-But-No-Disk-Block-Assigned 'R-W-Unassigned) )) (Defun Make-DPMT () (make-array (calculate-dpmt-array-size) :type 'art-16b :displaced-to #'disk-page-map-area)) (Defun Show-DPMT-Cluster (dpmt cluster-number) (let ((status (get-dpmt-device-status cluster-number dpmt))) (format t "~%~4,,o: A: ~14,,,@a, ~o, B: ~9,,,@a, ~o., Bitmap: ~4,,x, ~ Offset A: ~4,,o, Offset B: ~4,,o" cluster-number (select-DPMT-status (ldb (byte 3. 13.) status)) (ldb (byte 5. 8.) status) (select-DPMT-status (ldb (byte 3. 5.) status)) (ldb (byte 5. 0.) status) (get-dpmt-bitmap cluster-number dpmt) (get-dpmt-device-a-offset cluster-number dpmt) (get-dpmt-device-b-offset cluster-number dpmt)) )) (Defun Dump-DPMT (dpmt &optional (start 0) (end (LDB %%VA-Cluster-Number -1))) (FORMAT t "~% (All numbers except bitmap in octal)") (DO ((cluster start (1+ cluster)) (cnt 0 (1+ cnt))) ((> cluster end)) (WHEN (ZEROP (MOD cnt 40)) (FORMAT t "~2% Bitmap 0 = PAGE, 1 = LOD~%")) (show-DPMT-cluster dpmt cluster)))