;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:8; Patch-file 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) 1984- 1989 Texas Instruments Incorporated. All rights reserved.
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; This file contains the various memory management warning daemons.

;;;
;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;------------------------------------------------------------------------------
;;; 07-22-86    ab      --       Integration for VM2.  Derived from
;;;                            SYS:MEMORY-MANAGEMENT; DAEMONS.LISP#10
;;;                              Removed conditionalized code.
;;;                              Translated to Common Lisp.
;;; 08-15-86    ab      --     - Integrated RJF's fixes to Address-Space-Warning
;;;                            and GC-Too-Late-Warning.
;;;                              Re-wrote a lot of the code.  Added
;;;                            documentation.  There are now 4 address
;;;                            space conditions instead of 3.  Changed
;;;                            the handling of %page-cons-alarm to reflect
;;;                            the fact that it is the number of pages 
;;;                            ASSIGNED to region-quanta, not the number
;;;                            of fresh pages consed.  The latter can be
;;;                            measured by the meter %Count-Fresh-Pages, which
;;;                            I added to the set of address-space-conditions
;;;                            checked (although no daemon watches it yet).
;;; 10-05-86    ab      --     - Moved actual process start-up forms to
;;;                            new file GC-PROCESSES.
;;;  8-22-88    clm     --     increased the priorities for each daemon process
;;;                            so that notifications have a "better" chance of
;;;                            getting out.


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Daemon Routines
;;;

;;; A GC-daemon is a set of address-space conditions to wait for, and a
;;; function to run (in a separate process) when conditions are met.

;;; This simple process implements the queue
(DEFVAR GC-Daemon-Process) 

;;; Each element on this queue is a list at least six long:
;;;	(name   function 
;;;             region-cons-alarm   region-page-cons-alarm 
;;;                                 page-creation-alarm     cluster-usage-alarm)
;;; If any alarm counter value is >= the value in the queue, the function is called
;;; in a background process with the queue element as its argument.
;;;
;;; If any oldspace is reclaimed, all entries on the queue go off, since the
;;; allocation of address space has just changed.
(DEFVAR GC-Daemon-Queue nil)

;;; Alarm Counters
;;;
;;; The following are system-maintained counters that are monitored by these
;;; daemons, and a description of each one's meaning.
;;;
;;; %Region-Cons-Alarm   (A-Memory variable)
;;;    Used in Make-Region (in Ucode Storage-Allocation).  Simply incremented
;;;    each time a new region is created, but is 0 on boot.  So just indicates
;;;    number of regions created since last boot.
;;;
;;; %Page-Cons-Alarm     (A-Memory variable)
;;;    Used in Make-region (in Ucode Storage-Allocation).  When a new region
;;;    is created, the number of pages in the region is added to this variable.
;;;    Also 0 at boot, so indicates the number of pages ASSIGNED to regions
;;;    (not necessarily allocated to objects) since boot.  This can give us
;;;    a measure of the number of QUANTUMS that have been allocated (to help
;;;    indicate a fragmented address space map).
;;;
;;; %Count-Fresh-Pages   (Meter)
;;;    Used in Ucode Page-Fault code.  Incremented every time page-fault is
;;;    entered in order to create a new page (as a result of consing).  Also
;;;    0 at boot, so indicates the total number of fresh pages ALLOCATED
;;;    since boot.
;;;
;;; %Free-Cluster-Count  (A-Memory variable)
;;;    Maintained by Ucode Page-Fault code.  Initialized at boot time to the
;;;    total number of usable clusters (16-pg units) of disk space available
;;;    for swapping out pages (calculated by examining all PAGE bands).  
;;;    Page-fault processing increments the count when it assigns swap space
;;;    to virtual addresses as part of the swap-out process.  Since one's
;;;    usable virtual memory is limited (in part) by the amount of swap space
;;;    available, we warn when swap space is getting low.
;;; 
 
