;;; -*- 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.

;;; This file contains some of the Lisp-level interfaces to the paging system.

;;;
;;; 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.
;;; 07-08-87   ab     Sys 43   Fixed SET-DISK-SWITCHES [SPR 5177], added SHOW-DISK-SWITCHES
;;;                              routine, and updated SET-DISK-SWITCHES for TGC training.
;;; 09/24/87   RJF    -----    Added doc strings for the wire and unwire routines [spr 5157]
;;; 1/12/88    ab              Fix WIRE-STRUCTURE to pass address of object to WIRE-WORDS instead of OBJECT.
;;; 2/9/89     JLM             Fix SHOW-PHT-ENTRY to display physical-address correctly
;;; 2/27/89    JLM		Fix WIRE-AREA to wire down all regions in an area.
;;;				Added WIRE-REGION.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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)
  "Wires the page containing ADDRESS (keeps the page from being paged out).
Only pages in static areas should be wired to prevent garbage collection from
moving objects to unwired pages.
 
If WIRE-P is T, the page containing ADDRESS is wired down; 
If WIRE-P is NIL, the page ceases to be wired down.
SET-MODIFIED = T causes the page to be marked as modified which will cause
  it to be saved once it is unwired.
DONT-BOTHER-PAGING-IN = T means just wire a possibly empty page."

  ;; 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)
  "Unwires the page containing ADDRESS (allows the page to be paged out)."
  (%change-page-status address %pht-swap-status-normal nil)) 


(DEFUN wire-words (from size &optional (wire-p t) set-modified dont-bother-paging-in)
  "Wires the page or pages containing the address FROM up to the address (+ FROM
SIZE (keeps the pages from being paged out). Only pages in static areas should be 
wired to prevent garbage collection from moving objects to unwired pages.
 
If WIRE-P is T, the pages are wired down; 
If WIRE-P is NIL, the pages ceases to be wired down.
SET-MODIFIED = T causes the pages to be marked as modified which will cause
  it to be saved once it is unwired.
DONT-BOTHER-PAGING-IN = T means just wire a possibly empty pages."

  (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)
  "Unwires the page or pages containing the address FROM up to the address (+ FROM SIZE)
(allows the page to be paged out)."
  (wire-words from size nil)) 
      

(DEFUN wire-array (array &optional from to set-modified dont-bother-paging-in &aux size)
  "Wires the page or pages containing the array ARRAY (keeps the array from
being paged out). If FROM and/or TO is specified then only the pages containing
those parts of the array are wired.  Only arrays in static areas should be wired to 
prevent garbage collection from moving the arrays to unwired pages.
 
SET-MODIFIED = T causes the pages to be marked as modified which will cause
  it to be saved once it is unwired.
DONT-BOTHER-PAGING-IN = T means just wire a possibly empty pages."

  (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)
  "Unwires the page or pages containing the array ARRAY (allows the array to be 
paged out).  If FROM and/or TO is specified then only the pages containing
those parts of the arrays are unwired."

  (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)))) 


;;ab 1/12/88.   Fix WIRE-STRUCTURE to pass address of object to WIRE-WORDS instead of OBJECT.
(DEFUN wire-structure (obj &optional set-modified dont-bother-paging-IN)
  "Wires the page or pages containing the structure OBJ (keeps the pages from being 
paged out). Only structures in static areas should be wired to prevent garbage collection 
from moving the structures to unwired pages.
 
SET-MODIFIED = T causes the pages to be marked as modified which will cause
  it to be saved once it is unwired.
DONT-BOTHER-PAGING-IN = T means just wire a possibly empty pages."

  (SETQ obj (FOLLOW-STRUCTURE-FORWARDING obj))
  (WITHOUT-INTERRUPTS
    (wire-words (%pointer (%FIND-STRUCTURE-LEADER obj)) (%STRUCTURE-TOTAL-SIZE obj) t set-modified
		dont-bother-paging-in)))


(DEFUN unwire-structure (obj)
  "Unwires the page or pages containing the structure OBJ (allows the structure to be paged out)."
  (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 &optional (wire-p t))
  "Wires down all of the allocated pages in AREA (keeps the pages from being 
paged out). Only static areas should be wired to prevent garbage collection 
from moving objects to unwired pages.

If WIRE-P is T, the area is wired down; 
If WIRE-P is NIL, the area ceases to be wired down."

  (DO ((region (area-region-list area) (region-list-thread region)))
       ((minusp region))
    (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))
      (si:wire-page loc wire-p))))

(DEFUN wire-region (region &optional (wire-p t) (set-modified nil))
  "Wires down all of the allocated pages in REGION (keeps the pages from being 
paged out). Only static regions should be wired to prevent garbage collection 
from moving objects to unwired pages."
  (when (plusp region)
    (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))
      (si:wire-page loc wire-p set-modified))))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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))
    ))



