LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031654. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "DAEMONS" :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 2758720389. :AUTHOR "REL3" :LENGTH-IN-BYTES 19807. :LENGTH-IN-BLOCKS 20. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- 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 (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) 1984,1987 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.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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-QueueWHEN (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 (STRING (FIRST elem)) (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 theGC 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 theGC 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))    (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")    #'tv:notify nil format-control format-args))    (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))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Too late to GC warning.;;;;;(DEFVAR*gc-too-late-warning-given* nil);;(DEFUN gc-too-late-warning (elem);;  (LET* ((batch-warning-flag;;   ;; T means warn about batch gc, NIL means warn about incremental.;;   (OR *gc-too-late-warning-given*;;       gc-reclaim-immediately;;       gc-reclaim-immediately-if-necessary));; current-free-space needed-free-space)    ;;    (MULTIPLE-VALUE-SETQ (needed-free-space current-free-space);;       (get-space-needed-for-gc batch-warning-flag nil t));;    (SETQ needed-free-space (* needed-free-space;;       (OR gc-flip-minimum-ratio gc-flip-ratio)))    ;;    (WHEN (AND %gc-flip-ready          ;; Done scavenging;;       (NEQ *gc-too-late-warning-given* 'batch)   ;; Not already given last too-late warning;;       (NOT (SEND gc-process ':active-p))  ;; GC process not already running;;                                                  ;;    (if it is running, it will do flip!);;       (>= needed-free-space current-free-space)) ;; Not enough free space.;;      ;; Record fact that warning given.;;      (SETQ *gc-too-late-warning-given*;;    (IF batch-warning-flag 'batch t));;      (gc-daemon-report;;(IF batch-warning-flag;;         "It will soon be too late to start even a batch garbage collection ~;;             ~%~7tunless a lot of your consing has been garbage. ~;;            ~2%~7tUse (GC-STATUS) for more information.";;         "It is nearly too late to start incremental garbage collection ~;;            ~%~7tunless a lot of your consing has been garbage. ~;;            ~2%~7tBatch garbage collection (GC) will remain possible for a while. ~;;             ~%~7tUse (GC-STATUS) for more information.")))    ;;    ;; Re-queue self;;    (gc-daemon-queue 'gc-too-late-warning 'gc-too-late-warning;;     daemon-dont-care-about-regions;;     (+ %page-cons-alarm;;(FLOOR GC-Free-Space-Needed-Delta page-size));;     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)    (LET ((percent-free (TRUNCATE (* free 100.) size)))      ;; 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.  )pace, NWORDS of (list NIL)s.       ;; For structure space, NWORDS of "".      (COND ((region-list-p reg bits)     (%p-dpb cdr-nil %%q-cdr-code start-va)     (%p-dpb dtp-symbol %%q-data-type start-va)     (%p-dpb 0 %%q-pointer start-va)     (WHEN (> nwords 1)       (%blt start-va (%pointer-plus start-va 1) (1- nwords) 1)))    ((region-structure-p reg bits)     (%p-dpb cdr-normal %%q-cdr-code start-va)     (%p-dpb (%p-ldb %%q-data-type "") %%q-data-type start-va)     (%p-dpb (%p-ldb %%q-pointer "") %%q-pointer start-va)     (WHEN (> nwords 1)       (%blt start-va (%pointer-plus start-va 1) (1- nwords) 1))))      ;; Now adjust free pointer.  