;;; The following variables will be set up to contain our "target" values for
;;; the above alarm counters.  That is, the alarm process "goes off" when the value
;;; of any of the actual alarm counters above is >= the target value (<= in the
;;; case of swap space usage).
(DEFVAR GC-Daemon-Region-Cons-Alarm nil) 
(DEFVAR GC-Daemon-Region-Page-Cons-Alarm nil) 
(DEFVAR GC-Daemon-Page-Usage-Alarm nil)
(DEFVAR GC-Daemon-Swap-Space-Usage-Alarm nil)

(DEFCONSTANT daemon-dont-care-about-regions      most-positive-fixnum)
(DEFCONSTANT daemon-dont-care-about-region-pages most-positive-fixnum)
(DEFCONSTANT daemon-dont-care-about-pages        most-positive-fixnum)
(DEFCONSTANT daemon-dont-care-about-clusters     (1+ most-negative-fixnum))

;;; Trivial macros

(DEFMACRO Daemon-Alarm-Name (elem)
  `(FIRST ,elem))

(DEFMACRO Daemon-Alarm-Function (elem)
  `(SECOND ,elem))

(DEFMACRO Daemon-Alarm-Nbr-Regions (elem)
  `(THIRD ,elem))

(DEFMACRO Daemon-Alarm-Nbr-Region-Pages (elem)
  `(FOURTH ,elem))

(DEFMACRO Daemon-Alarm-Nbr-Pages (elem)
  `(FIFTH ,elem))

(DEFMACRO Daemon-Alarm-Nbr-Clusters (elem)
  `(SIXTH ,elem))

(PROCLAIM '(SPECIAL *address-space-warning-given*
		    *gc-too-late-warning-given*
		    *swap-space-warning-given*)) 

(DEFUN check-all-gc-daemons ()
  ;; Setting one of our target values negative will wake up daemon process, since
  ;; the process wait function checks against these variables.  The target
  ;; will then be reset to something reasonable after all the daemon conditions
  ;; have been checked.
  (SETQ gc-daemon-region-cons-alarm -1)
  )