(DEFUN show-disk-switches (&optional (stream *standard-output*) &aux tem)
  "Display the current value of each of the flags in sys:%DISK-SWITCHES."
  (FORMAT stream
	  "~%  Clean Page Search          ~d   (~a)~
           ~%  Time Page Faults           ~d   (~a)~
           ~%  Multi Page Swapout         ~d   (~a)~
           ~%  Batch Promote Collection   ~d   (~a)~
           ~%  Multi Swapout Page Limit   ~d~
           ~%  Serial Delay Constant      ~d"
	  (SETQ tem (LDB %%Clean-Page-Search-Enable %disk-switches))
	  (IF (ZEROP tem) "Disabled" "Enabled")
	  (SETQ tem (LDB %%Time-Page-Faults-Enable %disk-switches))
	  (IF (ZEROP tem) "Disabled" "Enabled")
	  (SETQ tem (LDB %%Multi-Page-Swapout-Enable %disk-switches))
	  (IF (ZEROP tem) "Disabled" "Enabled")
	  (SETQ tem (LDB %%Batch-Promote-Collection-Flag %disk-switches))
	  (IF (ZEROP tem) "Disabled" "Enabled")
	  (LDB %%Multi-Swapout-Page-Limit %disk-switches)
	  (LDB %%Serial-Delay-Constant %disk-switches))
  )

;;; Set-Disk-Switches is a user interface to safely alter the dynamic
;;; paging variables using symbolic keyword definitions to specify the
;;; fields. The value returned is the new value of si:%disk-switches.
(DEFUN Set-Disk-Switches (&key clean-page-search 
			  time-page-faults
			  multi-page-swapouts
			  batch-promote-collection-flag
			  multi-swapout-page-count-limit
			  serial-delay-constant show-current)
  "Set the Paging Switches.  A keyword exists for each of the switches.  Any switch
value can be changed by providing a new numeric value.  Unspecified keywords will not
have their corresponding switch value changed.  The keywords are:
  :Clean-Page-Search     When enabled, page replacement algorithm will scan through physical memory
                          looking for a clean page to flush on a findcore.  1=enable, 0=disable.
  :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.  1=enable, 0=disable.
  :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.
                          1=enable, 0=disable.
  :Batch-Promote-Collection-Flag
                         Indicates that a batch garbage collection with the promote option is in 
                          progress.  This flag is set (or cleared) by GC-FLIP-NOW and is used
                          by the transporter to do the right thing re adjustments to the region-usage.
                          Should not be fiddled by normal users.  1=batch collection, 0=not batch.
  :Multi-Swapout-Page-Count-Limit
                         Maximum number of pages that can be updated in a multi-swapout.  Values
                          between 0 - 255.
  :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.
  :Show-Current          When true, display the current value of all switches after setting."

  (CHECK-ARG clean-page-search
	     (OR (NULL clean-page-search)
		 (AND (NUMBERP clean-page-search) (<= 0 clean-page-search 1)))
	     "the number 0, 1 or NIL")
  (CHECK-ARG time-page-faults
	     (OR (NULL time-page-faults)
		 (AND (NUMBERP time-page-faults) (<= 0 time-page-faults 1)))
	     "the number 0, 1 or NIL")
  (CHECK-ARG multi-page-swapouts
	     (OR (NULL multi-page-swapouts)
		 (AND (NUMBERP multi-page-swapouts) (<= 0 multi-page-swapouts 1)))
	     "the number 0, 1 or NIL")
  (CHECK-ARG batch-promote-collection-flag
	     (OR (NULL batch-promote-collection-flag)
		 (AND (NUMBERP batch-promote-collection-flag) (<= 0 batch-promote-collection-flag 1)))
	     "the number 0, 1 or NIL")
  (CHECK-ARG multi-swapout-page-count-limit 
	     (OR (NULL multi-swapout-page-count-limit)
		 (AND (NUMBERP multi-swapout-page-count-limit) (<= 0 multi-swapout-page-count-limit 255.)))
	     "a number between 0 and 255 inclusive or NIL")
  (CHECK-ARG serial-delay-constant 
	     (OR (NULL serial-delay-constant )
		 (AND (NUMBERP serial-delay-constant) (<= 12. serial-delay-constant 255.)))
	     "a number between 12 and 255 inclusive or NIL")

  (WHEN clean-page-search
    (SETF %disk-switches
	  (DPB clean-page-search %%Clean-Page-Search-Enable %disk-switches)))
  (WHEN time-page-faults
    (SETF %disk-switches
	  (DPB time-page-faults %%Time-Page-Faults-Enable %disk-switches)))
  (WHEN multi-page-swapouts
    (SETF %disk-switches
	  (DPB multi-page-swapouts %%Multi-Page-Swapout-Enable %disk-switches)))
  (WHEN batch-promote-collection-flag
    (SETF %disk-switches
	  (DPB batch-promote-collection-flag %%Batch-Promote-Collection-Flag %disk-switches)))
  (WHEN multi-swapout-page-count-limit 
    (SETF %disk-switches
	  (DPB multi-swapout-page-count-limit %%Multi-Swapout-Page-Limit %disk-switches)))
  (WHEN serial-delay-constant 
    (SETF %disk-switches
	  (DPB serial-delay-constant %%Serial-Delay-Constant %disk-switches)))
  (WHEN show-current
    (show-disk-switches *standard-output*))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 11.))							;; JLM
		 (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)))