LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031677. :SYSTEM-TYPE :LOGICAL :VERSION 13. :TYPE "LISP" :NAME "PAGE" :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 2758728091. :AUTHOR "REL3" :LENGTH-IN-BYTES 27526. :LENGTH-IN-BLOCKS 27. :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.;;;                            Moved Wire-<thing> routines to here from IO;DISK;;;                            Removed #+explorer conditionalizations.;;;                            Patches integrated:;;;                               2-65 to Wire-Page;;;                            Other fixes:;;;                               Removed IF NOT ARRAY-INDEX-ORDER case from;;;                                 Page-Array-Calculate-Bounds (it is always T);;;                               Fixed Page-Out-Words to mark more than just;;;                                 the 1st page as flushable;;;                               Fixed problems with large positive values;;;                                 of start address in Page-In-Words and ;;;                                 Wire-Words.;;; 02-07-86   ab       --     Moved %make-page-read-only here from SYS:QMISC.;;;                            Moved Deallocate-Pages here from MEMORY-MANAGEMENT;GC.;;;                            This is required since Reset-Temporary-Area ;;;                            (in AREA) calls Deallocate-Pages.;;; 06-23-86   ab       --     Added new PPD-related accessors for LRU paging (based;;;                            on new VM1 versions).  Also added Set-Disk-Switches,;;;                            and other miscellany.  Changed Deallocate-Pages to ;;;                            work properly in new paging scheme.;;;                              This integrates Rel 2.1 Ucode-Dependent patch 2-3.;;; 07-31-86   ab       --       Rewrote various page counting functions to be faster.;;;                              Made Page-Out-Words a No-op since it really doesn't do;;;                            anything in the new LRU paging scheme.  Also did same;;;                            for all other Page-Out-xxx fns.;;; 09-22-86   ab       --       Put routines dealing with swap devices in new file,;;;                            PAGE-DEVICE.;;;                              Updated Deallocate-Pages, counting & debug routines;;;                            for new physical-memory tables.;;; This file contains some of the Lisp-level interfaces to the paging system.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Page-In/Out routines;;;;(DEFUN page-in-area (area)  "Swap in the contents of AREA."  (DO ((region (area-region-list area) (region-list-thread region)))      ((MINUSP region) nil)    (page-in-region region)))  (DEFUN page-out-area (area)  "Put the contents of AREA high on the list for being swapped out."  area nil)(DEFUN page-in-region (region)  "Swap in the contents of region REGION."  (page-in-words (region-origin region) (region-free-pointer region))) (DEFUN page-out-region (region)  "Put the contents of region REGION high on the list for being swapped out."  region nil)(DEFUN page-in-structure (obj)  "Swap in all pages in the structure STRUCTURE."  (SETQ obj (FOLLOW-STRUCTURE-FORWARDING obj))  (page-in-words (%FIND-STRUCTURE-LEADER obj) (%STRUCTURE-TOTAL-SIZE obj))) (DEFUN page-out-structure (obj)  "Put the data of structure STRUCTURE high on the list for being swapped out."  obj nil);; Removed IF NOT ARRAY-INDEX-ORDER case.  Is always T for us.  -ab;;;; FROM and TO are lists of subscripts.  If too short, zeros are appended.;; Returns array, starting address of data, number of Q's of data.;; First value is NIL if displaced to an absolute address (probably TV buffer).(DEFUN page-array-calculate-bounds (array from to)  (SETQ array (FOLLOW-STRUCTURE-FORWARDING array))  (BLOCK done    (PROG (ndims type start end size elts-per-q)  (SETQ ndims (ARRAY-RANK array)type (ARRAY-TYPE array))  (OR (<= (LENGTH from) ndims) (FERROR nil "Too many dimensions in starting index ~S" from))  (OR (<= (LENGTH to) ndims) (FERROR nil "Too many dimensions in ending index ~S" to))  (SETQ start (OR (CAR from) 0)end (1- (OR (CAR to) (ARRAY-DIMENSION array 0))))  (DO ((i 1 (1+ i))       dim)      ((= i ndims))    (SETQ start (+ (* start (SETQ dim (ARRAY-DIMENSION array i))) (OR (NTH i from) 0))  end (+ (* end dim) (1- (OR (NTH i to) dim)))))  (SETQ end (1+ end))  (SETQ size (- end start))  (DO ((p))      ((ZEROP (%P-LDB-OFFSET %%array-displaced-bit array 0)))    (SETQ ndims (%P-LDB-OFFSET %%array-number-dimensions array 0))    (SETQ p  (%MAKE-POINTER-OFFSET dtp-locative array(+ ndims (%P-LDB-OFFSET %%array-long-length-flag array 0))))    (AND (ARRAY-INDEXED-P array);Index offset (SETQ start (+ start (%P-CONTENTS-OFFSET p 2))))    (SETQ array (%P-CONTENTS-OFFSET p 0))    (OR (ARRAYP array) (RETURN-FROM done nil)))  (SETQ elts-per-q (CDR (ASSOC type array-elements-per-q :test #'EQ)))  (SETQ start(+ (IF (PLUSP elts-per-q)       (FLOOR start elts-per-q)       (* START (- elts-per-q)))   (%MAKE-POINTER-OFFSET dtp-fix array (+ ndims (%P-LDB-OFFSET %%array-long-length-flag array 0))))size (IF (PLUSP elts-per-q) (CEILING size elts-per-q) (* SIZE (- elts-per-q))))  (RETURN-FROM done array start size));Convert from inclusive upper bound to exclusive    ))  (DEFUN page-in-array (array &optional from to &aux size)  "Swap in all or part of ARRAY in one disk operation.FROM and TO are lists of subscripts, or NIL."  (WITHOUT-INTERRUPTS    (MULTIPLE-VALUE-SETQ (array from size) (page-array-calculate-bounds array from to))    (AND array (page-in-words from size)))) (DEFUN page-out-array (array &optional from to)  "Put all or part of ARRAY high on the list for being swapped out.FROM and TO are lists of subscripts, or NIL."  array from to nil);; Just marks pages as good to swap out (flushable).  Doesn't actually write them.;; This really doesn't do anything in new LRU paging scheme, so make it no-op.;;;(DEFUN PAGE-OUT-WORDS (ADDRESS NWDS &OPTIONAL ONLY-IF-UNMODIFIED &AUX STS);;;  ONLY-IF-UNMODIFIED;;;  (WITHOUT-INTERRUPTS;;;    ;; Get pointer field as fixnum;;;    (SETQ ADDRESS (%POINTER ADDRESS));;;    (DO ((ADDR;;;   ;; Address of 1st page (must stay a fixnum);;;   (LOGAND (- PAGE-SIZE) ADDRESS);;;   ;; Next page (must stay a fixnum);;;   (%MAKE-POINTER-OFFSET DTP-FIX ADDR PAGE-SIZE));;; ;; Loop controlled by N, which is NWDS plus number of;;; ;; words between page boundary and ADDRESS.  This;;; ;; guarantees we will touch all pages in the interval.;;; (N (+ NWDS (LOGAND (1- PAGE-SIZE) ADDRESS)) (- N PAGE-SIZE)));;;((NOT (PLUSP N)));;;      ;; Only change status if swapped in and not wired.;;;      (OR (NULL (SETQ STS (%PAGE-STATUS ADDR)));;;  ;; swapped out;;;  (>= (LDB %%PHT1-SWAP-STATUS-CODE STS) %PHT-SWAP-STATUS-WIRED);;;  ;; wired or swapout in progress;;;  (%CHANGE-PAGE-STATUS ADDR %PHT-SWAP-STATUS-FLUSHABLE;;;       (LDB %%REGION-MAP-BITS (REGION-BITS (%REGION-NUMBER ADDR))))))))(DEFUN page-out-words (address nwds &optional only-if-unmodified)  address nwds only-if-unmodified nil)(DEFUN page-in-words (start-address num-words)  (UNLESS (ZEROP num-words)    (WITHOUT-INTERRUPTS      ;; Get pointer field as fixnum      (SETQ start-address (%POINTER start-address))      (DO ((addr     ;; Address of 1st page (must stay a fixnum)     (LOGAND (- page-size) start-address)     ;; Next page (must stay a fixnum)     (%MAKE-POINTER-OFFSET dtp-fix addr page-size))   ;; Loop controlled by N, which is NUM-WORDS plus number of   ;; words between page boundary and ADDRESS.  This   ;; guarantees we will touch all pages in the interval.   (n (+ num-words (LOGAND (1- page-size) start-address)) (- n page-size)))  ((NOT (PLUSP n)));; Reference page to bring it in.(%P-LDB 1 addr)))))       ;;; I'm leaving this old code here because we may want to do someting like;;; it in the future. -ab;;;;;;(DEFUN PAGE-IN-WORDS (ADDRESS NWDS &AUX (CCWX 0) CCWP BASE-ADDR);;;  (WITHOUT-INTERRUPTS;;;    (SETQ ADDRESS (%POINTER ADDRESS));;;    (UNWIND-PROTECT;;;      (PROGN (WIRE-PAGE-RQB);;;     ;; This DO is over the whole frob;;;     (DO ((ADDR (LOGAND (- PAGE-SIZE) ADDRESS);;;(%MAKE-POINTER-OFFSET DTP-FIX ADDR PAGE-SIZE));;;  (N (+ NWDS (LOGAND (1- PAGE-SIZE) ADDRESS)) (- N PAGE-SIZE)));;; ((NOT (PLUSP N)));;;       (SETQ CCWX 0;;;     CCWP %DISK-RQ-CCW-LIST;;;     BASE-ADDR ADDR);;;       ;; This DO is over pages to go in a single I/O operation.;;;       ;; We collect some page frames to put them in, remembering the;;;       ;; PFNs as CCWs.;;;       (DO () (NIL);;; (OR (EQ (%PAGE-STATUS ADDR) NIL) (RETURN NIL));;; (LET ((PFN (%FINDCORE)));;;   (ASET (1+ (LSH PFN 8)) PAGE-RQB CCWP);;;   (ASET (LSH PFN -8) PAGE-RQB (1+ CCWP)));;; (SETQ CCWX (1+ CCWX);;;       CCWP (+ 2 CCWP));;; (OR (< CCWX PAGE-RQB-SIZE) (RETURN NIL));;; (SETQ ADDR (%MAKE-POINTER-OFFSET DTP-FIX ADDR PAGE-SIZE);;;       N (- N PAGE-SIZE));;; (OR (PLUSP N) (RETURN NIL)));;;       (COND ((PLUSP CCWX);We have something to do, run the I/O op;;;      (ASET (LOGAND (AREF PAGE-RQB (- CCWP 2)) -2) ;Turn off chain bit;;;    PAGE-RQB (- CCWP 2));;;      (DISK-READ-WIRED PAGE-RQB 0 (+ (LSH BASE-ADDR -8) PAGE-OFFSET));;;      ;Make these pages in;;;      (DO ((I 0 (1+ I));;;   (CCWP %DISK-RQ-CCW-LIST (+ 2 CCWP));;;   (VPN (LSH BASE-ADDR -8) (1+ VPN));;;   (PFN));;;  ((= I CCWX));;;(SETQ PFN (DPB (AREF PAGE-RQB (1+ CCWP));;;       1010 (LDB 1010 (AREF PAGE-RQB CCWP))));;;(OR (%PAGE-IN PFN VPN);;;    ;Page already got in somehow, free up the PFN;;;    (%CREATE-PHYSICAL-PAGE (LSH PFN 8))));;;      (SETQ CCWX 0)))));;;      ;; UNWIND-PROTECT forms;;;      (UNWIRE-PAGE-RQB);;;I guess it's better to lose some physical memory than to get two pages;;;swapped into the same address, in the event that we bomb out.;;;     (DO ((CCWP %DISK-RQ-CCW-LIST (+ CCWP 2));;;   (N CCWX (1- N)));;;  ((ZEROP N));;;(%CREATE-PHYSICAL-PAGE (DPB (AREF PAGE-RQB (1+ CCWP));;;    2006;;;    (AREF PAGE-RQB CCWP))));;;      )));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Wire/Unwire routines;;;;;;;; These used to live in IO;DISK;; Must be defined before Disk-Init is run.  Used by WIRE-NUPI-RQB.(DEFUN wire-page (address &optional (wire-p t) set-modified dont-bother-paging-in)  ;; DONT-BOTHER-PAGING-IN = t means just wire a possibly empty page.  (IF wire-p      (DO ()  ;; If %change-page-status returns nil, page not swapped in.  ;; Keep trying until page stays in long enough to wire it down.  ((%CHANGE-PAGE-STATUS address %Pht-Swap-Status-Wired nil)   (IF set-modified       ;; Set modified bit without changing anything       ;; and without touching uninitialized memory       (IF dont-bother-paging-in   (PROGN     (%P-DPB DTP-Trap %%Q-Data-Type address)     (%P-DPB address %%Q-Pointer address))   (%P-DPB (%P-LDB %%q-data-type address) %%q-data-type address))))(COND  ((NOT dont-bother-paging-in)   ;; Bring it into main memory by referencing it   (%P-LDB 1 (%POINTER address)))  ;; Check if swapped in.  %page-status is nil if not swapped in.  ((NULL (%PAGE-STATUS address))   (WITHOUT-INTERRUPTS     ;; Find a page frame we can use     (LET ((pfn (%findcore)))       ;; Associate physical page with this virtual address (no actual       ;; swap-in done).  %page-in returns nil if page already in.       (IF (NOT (%PAGE-IN pfn (LSH address   (- (BYTE-SIZE %%VA-Offset-Into-Page)))))   ;; Page already got in somehow, free up the PFN   (%CREATE-PHYSICAL-PAGE pfn)))))))      (UNWIRE-PAGE address))) (DEFUN unwire-page (address)  (%change-page-status address %pht-swap-status-normal nil)) (DEFUN wire-words (from size &optional (wire-p t) set-modified dont-bother-paging-in)  (DO ((adr (- from (LOGAND from (1- page-size)))    ;; Make sure this stays a fixnum, -ab    ;; Old code: (+ adr Page-Size)    (%MAKE-POINTER-OFFSET Dtp-fix adr Page-Size))       (count 0 (+ count 1))       (finished (TRUNCATE (+ size (LOGAND from (1- Page-Size)) -1) Page-Size)))      ((> count finished))    (wire-page adr wire-p set-modified dont-bother-paging-in))) (DEFUN unwire-words (from size)  (wire-words from size nil))       (DEFUN wire-array (array &optional from to set-modified dont-bother-paging-in &aux size)  (WITHOUT-INTERRUPTS    (MULTIPLE-VALUE-SETQ (array from size) (page-array-calculate-bounds array from to))    (AND array ;; Have starting word and number of words.  (wire-words from size t set-modified dont-bother-paging-in)))) (DEFUN unwire-array (array &optional from to &aux size)  (WITHOUT-INTERRUPTS    (MULTIPLE-VALUE-SETQ (array from size) (page-array-calculate-bounds array from to))    (AND array ;; Have starting word and number of words.  (unwire-words from size)))) (DEFUN wire-structure (obj &optional set-modified dont-bother-paging-IN)  (SETQ obj (FOLLOW-STRUCTURE-FORWARDING obj))  (WITHOUT-INTERRUPTS    (wire-words (%FIND-STRUCTURE-LEADER obj) (%STRUCTURE-TOTAL-SIZE obj) t set-modifieddont-bother-paging-in))) (DEFUN unwire-structure (obj)  (SETQ obj (FOLLOW-STRUCTURE-FORWARDING obj))  (WITHOUT-INTERRUPTS (unwire-words (%FIND-STRUCTURE-LEADER obj) (%STRUCTURE-TOTAL-SIZE obj)))) ;;; Takes the number of an area and wires down all the allocated;;; pages of it, or un-wires, depending on the second argument.;;; The area had better have only one region.;;; Also doesn't work on downwards-consed list regions (which no longer exist).(DEFUN wire-area (area wire-p)  (LET ((region (area-region-list area)))    (OR (MINUSP (region-list-thread region));last region in area(FERROR nil "Area ~A has more than one region" (AREA-NAME area)))    (DO ((loc (region-origin region) (%MAKE-POINTER-OFFSET Dtp-Fix loc Page-Size)) (count (CEILING (region-free-pointer region) Page-Size) (1- count)))((ZEROP count))      (wire-page loc wire-p)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Miscellaneous;;;;;; Formerly in SYS;QMISC(DEFUN %make-page-read-only (p)  "Make virtual page at address P read only.  Lasts only until it is swapped out!"  (%change-page-status p nil       (DPB 2 (BYTE 3. 6.)    ;; Changes map status    (LDB %%region-map-bits (region-bits (%region-number p)))))) ;; This came from MEMORY-MANGEMENT; GC.  It is used by the garbage collector.;; Given a base virtual address and number of pages, makes sure any in-core pages;; are deallocated.  That is, the pages are made free for use by other virtual pages.;; They are NOT written out if they have been modified.  Swap space for these;; virtual pages is NOT deallocated (for that, call Deallocate-Swap-Space).;;;; Note:  This function MUST NOT do any consing OR take a page fault since it hacks;;        the PHT (which is side-effected by page faults).(DEFUN Deallocate-Pages (base-addr n-pages)  (DECLARE (INLINE convert-physical-page-to-pfn))  (WITHOUT-INTERRUPTS    ;; For N-PAGES pages starting at BASE-ADDR, mark them properly not in core and "free".    (LET ((pht-slot (get-pht-slot-addr))  (pht-offset (get-pht-slot-offset))  (pht-limit (get-paging-parameter %PHT-Index-Limit))  (%%valid-bit %%PHT1-Valid-Bit)  (%%virtual-page-number %%PHT1-Virtual-Page-Number)  (%%physical-pg-nbr %%PHT2-Physical-Page-Number)  (%%modified-bit %%PHT1-Modified-Bit)  (pg-size Page-Size)  (pfn-map (system-communication-area %Sys-Com-Physical-Memory-Map)))      ;; Above locals used to avoid references to specials which could cause page fault.      ;; Must not page fault in this function, so make sure all our FEF is in core.      (page-in-structure #'deallocate-pages)      (page-in-structure #'convert-physical-page-to-pfn)      (DO ((i 0 (1+ i))   (address base-addr (%make-pointer-offset DTP-Fix address pg-size))   phys-pg pfn)  ((>= i n-pages));; For each page, if it is swapped in, change its PHT entry to "free"(WHEN (%page-status address)  ;; Now must manually set page to unmodified.  ;; Search for this page in the page hash table.  (DO* ((phtx (%compute-page-hash address) (+ phtx 8.));; page hash returns byte-index(pht1 (+ pht-offset phtx) (+ pht-offset phtx))pht2)       (nil)    ;; Wrap around if necessary    (WHEN (>= phtx pht-limit)      (SETQ phtx (- phtx pht-limit))      (SETQ pht1 (+ pht-offset phtx)))    ;; Valid entry not found.  This shouldn't happen since    ;; %page-status was non-nil.    (IF (NOT (= 1 (%phys-logldb %%valid-bit pht-slot pht1)))(RETURN nil))    ;; If this entry is for ADDRESS, process it and return.  Else    ;; keep searching PHT.    (WHEN (= (LSH address (- (BYTE-SIZE %%VA-Offset-Into-Page)))     (%phys-logldb %%virtual-page-number pht-slot pht1))      (SETQ pht2 (+ pht1 4.))      ;; First use miscop to bash any level 2 map that might be set up.      (%change-page-status address nil nil)      ;; turn off modified bit.      (%phys-logdpb 0 %%modified-bit pht-slot pht1)      ;; Change map-status to RWF so delete-physical-page won't swap it out      (%phys-logdpb %PHT-Map-Status-Read-Write-First %%PHT2-Map-Status-Code pht-slot pht2)      ;; get physical page number      (SETQ phys-pg    (%phys-logldb %%physical-pg-nbr pht-slot pht2))      ;; Delete & create page to take it out of use (mark as "free")      ;; This will clean up its PHT entry (re-hashing if necessary).      (SETQ pfn (convert-physical-page-to-pfn phys-pg pfn-map))      (%delete-physical-page pfn)      (%create-physical-page pfn)      (RETURN nil)))      ))      )));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Counters.;;;(DEFUN count-user-wired-pages ()  (DO* ((pfn 0 (1+ pfn))(ppd-slot (get-ppd-slot-addr))(ppd-offset (get-ppd-slot-offset))(pht-slot (get-pht-slot-addr))(pht-offset (get-pht-slot-offset))(count 0)(end (pages-of-physical-memory)))       ((>= pfn end) count)    (WHEN (page-user-wired-p pfn ppd-slot ppd-offset pht-slot pht-offset)      (INCF count)))  )(DEFUN count-perm-wired-pages ()  (DO* ((pfn 0 (1+ pfn))(ppd-slot (get-ppd-slot-addr))(ppd-offset (get-ppd-slot-offset))(count 0)(end (pages-of-physical-memory)))       ((>= pfn end) count)    (WHEN (page-perm-wired-p pfn ppd-slot ppd-offset)      (INCF count)))  )(DEFUN count-free-core-pages ()  (DO* ((pfn 0 (1+ pfn))(ppd-slot (get-ppd-slot-addr))(ppd-offset (get-ppd-slot-offset))(count 0)(end (pages-of-physical-memory)))       ((>= pfn end) count)    (WHEN (page-free-p pfn ppd-slot ppd-offset)      (INCF count)))  )(DEFUN count-wired-pages ()  (DO* ((pfn 0 (1+ pfn))(ppd-slot (get-ppd-slot-addr))(ppd-offset (get-ppd-slot-offset))(pht-slot (get-pht-slot-addr))(pht-offset (get-pht-slot-offset))(user-wired 0)(perm-wired 0)(end (pages-of-physical-memory)))       ((>= pfn end)(values (+ perm-wired user-wired) perm-wired))    (IF (page-perm-wired-p pfn ppd-slot ppd-offset)(INCF perm-wired)(IF (page-user-wired-p pfn ppd-slot ppd-offset pht-slot pht-offset)    (INCF user-wired)))    ))(DEFUN estimate-modified-core-pages ()  "Returns estimate of number of modified (dirty) pages in core memory."  (DO* ((pht-slot (get-pht-slot-addr))(pht-offset (get-pht-slot-offset))(phtx 0 (+ phtx 8.))        (offset (+ pht-offset phtx) (+ pht-offset phtx))(dirty 0)(end (get-paging-parameter %PHT-Index-Limit)))       ((>= phtx end) dirty)    (WHEN (AND (= 1 (%phys-logldb %%PHT1-Valid-Bit pht-slot offset))       (= 1 (%phys-logldb %%PHT1-Modified-Bit pht-slot offset)))      (INCF dirty))    ))(DEFUN estimate-clean-core-pages ()  "Returns estimate of number of modified (dirty) pages in core memory."  (DO* ((pht-slot (get-pht-slot-addr))(pht-offset (get-pht-slot-offset))(phtx 0 (+ phtx 8.))        (offset (+ pht-offset phtx) (+ pht-offset phtx))(clean 0)(end (get-paging-parameter %PHT-Index-Limit)))       ((>= phtx end) clean)    (WHEN (AND (= 1 (%phys-logldb %%PHT1-Valid-Bit pht-slot offset))       (= 0 (%phys-logldb %%PHT1-Modified-Bit pht-slot offset)))      (INCF clean))    ));;; Set-Disk-Switches is a user interface to safely alter the dynamic;;; paging variables using symbolic keyword definitions to specify the;;; fields.  The defaults for each switch are "safe" values. The value;;; returned is the new value of si:%disk-switches.(Defun Set-Disk-Switches (&key  (clean-page-search 1)  (time-page-faults 0)  (multi-page-swapouts 1)  (sequence-breaks-during-disk-wait 0)  (multi-swapout-page-count-limit 128.)  (serial-delay-constant 12.))  "Set the Paging Switches.Keywords are:  :Clean-Page-search     Page replacement algorithm will scan through physical memory                          looking for a clean page to flush on a findcore.  Default                          value is 1 (on).  :Time-Page-Faults      Enables %TOTAL-PAGE-FAULT-TIME in the counter block.  Value of counter is                          microsecond time spent in the page fault microcode + disk wait time, but                          excluding code that resolves page exceptions.  Default value is 0 (off).  :Multi-Page-Swapouts   Enables the page replacement algorithm to clean adjacent memory page images                          by writing them to disk in the same disk write for a page being flushed.                          Default value is 1 (on).  :Sequence-Breaks-During-Disk-Wait                         Allows the system to enter the scheduler and run another process                           while waiting for a disk page write to complete.  Do not use this option if                          :Time-Page-Faults is turned on (the counter will include elapsed time from                           the sequence break to re-activation of the waiting process).  Default is 0 (off).  :Multi-Swapout-Page-Count-Limit                         Maximum number of pages that can be updated in a multi-swapout.  Values                          between 0 - 255.  Default value 128. pages.  :Serial-Delay-Constant Timing constant for microcode access to the serial chip registers.  This must                          NOT be less than 12 (the default), which yields a delay of at least 2.641                          microseconds on Explorer I.  Don't change this unless you know what you're                          doing."  (let ((new-switches 0))    (setq new-switches (dpb clean-page-search %%Clean-Page-Search-Enable new-switches)  new-switches (dpb time-page-faults %%Time-Page-Faults-Enable new-switches)  new-switches (dpb multi-page-swapouts %%Multi-Page-Swapout-Enable new-switches)  new-switches (dpb sequence-breaks-during-disk-wait %%SB-During-Disk-Wait-Enable new-switches)  new-switches (dpb multi-swapout-page-count-limit %%Multi-Swapout-Page-Limit new-switches)  new-switches (dpb serial-delay-constant %%Serial-Delay-Constant new-switches))    (setq %disk-switches new-switches)));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Debugging Functions.;;;(DEFUN dump-ppd (&optional (start 0) (end (pages-of-physical-memory)))  (LET ((ppd-slot (get-ppd-slot-addr))(ppd-offset (get-ppd-slot-offset)))    (DO ((pg start (1+ pg)))((>= pg end))      (FORMAT *Standard-Output* "~%PFN: ~4d.,  Link: ~16,4,,r,  Index: ~16,4,,r"      pg      (%phys-logldb %%PPD-Link-Field ppd-slot (+ ppd-offset (* pg 4.)))      (%phys-logldb %%PPD-Index-Field ppd-slot (+ ppd-offset (* pg 4.))))       )))(DEFUN show-pht-entry (address)  (SETQ address (%POINTER address))  (LET* ((ppd-slot (get-ppd-slot-addr)) (ppd-offset (get-ppd-slot-offset)) (pht-slot (get-pht-slot-addr)) (pht-offset (get-pht-slot-offset)) (pht-limit (get-paging-parameter %PHT-Index-Limit)) (hash (%compute-page-hash address)))    (WHEN (%page-status address)      (DO* ((phtx hash (+ phtx 8.))    (pht1 (+ pht-offset phtx) (+ pht-offset phtx)))   (nil);; Wrap if necessary.(WHEN (>= phtx pht-limit)  (SETQ phtx (- phtx pht-limit))  (SETQ pht1 (+ pht-offset phtx)))(WHEN (= 1 (%phys-logldb %%PHT1-Valid-Bit pht-slot pht1))  (LET* ((vpn (LSH address (- (BYTE-SIZE %%va-offset-into-page)))) (vpn-from-pht (%phys-logldb %%Pht1-Virtual-Page-Number pht-slot pht1)) (modified (%phys-logldb %%PHT1-Modified-Bit pht-slot pht1)) (l2-ctl (%phys-logldb %%PHT2-Access-Status-And-Meta-Bits pht-slot (+ pht1 4.))) (valid (%phys-logldb %%PHT1-Valid-Bit pht-slot pht1)) (status (%phys-logldb %%PHT1-Swap-Status-Code pht-slot pht1)) (symb-status (ELT PHT-Status-Codes-List status)) (bg-write (%phys-logldb %%PHT1-Background-Writing-Bit pht-slot pht1)) (phys-pg (%phys-logldb %%PHT2-Physical-Page-Number pht-slot (+ pht1 4.))) (phys-adr (ASH phys-pg 10.)) (pfn (convert-physical-page-to-pfn phys-pg)) (ppd-index   (LSH (%phys-logldb %%PPD-Index-Field ppd-slot (+ ppd-offset (* pfn 4)))3)))    ;; Display info     (FORMAT t "~2%Address: #x+~16r,   VPN: #x+~16r,   VPN From PHT: #x+~16r ~                        ~%Modified: ~d.,   BG Write Bit: ~d.,  Lvl2 Ctl: #x+~16r                        ~%Valid: ~d,   Status: ~d. = ~a ~                        ~%Phys Pg: #x+~16r,   Phys address: #x+~16r,   PFN: #x+~16r ~                        ~%PPD Index For PFN: #x+~16r,   Phtx: #x~16r"    address vpn vpn-from-pht    modified bg-write l2-ctl    valid status symb-status    phys-pg  phys-adr pfn    ppd-index phtx))  (IF (= (LSH address (- (BYTE-SIZE %%VA-Offset-Into-Page))) (%phys-logldb %%Pht1-Virtual-Page-Number pht-slot pht1))      (RETURN nil))))      )))(DEFUN find-pfn (va)  (SETQ va (%POINTER va))  ;; Will have PFN only if swapped in  (WITHOUT-INTERRUPTS    (WHEN (%page-status VA)      (convert-physical-address-to-pfn (%physical-address va)))    ))(DEFUN print-areas-of-wired-pages ()  (DO ((pht-slot (get-pht-slot-addr))       (pht-offset (get-pht-slot-offset) (+ pht-offset 8.))       (index-limit (get-paging-parameter %PHT-Index-Limit))       (area)       (area-lst))      ((>= pht-offset index-limit)       (DOLIST (a area-lst) (FORMAT t "~%~S" a)))    (WHEN (AND (NOT (ZEROP (%phys-logldb %%pht1-valid-bit pht-slot pht-offset)))       (= (%phys-logldb %%pht1-swap-status-code pht-slot pht-offset) %pht-swap-status-wired))      (SETQ area    (AREF #'AREA-NAME (%AREA-NUMBER(LSH (%phys-logldb %%pht1-virtual-page-number pht-slot pht-offset)     (BYTE-SIZE %%VA-Offset-Into-Page)))))      (UNLESS (MEMBER area area-lst :test #'EQ)(PUSH area area-lst))))  )(DEFUN swap-out-page (page-frame-number)  (IF (%delete-physical-page page-frame-number);Swap it out & delete      (%create-physical-page page-frame-number)))flag)))      (gc-fwd       (MULTIPLE-VALUE-BIND (obj ignore flag)   (%structure-header-safe-internal     (%follow-gc