;;; Add to the queue.  Arguments are how many more regions and region-pages 
;;; must be consed or swap band clusters used before the function goes off.
;;; If you want your queue element to be more than six long, pre-create it
;;; and pass it in.  Put the don't-care values in slots where you
;;; aren't concerned about the value of the alarm.
(DEFUN gc-daemon-queue (name function n-regions n-region-pages n-pages n-clusters 
			&optional elem)
  (OR elem
      (SETQ elem (ASSOC name GC-Daemon-Queue :test #'EQ))
      (SETQ elem (LIST name function nil nil nil nil)))
  (WITHOUT-INTERRUPTS
    (SETF (daemon-alarm-nbr-regions elem) n-regions)
    (SETF (daemon-alarm-nbr-region-pages elem) n-region-pages)
    (SETF (daemon-alarm-nbr-pages elem) n-pages)
    (SETF (daemon-alarm-nbr-clusters elem) n-clusters)
    (UNLESS (MEMBER elem gc-daemon-queue :test #'EQ)
      (PUSH elem gc-daemon-queue))
    (check-all-gc-daemons)
    ))

;;; This is the function that runs in the scheduler
(DEFUN gc-daemon-function ()
  ;; Here when we know some alarm has gone off, or if a new alarm queue'd since in that
  ;; case we will want to check all alarms.
  ;;
  ;; If any alarm has reached its target value, spawn a new process to process the alarm
  ;; (generally notifying the user).
  (LOOP FOR elem IN GC-Daemon-Queue
	WHEN (OR (>= %region-cons-alarm (daemon-alarm-nbr-regions elem))
		 (>= %page-cons-alarm (daemon-alarm-nbr-region-pages elem))
		 (>= (READ-METER '%count-fresh-pages) (daemon-alarm-nbr-pages elem))
		 (<= (* %free-cluster-count Cluster-Size) (daemon-alarm-nbr-clusters elem)))
	DO (SETQ GC-Daemon-Queue (DELETE elem (THE list GC-Daemon-Queue) :test #'EQ))
	   (PROCESS-RUN-FUNCTION `(:name ,(STRING (FIRST elem))
				   :priority 5)               ;;;clm - up'd the priority
				 (SECOND elem) elem))
  ;; Determine when the next interesting time will be.
  (IF GC-Daemon-Queue
      (SETQ gc-daemon-region-cons-alarm      (LOOP FOR elem IN gc-daemon-queue
						   MINIMIZE (daemon-alarm-nbr-regions elem))
	    gc-daemon-region-page-cons-alarm (LOOP FOR elem IN gc-daemon-queue
						   MINIMIZE (daemon-alarm-nbr-region-pages elem))
	    gc-daemon-page-usage-alarm       (LOOP FOR elem IN gc-daemon-queue
						   MINIMIZE (daemon-alarm-nbr-pages elem))
	    gc-daemon-swap-space-usage-alarm (LOOP FOR elem IN gc-daemon-queue
						   MAXIMIZE (daemon-alarm-nbr-clusters elem)))
      ;; Daemon Queue nil.  Put to sleep.
      (SETQ gc-daemon-region-cons-alarm       daemon-dont-care-about-regions
	    gc-daemon-region-page-cons-alarm  daemon-dont-care-about-region-pages
	    gc-daemon-page-usage-alarm        daemon-dont-care-about-pages
	    gc-daemon-swap-space-usage-alarm  daemon-dont-care-about-clusters))
  ;; Cause process to sleep until next interesting time.
  ;; As soon as one of these conditions comes true, we'll check the daemon queue again
  ;; to see which notifications should be made.
  (SET-PROCESS-WAIT current-process
		    #'(LAMBDA ()
			(OR (>= %region-cons-alarm gc-daemon-region-cons-alarm)
			    (>= %page-cons-alarm gc-daemon-region-page-cons-alarm)
			    (>= (READ-METER '%count-fresh-pages) gc-daemon-page-usage-alarm)
			    (<= (* %free-cluster-count Cluster-Size) gc-daemon-swap-space-usage-alarm)))
		    nil)
  (SETF (process-whostate current-process) "GC Daemon"))


(DEFUN gc-daemon-restart (p)
  (SETQ *address-space-warning-given* 0
	*Gc-Too-Late-Warning-Given* nil
	*swap-space-warning-given* 0)
  ;; %REGION-CONS-ALARM and %PAGE-CONS-ALARM have changed unpredictably.
  ;; Set up all alarms so their processors will be run almost immediately.
  (DOLIST (elem gc-daemon-queue)
    (gc-daemon-queue (daemon-alarm-name elem) (daemon-alarm-function elem)
		     (- daemon-dont-care-about-regions)
		     (- daemon-dont-care-about-region-pages)
		     (- daemon-dont-care-about-pages)
		     (- daemon-dont-care-about-clusters)))
  (process-warm-boot-delayed-restart p)) 

(DEFUN arrest-gc-daemon (&optional (reason 'user))
  "Turn off all memory management daemon warnings by arresting the
GC Daemon process."
  (WHEN (AND (VARIABLE-BOUNDP gc-daemon-process)
	     (SEND gc-daemon-process :active-p))
    (SEND gc-daemon-process :arrest-reason reason))
  )

(DEFUN unarrest-gc-daemon ()
"Turn on all memory management daemon warnings by unarresting the
GC Daemon process."
  (WHEN (VARIABLE-BOUNDP gc-daemon-process)
    (LET ((reasons (SEND gc-daemon-process :arrest-reasons)))
      (WHEN reasons
	(DOLIST (r reasons) (SEND gc-daemon-process :revoke-arrest-reason r)))))
  )

(DEFUN make-gc-daemon (&optional (start-up t))
  (WHEN (AND (VARIABLE-BOUNDP gc-daemon-process)
	     (NOT (NULL gc-daemon-process)))
    ;; Unarrest daemon if necessary
    (IF (SEND gc-daemon-process :arrest-reasons)
	(unarrest-gc-daemon))
    ;; Kill process.  Since it is a simple process,
    ;; this removes it from the active processes list
    (SEND gc-daemon-process :kill))
  ;; Start up new one if desired.
  (WHEN start-up
    (SETQ gc-daemon-process
	  (MAKE-PROCESS "GC Daemon"
			:simple-p t
			:warm-boot-action 'gc-daemon-restart
			:priority 5))     ;;; clm - up'd the priority
    (SEND gc-daemon-process :preset 'gc-daemon-function)
    (SEND gc-daemon-process :run-reason 'start-gc-daemon)
    (SETQ gc-daemon-queue nil)
    (init-gc-daemon-queue))
  )

(DEFUN init-gc-daemon-queue ()
  (SETQ gc-daemon-queue nil)
  ;; Address space warning daemon
  (gc-daemon-queue 'address-space-warning 'address-space-warning
		 (- daemon-dont-care-about-regions)
		 (- daemon-dont-care-about-region-pages)
		 daemon-dont-care-about-pages
		 daemon-dont-care-about-clusters)
;;  ;; Too late for GC warning daemon
;;  (gc-daemon-queue 'gc-too-late-warning 'gc-too-late-warning
;;		   daemon-dont-care-about-regions
;;		   daemon-dont-care-about-region-pages
;;		   (- daemon-dont-care-about-pages)
;;		   daemon-dont-care-about-clusters)
  ;; Swap space low daemon
  (gc-daemon-queue 'swap-space-warning 'swap-space-warning
		   daemon-dont-care-about-regions
		   daemon-dont-care-about-region-pages
		   daemon-dont-care-about-pages
		   (- daemon-dont-care-about-clusters)))

;; Args like FORMAT, but stream comes from GC-DAEMON-REPORT-STREAM
(DEFUN gc-daemon-report (format-control &rest format-args)
  (COND
    ((NULL gc-daemon-report-stream) nil)
    ((EQ gc-daemon-report-stream t)
     (APPLY 'process-run-function '(:name "GC Daemon Notification" :priority 5)
	    #'tv:notify nil format-control format-args))           ;;; clm - up'd the priority
    (t (FUNCALL gc-daemon-report-stream :fresh-line)
       (APPLY #'FORMAT gc-daemon-report-stream format-control format-args))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Address space low daemon.
;;;

(DEFVAR *address-space-warning-given* 0)

;;; Controlling parameters:
;;; Amount of free space at which to start complaining, fraction by which to go down

(DEFPARAMETER Address-Space-Warning-Low-Quanta 75.)
(DEFPARAMETER Address-Space-Warning-Low-Regions 150.) 
(DEFPARAMETER Address-Space-Warning-Quanta-Ratio 0.75) 
(DEFPARAMETER Address-Space-Warning-Regions-Ratio 0.75)
 
;; These two are where it last notified the user
(DEFVAR Address-Space-Warning-Quanta nil)
(DEFVAR Address-Space-Warning-Regions nil)

(DEFUN address-space-warning (elem &aux (complain nil))
  ;; What is our status now?
  (LET* ((free-words (get-unassigned-address-space-size))
	 (free-quanta (TRUNCATE free-words %address-space-quantum-size))
	 (free-regions (number-of-free-regions)))
    
    ;; Determine condition & complain if necessary.
    (COND ((AND (>= free-quanta address-space-warning-low-quanta)
		(>= free-regions address-space-warning-low-regions))
	   ;; No need to complain at all, reset everything
	   (SETQ complain nil
		 address-space-warning-quanta address-space-warning-low-quanta
	         address-space-warning-regions address-space-warning-low-regions))
	  
	  ((OR (< free-quanta
		  (* address-space-warning-quanta address-space-warning-quanta-ratio))
	       (< free-regions
		  (* address-space-warning-regions address-space-warning-regions-ratio)))
	   ;; Time to complain again, space significantly lower than last time
	   (SETQ complain '<
		 address-space-warning-quanta free-quanta
		 address-space-warning-regions free-regions))
	  
	  ((AND (> free-regions
		   (FLOOR address-space-warning-regions address-space-warning-regions-ratio))
		(> free-quanta
		   (FLOOR address-space-warning-quanta address-space-warning-quanta-ratio)))
	   ;; Significantly more space than there was before, let user know
	   (SETQ complain '>
		 address-space-warning-quanta free-quanta
		 address-space-warning-regions free-regions)))
    
    ;; If suppose to complain, do so
    (UNLESS (> *address-space-warning-given* 15.)
      (COND ((EQ complain '<)
	     (INCF *address-space-warning-given*)
	     (gc-daemon-report
	       "Address space low!  You have ~:[only ~]~:Dk words of address space left (and ~:[only ~]~D free regions)."
	       (> free-quanta address-space-warning-low-quanta)
	       (TRUNCATE free-words 1024.)
	       (> free-regions address-space-warning-low-regions)
	       free-regions))
	    ((EQ complain '>)
	     (gc-daemon-report
	       "Address space has increased.  You now have ~:Dk words of address space left and ~D free regions."
	       (TRUNCATE free-words 1024.)
	       free-regions))))

    ;; Re-queue self
    (gc-daemon-queue 'address-space-warning 'address-space-warning
		     ;; Fire again when %region-cons-alarm is bigger by some delta.
		     (+ %region-cons-alarm
			;; The delta is some portion of the current number of free regions.
			(- free-regions
			   (MIN address-space-warning-low-regions
				(FLOOR (* free-regions address-space-warning-regions-ratio)))))
		     ;; Complain again when %page-cons-alarm is bigger by some delta.		     
		     (+ %page-cons-alarm
			;; The delta is some portion of the current number of words free for quanta.
			(- (TRUNCATE free-words page-size)
			   (* %Address-Space-Quantum-Size-In-Pages
			      (MIN address-space-warning-low-quanta
				   (FLOOR (* free-quanta address-space-warning-quanta-ratio))))))
		     daemon-dont-care-about-pages
		     daemon-dont-care-about-clusters
		     elem))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Swap Space low warning
;;;

(DEFPARAMETER *swap-space-margin* 10.)		;; Complain when 10% of swap space left
(DEFVAR *swap-space-warning-given* 0)

(DEFUN swap-space-warning (elem)
  ;; Check free swap space to see if we're in trouble yet.
  (MULTIPLE-VALUE-BIND (size free)
      (swap-space-info)
    (cond ((zerop size)
	   (gc-daemon-report
		"No swap space exists!~
             ~%~7tYou should reboot or add more PAGE bands immediately!"))
	  (t
	   (LET ((percent-free (if (zerop size)
				   0
				   (TRUNCATE (* free 100.) size))))
	     (unless (> *swap-space-warning-given* 10.)
	       ;; Start complaining when less than a certain percent
	       ;; of swap space is left.
	       (WHEN (< percent-free *swap-space-margin*)
		 (INCF *swap-space-warning-given*)
		 (IF (< percent-free (TRUNCATE *swap-space-margin* 2))
		     (gc-daemon-report
		       "Swap space very low!  Total blocks: ~d,  Free blocks: ~d (~d%).~
          ~%~7tYou need to reboot or add more PAGE bands very soon."
		       size free percent-free)
		     (gc-daemon-report
		       "Swap space low.  Total blocks: ~d,  Free blocks: ~d (~d%)."
		       size free percent-free)))
	       ;; Always re-queue alarm entry.
	       ;; Set alarm to go off again when number of free clusters is half what it is now.
	       (gc-daemon-queue 'swap-space-warning 'swap-space-warning
				most-positive-fixnum most-positive-fixnum most-positive-fixnum
				(TRUNCATE free 2.) elem)))))
    ))


;;;
;;; Start up DAEMON process
;;;

(EVAL-WHEN (LOAD)
  (make-gc-daemon)				; Various virtual-memory monitors.
  )