;;; -*- 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) 1986- 1989 Texas Instruments Incorporated. All rights reserved.

;;; This file contains the internals of the Lisp Paging processes.

;;;
;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;------------------------------------------------------------------------------
;;; 09-22-86    ab             - Original.  Code to create background page
;;;                            process which updates maximum PHT hash depth.
;;; 04-02-87    ab             - Change UPDATE-PHT-DEPTH to FERROR if new
;;;                            computed depth is greater than UCODE-recorded depth.
;;; 05-12-88    RJF            - Change UPDATE-PHT-DEPTH to do its work twice
;;;                            to settle paging.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Background Page Process
;;;

(DEFUN compute-table-depth (&optional
			    (num-pages (pages-of-physical-memory)))
  "Scan the current memory layout reporting the deepest scan."
  ;; Scan the PPD and look up the virtual address for each page that's
  ;; in virtual memory (permanently wired and deleted pages are ignored).
  ;;
  ;; This function should not take any page faults or cons.
  (LOOP WITH ppd-slot = (get-ppd-slot-addr)
	WITH ppd-offset = (get-ppd-slot-offset)
	WITH pht-slot = (get-pht-slot-addr)
	WITH pht-offset = (get-pht-slot-offset)
	WITH pht-index-limit = (get-paging-parameter %Pht-Index-Limit)
	WITH max = 0
	WITH depth = 0
	WITH va
	FOR pfn FROM (1- num-pages) DOWNTO 0
	FOR pht-index = (valid-pht-index (ppd-index-field pfn ppd-slot ppd-offset))
	WHEN pht-index				;; Index will be NIL if invalid.
	DO
	;; Page is part of virtual memory -- get the virtual address from PHT.
	(SETQ va (LSH (pht-vpn pht-index pht-slot pht-offset)
		      (BYTE-SIZE %%va-offset-into-page)))
	;; Calculate how many steps the hash algorithm took to get here.
	(UNLESS (= va (LSH (LDB %%va-page-number -1)
			   (BYTE-SIZE %%va-offset-into-page)))			;; Dummy page
	  (SETQ depth
		(DO ((computed-hash (%compute-page-hash va)
				    (%rehash computed-hash pht-index-limit))
		     (cnt 0 (1+ cnt)))
		    ((= computed-hash pht-index) cnt)
		  ())))
	;; See if it is the longest path so far.
	(WHEN (> depth max) (SETQ max depth))
	FINALLY (RETURN max))
  )

;;;(DEFUN update-pht-depth (&optional (num-pages (pages-of-physical-memory)))
;;;  ;; The PHT-SEARCH-DEPTH counter is continually updated by the Ucode to be the
;;;  ;; longest hash-chain length so far.  When hashing, Ucode looks at this to determine
;;;  ;; how many steps to check before giving up and declaring hard fault.  Through
;;;  ;; deletions the chain can get shorter, but this fact won't be recorded by the Ucode.
;;;  ;; Hence we check periodically from Lisp to see what the max table depth is, and update
;;;  ;; the counter from that calculation.
;;;  (page-in-structure #'update-pht-depth)
;;;  (page-in-structure #'compute-table-depth)
;;;  (LET ((old-depth (get-paging-parameter %pht-search-depth))
;;;	(new-depth (compute-table-depth num-pages)))
;;;    (IF (<= new-depth old-depth)
;;;	(set-paging-parameter %pht-search-depth new-depth)
;;;	;; This shouldn't happen.
;;;	(FERROR nil "Computed PHT depth ~d. is larger than microcode-recorded depth of ~d."
;;;		new-depth old-depth))))

(DEFUN update-pht-depth (&optional (num-pages (pages-of-physical-memory)))
  ;; The PHT-SEARCH-DEPTH counter is continually updated by the Ucode to be the
  ;; longest hash-chain length so far.  When hashing, Ucode looks at this to determine
  ;; how many steps to check before giving up and declaring hard fault.  Through
  ;; deletions the chain can get shorter, but this fact won't be recorded by the Ucode.
  ;; Hence we check periodically from Lisp to see what the max table depth is, and update
  ;; the counter from that calculation.

  ;; Do it twice, the first time should settle any paging these functions
  ;; may cause.
  (without-interrupts
    (page-in-structure #'update-pht-depth)
    (page-in-structure #'compute-table-depth)
    (LET ((old-depth1 (get-paging-parameter %pht-search-depth))
	  (new-depth1 (compute-table-depth num-pages))
	  (old-depth2 (get-paging-parameter %pht-search-depth))
	  (new-depth2 (compute-table-depth num-pages)))
      (IF (<= new-depth2 old-depth2)
	  (set-paging-parameter %pht-search-depth new-depth2)
	  ; This shouldn't happen
	  (if (and (= new-depth1 new-depth2)(= old-depth1 old-depth2))
	      (FERROR nil "Tried twice and computed PHT depth ~d. is larger than microcode-recorded depth of ~d."
		      new-depth1 old-depth1)
	      (FERROR nil "Computed PHT depth ~d. is larger than microcode-recorded depth of ~d."
		      new-depth2 old-depth2))))))

;; This is initial function for the background paging process.
;; It can be redefined as more functionality is added.
(DEFUN page-background-loop ()
 "Update the %PHT-SEARCH-DEPTH meter with the current table data."
  (DO-FOREVER
    (LET ((num-pages (pages-of-physical-memory)))
      ;; Only do regularly for systems with 8 MB of memory or less.
      ;; On larger systems, only do after a complete gc.
      (WHEN (<= num-pages (FLOOR (* 8. 1024. 1024.) Page-Size))
	(WITHOUT-INTERRUPTS
	  ;; Update the counter which holds the current max PHT hash depth.
	  (update-pht-depth)))
    ;; Once every 30 minutes
    (PROCESS-SLEEP (* 60. 60. 30.))))
  )

(EVAL-WHEN (LOAD)
  ;; Start up the background paging process.  Keep it at a low priority.
  (PROCESS-RUN-FUNCTION '(:name "Page-Background" :restart-after-reset t :restart-after-boot t :priority -100.)
			'page-background-loop)

  ;; In addition, update the PHT depth after GCs.
  (ADD-INITIALIZATION "Update PHT max hash depth" '(update-pht-depth) '(:after-full-gc :normal))
  )