LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031681. :SYSTEM-TYPE :LOGICAL :VERSION 9. :TYPE "LISP" :NAME "PAGE-DEVICE" :DIRECTORY ("REL3-SOURCE" "MEMORY-MANAGEMENT") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758728162. :AUTHOR "REL3" :LENGTH-IN-BYTES 31176. :LENGTH-IN-BLOCKS 31. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;;; -*- 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 (b)(3)(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,1987 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).;;; 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      (%P-LDB %%q-pointer (+ pointer %lpdib-starting-block))) (end        (%P-LDB %%q-pointer (+ 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-formatteron-same-formatter-but-different-uniton-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, includingthe total usable size and the amount currently in use.  If STREAM is nil, justreturns 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-sizeswap-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 thissystem 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  (%p-ldb %%q-pointer (+ swap-band-pointer %lpdib-starting-block)))     (swap-band-end    (%p-ldb %%q-pointer (+ 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).  Usethis 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 andclears 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 partitionon 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 (FIXNUMP band-start-block) (NOT (MINUSP band-start-block)))     "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))       (<= total-swap-pages (LDB %%VA-Page-Number -1)))      (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 band-start-block %%Q-Pointer  (+ lpdib-addr %LPDIB-Starting-Block))(%P-DPB band-end-block %%Q-Pointer    (+ 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;;;(Defun Count-Unmodified-Load-Band-Pages ()  "Returns the number of LOD band pages that have not been dirtied (modified) sincethe 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))    ));; 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 ofthe page containing VA, the physical disk unit where the page resides, and the DPMTdevice status code for that page.  If the status is UNASSIGNED, the first twovalues 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;Will always fit in fixnum    (%P-LDB %%Q-Pointer (+ 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)))at the physical page address referenced in the high order;; 22 bits of the word.  To translate an address, walk the table sequentially, counting pages;; as you go, until you find the entry that contains the page.;; Entries for slots that do not contain a memory board are -1.(DEFUN convert-physical-page-to-pfn (physical-page-number     &optional (a-mem-phys-map-address (AREF #'system-communication-area   %Sys-Com-Physical-Memory-Map)))  "Given a physical page number, returns its page frame number (PFN)."  (LET ((tot-pfn 0)map-addr num-q