Show
Ignore:
Timestamp:
08/18/11 11:03:57 (21 months ago)
Author:
rjs
Message:

Update from System 78.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • trunk/lisp/lispm2/gc.lisp

    r247 r278  
    55;;; Some GC-related functions that need to be in the cold-load can be found in QRAND. 
    66 
    7 ;*** Needs a facility which continuously maintains a second who-line with gc stats 
    8 ;*** Needs a way to sound a warning when you are close to running out of virtual memory 
     7;*** Needs a facility which continuously maintains a second who-line with gc stats? 
    98 
    109 
    … …  
    4241                                        ;like a copying garbage collector. 
    4342 
    44 ;;; Fix some things which the cold-load generator sets up wrong. 
    45 (DEFUN GC-ONCE-INIT (&AUX BITS) 
    46   ;; The cold-load does not set up the %%REGION-SCAVENGE-ENABLE bits, and gets 
    47   ;; the REGION-GC-POINTER's wrong, at least in LINEAR-PDL-AREA and LINEAR-BIND-PDL-AREA. 
    48   ;; This then gets propagated through all newly-created regions. 
    49   (DO REGION SIZE-OF-AREA-ARRAYS (1- REGION) (MINUSP REGION) 
    50     (STORE (REGION-GC-POINTER REGION) 0) ;assuming no compact-consing regions yet 
    51     (SETQ BITS (REGION-BITS REGION)) 
    52     (STORE (REGION-BITS REGION) 
    53            (%LOGDPB (SELECT (LDB %%REGION-SPACE-TYPE BITS) 
    54                   ;; These should not be scavenged 
    55                   ((%REGION-SPACE-FREE %REGION-SPACE-EXITED 
    56                     %REGION-SPACE-EXTRA-PDL ;Very important!! This does not follow the 
    57                                             ;prescribed protocol for use of header-forward 
    58                                             ;and body-forward.  Also this area gets randomly 
    59                                             ;reset without interfacing with the scavenger. 
    60                     %REGION-SPACE-WIRED %REGION-SPACE-USER-PAGED) 0) 
    61                   ;; These usually should be scavenged, except for efficiency certain ones 
    62                   ;; that only contain fixnums will be bypassed 
    63                   (%REGION-SPACE-FIXED 
    64                     (COND ((OR (= REGION MICRO-CODE-SYMBOL-AREA) 
    65                                (= REGION PAGE-TABLE-AREA) 
    66                                (= REGION PHYSICAL-PAGE-DATA) 
    67                                (= REGION REGION-ORIGIN) 
    68                                (= REGION REGION-LENGTH) 
    69                                (= REGION REGION-BITS) 
    70                                (= REGION REGION-SORTED-BY-ORIGIN) 
    71                                (= REGION REGION-FREE-POINTER) 
    72                                (= REGION REGION-GC-POINTER) 
    73                                (= REGION REGION-LIST-THREAD) 
    74                                (= REGION AREA-REGION-LIST) 
    75                                (= REGION AREA-REGION-SIZE) 
    76                                (= REGION AREA-MAXIMUM-SIZE) 
    77                                (= REGION MICRO-CODE-ENTRY-AREA) 
    78                                (= REGION MICRO-CODE-ENTRY-MAX-PDL-USAGE)) 
    79                            0) 
    80                           (T 1))) 
    81                   ;; Newspace doesn't need scavenging 
    82                   (%REGION-SPACE-NEW 0) 
    83                   ;; Other regions should be scavenged 
    84                   (OTHERWISE 1)) 
    85                 %%REGION-SCAVENGE-ENABLE BITS))) 
    86   ;; Crank up the default region-size for certain areas 
    87   (DO L '(WORKING-STORAGE-AREA 200000 MACRO-COMPILED-PROGRAM 200000 
    88           P-N-STRING 200000 NR-SYM 100000) 
    89       (CDDR L) (NULL L) 
    90     (STORE (AREA-REGION-SIZE (SYMEVAL (CAR L))) (CADR L)))) 
    91  
    92 (ADD-INITIALIZATION "GC-ONCE" '(GC-ONCE-INIT) '(ONCE)) 
    93  
    94 ;;; Check the size of the free regions in case this is a band 
    95 ;;; that was shipped over from a machine with a different size paging partition. 
    96 (DEFUN GC-CHECK-FREE-REGIONS (PAGE-PART-SIZE) 
    97   ;; Find the size of the paging partition and adjust the free area if necessary. 
    98   ;; The microcode already knows this, but it isn't left around, so read the label again. 
    99   (LET ((HIGHEST-PAGE-USED 0) (PAGE-NUMBER-FIELD 1020)) 
    100     (WITHOUT-INTERRUPTS  ;Don't let any allocation happen 
    101       (DO REGION SIZE-OF-AREA-ARRAYS (1- REGION) (MINUSP REGION) 
    102         (LET ((REGION-TOP (+ (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION)) 
    103                              (LDB PAGE-NUMBER-FIELD (REGION-LENGTH REGION))))) 
    104           (SETQ HIGHEST-PAGE-USED (MAX REGION-TOP HIGHEST-PAGE-USED)))) 
    105       (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION) 
    106         (LET ((REGION-TOP (+ (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION)) 
    107                              (LDB PAGE-NUMBER-FIELD (REGION-LENGTH REGION))))) 
    108           (COND ((OR (> REGION-TOP PAGE-PART-SIZE) (= REGION-TOP HIGHEST-PAGE-USED)) 
    109                  (STORE (REGION-LENGTH REGION) 
    110                         (%LOGDPB (MAX 0 (- PAGE-PART-SIZE 
    111                                            (LDB PAGE-NUMBER-FIELD (REGION-ORIGIN REGION)))) 
    112                                  PAGE-NUMBER-FIELD 0))))))))) 
    113  
    114 (DEFUN GC-REPORT-STREAM () 
    115   (IF (EQ GC-REPORT-STREAM T) (TV:GET-NOTIFICATION-STREAM) GC-REPORT-STREAM)) 
     43(DEFVAR GC-SCAVENGER-WS-SIZE)           ;Physical pages the scavenger may use. 
     44                                        ; Don't set this variable directly, 
     45                                        ; instead call SET-SCAVENGER-WS. 
     46 
     47;Args like FORMAT, but stream comes from GC-REPORT-STREAM 
     48(DEFUN GC-REPORT (FORMAT-CONTROL &REST FORMAT-ARGS) 
     49  (COND ((NULL GC-REPORT-STREAM)) 
     50        ((EQ GC-REPORT-STREAM T) 
     51         (LEXPR-FUNCALL #'TV:NOTIFY NIL FORMAT-CONTROL FORMAT-ARGS)) 
     52        (T (LEXPR-FUNCALL #'FORMAT GC-REPORT-STREAM FORMAT-CONTROL FORMAT-ARGS)))) 
    11653 
    11754;;; Flipper 
    … …  
    14784  (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE) 
    14885                (GC-GET-SPACE-SIZES) 
    149     (AND GC-REPORT-STREAM 
    150          (FORMAT (GC-REPORT-STREAM) ;separate static from exited when exited exists? 
    151              "~&[GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D.]~%" 
    152              DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE)) 
     86    (GC-REPORT ;separate static from exited when exited exists? 
     87                "GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D." 
     88                DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE) 
    15389    ;; Perform whatever actions other programs need to do on flips 
    15490    (MAPC #'EVAL GC-EVERY-FLIP-LIST) 
    … …  
    174110       (STATIC-SIZE 0) 
    175111       (EXITED-SIZE 0) 
    176        (FREE-SIZE 0) 
     112       (FREE-SIZE (GET-FREE-SPACE-SIZE)) 
    177113       (OLD-SIZE 0)) 
    178114      ((MINUSP REGION) 
    179        (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION) 
    180          (SETQ FREE-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION)) FREE-SIZE))) 
    181115       (RETURN DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE OLD-SIZE)) 
    182116    (SETQ SZ (24-BIT-UNSIGNED (REGION-FREE-POINTER REGION))) 
    183117    (SELECT (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) 
    184       ((%REGION-SPACE-NEW %REGION-SPACE-COPY) 
    185         (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE))) 
     118      ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2 
     119        %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6) 
     120       (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE))) 
    186121      (%REGION-SPACE-OLD 
    187122        (SETQ OLD-SIZE (+ SZ OLD-SIZE))) 
    188       ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED %REGION-SPACE-EXIT) 
    189         (SETQ STATIC-SIZE (+ SZ STATIC-SIZE))) 
    190       (%REGION-SPACE-EXITED 
    191         (SETQ EXITED-SIZE (+ SZ EXITED-SIZE)))))) 
     123      ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED) 
     124        (SETQ STATIC-SIZE (+ SZ STATIC-SIZE)))))) 
     125 
     126;Returns the number of words of free space 
     127(DEFUN GET-FREE-SPACE-SIZE () 
     128  (* (LOOP FOR I FROM (// (+ (REGION-ORIGIN INIT-LIST-AREA) (REGION-LENGTH INIT-LIST-AREA)) 
     129                          %ADDRESS-SPACE-QUANTUM-SIZE) 
     130                 BELOW (// VIRTUAL-MEMORY-SIZE %ADDRESS-SPACE-QUANTUM-SIZE) 
     131           COUNT (ZEROP (AREF #'ADDRESS-SPACE-MAP I))) 
     132     %ADDRESS-SPACE-QUANTUM-SIZE)) 
    192133 
    193134;;; If called when %GC-FLIP-READY is true, returns a conservative (over) estimate of 
    … …  
    279220(DEFUN GC-RECLAIM-OLDSPACE () 
    280221  ;; Make sure all regions are clean (no pointers to oldspace) 
    281   (DO ((%SCAVENGER-WS-ENABLE NIL))  ;Use all of memory as long as using all of processor 
     222  (DO ((%SCAVENGER-WS-ENABLE 0))  ;Use all of memory as long as using all of processor 
    282223      (%GC-FLIP-READY)  ;Stop when scavenger says all is clean 
    283224    (%GC-SCAVENGE 10000)) 
    … …  
    288229              (OLD-USED-SIZE 0)) 
    289230             ((MINUSP REGION) 
    290               (FORMAT (GC-REPORT-STREAM) 
    291                       "~&[GC: Flushing oldspace.  allocated=~D., used=~D.]~%" 
    292                       OLD-TOTAL-SIZE OLD-USED-SIZE)) 
     231              (GC-REPORT "GC: Flushing oldspace.  allocated=~D., used=~D." 
     232                         OLD-TOTAL-SIZE OLD-USED-SIZE)) 
    293233           (COND ((= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-OLD) 
    294234                  (SETQ OLD-TOTAL-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION)) 
    … …  
    301241      (AND (OR (MINUSP AREA-NUMBER) (> AREA-NUMBER SIZE-OF-AREA-ARRAYS)) 
    302242           (FERROR NIL "Area-symbol ~S clobbered" AREA)) ;don't get grossly faked out 
    303       (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER)))) 
     243      (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER))) 
     244  (SETQ GC-DAEMON-PAGE-CONS-ALARM -1))  ;Wake up daemon process 
    304245 
    305246;;; GC-RECLAIM-OLDSPACE-AREA - deletes all old-space regions of a specified area, 
    … …  
    368309              (T                ;Wait a while before flipping, then compute frob again 
    369310               (SETQ %PAGE-CONS-ALARM 0) 
    370                (AND GC-REPORT-STREAM 
    371                     (FORMAT (GC-REPORT-STREAM) 
    372                             "~&[GC: Allowing ~D. words more consing before flip.]~%" 
    373                             (- FREE-SPACE COMMITTED-FREE-SPACE))) 
     311               (GC-REPORT "GC: Allowing ~D. words more consing before flip." 
     312                          (- FREE-SPACE COMMITTED-FREE-SPACE)) 
    374313               (SETQ GC-PAGE-CONS-ALARM-MARK 
    375314                     (// (- FREE-SPACE COMMITTED-FREE-SPACE) PAGE-SIZE)) 
    … …  
    382321(DEFUN GC-ON () 
    383322  (OR (BOUNDP 'GC-PROCESS) 
    384       (SETQ GC-PROCESS (PROCESS-CREATE "Garbage Collector"))) 
     323      (SETQ GC-PROCESS (MAKE-PROCESS "Garbage Collector"))) 
    385324  (PROCESS-PRESET GC-PROCESS #'GC-PROCESS) 
    386325  (PROCESS-ENABLE GC-PROCESS)                   ;Start flipper process 
    … …  
    417356                   (GC-FLIP-NOW)) 
    418357                (T              ;Wait a while before flipping, then compute frob again 
    419                  (AND GC-REPORT-STREAM 
    420                       (FORMAT (GC-REPORT-STREAM) 
    421                               "~&[GC: Allowing ~D. words more consing before flip.]~%" 
    422                               (- FREE-SPACE COMMITTED-FREE-SPACE))) 
     358                 (GC-REPORT "GC: Allowing ~D. words more consing before flip."  
     359                            (- FREE-SPACE COMMITTED-FREE-SPACE)) 
    423360                 (SETQ %PAGE-CONS-ALARM 0 
    424361                       GC-PAGE-CONS-ALARM-MARK (// (- FREE-SPACE COMMITTED-FREE-SPACE) 
    … …  
    440377      (LET ((BITS (REGION-BITS REGION))) 
    441378        (SELECT (LDB %%REGION-SPACE-TYPE BITS) 
    442           ((%REGION-SPACE-NEW %REGION-SPACE-COPY) 
    443              (STORE (REGION-BITS REGION) 
    444                     (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE 
    445                              (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS))))))))) 
     379          ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2 
     380            %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6) 
     381           (STORE (REGION-BITS REGION) 
     382                  (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE 
     383                           (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS))))))))) 
    446384 
    447385;;; Make a static area dynamic.  This can happen right away, although it really 
    … …  
    476414  (PUSH `(MAKE-AREA-STATIC-INTERNAL ,AREA) GC-SECOND-NEXT-FLIP-LIST) 
    477415  (MAKE-AREA-DYNAMIC AREA)) 
     416 
     417;Find boundary in physical core for scavenger working set.  Scan up until right number 
     418; of non-wired pages passed. 
     419(DEFUN SET-SCAVENGER-WS (WS-SIZE) 
     420  (DO ((PHYS-ADR 0 (+ PHYS-ADR PAGE-SIZE)) 
     421       (PAGES-FOUND 0)) 
     422      ((>= PAGES-FOUND WS-SIZE) 
     423       (SETQ GC-SCAVENGER-WS-SIZE WS-SIZE 
     424             %SCAVENGER-WS-ENABLE PHYS-ADR)) 
     425    (LET ((PPD-ADR (+ (REGION-ORIGIN PHYSICAL-PAGE-DATA) 
     426                      (// PHYS-ADR PAGE-SIZE)))) 
     427      (IF (NOT (AND (= (%P-LDB 0020 PPD-ADR) 177777)            ;flush if fixed wired 
     428                    ( (%P-LDB 2020 PPD-ADR) 177777))) 
     429          (LET ((PHT-ADR (+ (%P-LDB 0020 PPD-ADR) (REGION-ORIGIN PAGE-TABLE-AREA)))) 
     430            (IF (NOT 
     431                  (AND (NOT (ZEROP (%P-LDB %%PHT1-VALID-BIT PHT-ADR))) 
     432                       (= (%P-LDB %%PHT1-SWAP-STATUS-CODE PHT-ADR) %PHT-SWAP-STATUS-WIRED))) 
     433                (SETQ PAGES-FOUND (1+ PAGES-FOUND)))))))) 
     434 
     435(DEFUN SET-SWAP-RECOMMENDATIONS-OF-AREA (AREA SWAP-RECOMMENDATIONS) 
     436  (CHECK-ARG AREA (AND (NUMBERP AREA) ( 
     437 AREA 0) ( 
     438 AREA SIZE-OF-AREA-ARRAYS)) 
     439             "an area number") 
     440  (WITHOUT-INTERRUPTS 
     441    (STORE (AREA-SWAP-RECOMMENDATIONS AREA) SWAP-RECOMMENDATIONS) 
     442    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION) 
     443      (STORE (REGION-BITS REGION) 
     444             (%LOGDPB SWAP-RECOMMENDATIONS %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION)))))) 
     445 
     446(DEFUN CHECK-SWAP-RECOMMENDATIONS-OF-AREA (AREA) 
     447  (LET ((SWAP-RECOMMENDATIONS (AREA-SWAP-RECOMMENDATIONS AREA))) 
     448    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION) 
     449        (IF (NOT (= (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION)) 
     450                    SWAP-RECOMMENDATIONS)) 
     451            (FORMAT T "~%Swap recomendations of region ~S are ~s but should be ~s." 
     452                    REGION 
     453                    (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION)) 
     454                    SWAP-RECOMMENDATIONS))))) 
     455 
     456(DEFUN SET-ALL-SWAP-RECOMMENDATIONS (N) 
     457  (DOLIST (NAME-OF-AREA AREA-LIST) 
     458    (SET-SWAP-RECOMMENDATIONS-OF-AREA (SYMEVAL NAME-OF-AREA) N))) 
     459 
     460 
     461;;; GC-Daemon facility. 
     462 
     463;;; A GC-daemon is a set of address-space conditions to wait for, and a 
     464;;; function to run (in a separate process) when conditions are met. 
     465 
     466;;; This simple process implements the queue 
     467(DEFVAR GC-DAEMON-PROCESS) 
     468 
     469;;; Each element on this queue is a list at least four long: 
     470;;;     (name function region-cons-alarm page-cons-alarm) 
     471;;; If either alarm is  
     472 the value in the queue, the function is called 
     473;;; in a background process with the queue element as its argument. 
     474;;; If any oldspace is reclaimed, all entries on the queue go off, since the 
     475;;; allocation of address space has just changed.  This may need improvement 
     476;;; in the future, when oldspace reclamation is more frequent. 
     477(DEFVAR GC-DAEMON-QUEUE NIL) 
     478 
     479(DEFVAR GC-DAEMON-PAGE-CONS-ALARM 0) 
     480(DEFVAR GC-DAEMON-REGION-CONS-ALARM 0) 
     481 
     482;;; Add to the queue.  Arguments are how many more regions and pages  
     483;;; must be consed before the function goes off.  If you want your 
     484;;; queue element to be more than four long, pre-create it and pass it in 
     485(DEFUN GC-DAEMON-QUEUE (NAME FUNCTION N-REGIONS N-PAGES &OPTIONAL ELEM) 
     486  (OR ELEM (SETQ ELEM (ASSQ NAME GC-DAEMON-QUEUE)) (SETQ ELEM (LIST NAME FUNCTION NIL NIL))) 
     487  (WITHOUT-INTERRUPTS 
     488    (SETF (THIRD ELEM) (+ %REGION-CONS-ALARM N-REGIONS)) 
     489    (SETF (FOURTH ELEM) (+ %PAGE-CONS-ALARM N-PAGES)) 
     490    (OR (MEMQ ELEM GC-DAEMON-QUEUE) 
     491        (PUSH ELEM GC-DAEMON-QUEUE)) 
     492    (SETQ GC-DAEMON-PAGE-CONS-ALARM -1)))       ;Wake up daemon process 
     493 
     494;;; This is the function that runs in the scheduler 
     495(DEFUN GC-DAEMON-FUNCTION () 
     496  ;; Fire off any interesting queue entries 
     497  (LOOP FOR ELEM IN GC-DAEMON-QUEUE 
     498        WHEN (OR ( 
     499 %REGION-CONS-ALARM (THIRD ELEM)) 
     500                 ( 
     501 %PAGE-CONS-ALARM (FOURTH ELEM))) 
     502          DO (SETQ GC-DAEMON-QUEUE (DELQ ELEM GC-DAEMON-QUEUE)) 
     503             (PROCESS-RUN-FUNCTION (STRING (FIRST ELEM)) (SECOND ELEM) ELEM))   
     504  ;; Cause process to sleep until next interesting time 
     505  (IF GC-DAEMON-QUEUE 
     506      (SETQ GC-DAEMON-REGION-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE 
     507                                              MINIMIZE (THIRD ELEM)) 
     508            GC-DAEMON-PAGE-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE 
     509                                            MINIMIZE (FOURTH ELEM))) 
     510      (SETQ GC-DAEMON-REGION-CONS-ALARM 37777777 
     511            GC-DAEMON-PAGE-CONS-ALARM 37777777))       
     512  (SET-PROCESS-WAIT CURRENT-PROCESS 
     513                    #'(LAMBDA () 
     514                        (OR ( 
     515 %REGION-CONS-ALARM GC-DAEMON-REGION-CONS-ALARM) 
     516                            ( 
     517 %PAGE-CONS-ALARM GC-DAEMON-PAGE-CONS-ALARM))) 
     518                    NIL) 
     519  (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) "GC Daemon")) 
     520 
     521(DEFUN START-GC-DAEMON () 
     522  (OR (BOUNDP 'GC-DAEMON-PROCESS) 
     523      (SETQ GC-DAEMON-PROCESS (MAKE-PROCESS "GC Daemon" 
     524                                ':SIMPLE-P T 
     525                                ':WARM-BOOT-ACTION 'GC-DAEMON-RESTART))) 
     526  (FUNCALL GC-DAEMON-PROCESS ':PRESET 'GC-DAEMON-FUNCTION) 
     527  (FUNCALL GC-DAEMON-PROCESS ':RUN-REASON 'START-GC-DAEMON)) 
     528 
     529(DEFUN GC-DAEMON-RESTART (P) 
     530  ;; %REGION-CONS-ALARM and %PAGE-CONS-ALARM have changed unpredictably 
     531  ;; so schedule all gc-daemons to go off almost immediately 
     532  (DOLIST (ELEM GC-DAEMON-QUEUE) 
     533    (GC-DAEMON-QUEUE (FIRST ELEM) (SECOND ELEM) 1 1 ELEM)) 
     534  (PROCESS-WARM-BOOT-DELAYED-RESTART P)) 
     535 
     536(START-GC-DAEMON) 
     537 
     538;;; GC-daemon which watches for exhaustion of address space 
     539 
     540;;; Controlling parameters: 
     541;;; Amount of free space at which to start complaining, fraction by which to go down 
     542(DEFCONST ADDRESS-SPACE-WARNING-LOW-WORDS 1000000.) 
     543(DEFCONST ADDRESS-SPACE-WARNING-LOW-REGIONS 50.) 
     544(DEFCONST ADDRESS-SPACE-WARNING-WORDS-RATIO 0.75) 
     545(DEFCONST ADDRESS-SPACE-WARNING-REGIONS-RATIO 0.75) 
     546;; These two are where it last notified the user 
     547(DEFVAR ADDRESS-SPACE-WARNING-WORDS NIL) 
     548(DEFVAR ADDRESS-SPACE-WARNING-REGIONS NIL) 
     549 
     550(DEFUN ADDRESS-SPACE-WARNING (ELEM &AUX (COMPLAIN NIL)) 
     551  ;; Is it time to complain? 
     552  (LET ((FREE-WORDS (GET-FREE-SPACE-SIZE)) 
     553        (FREE-REGIONS 
     554          (LOOP FOR REGION = (SYSTEM-COMMUNICATION-AREA %SYS-COM-FREE-REGION#-LIST) 
     555                           THEN (REGION-LIST-THREAD REGION) 
     556                UNTIL (MINUSP REGION) 
     557                COUNT T))) 
     558    (COND ((AND ( 
     559 FREE-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS) 
     560                ( 
     561 FREE-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS)) 
     562           ;; No need to complain at all, reset everything 
     563           (SETQ ADDRESS-SPACE-WARNING-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS) 
     564           (SETQ ADDRESS-SPACE-WARNING-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS)) 
     565          ((OR (< FREE-WORDS 
     566                  (* ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO)) 
     567               (< FREE-REGIONS 
     568                  (* ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO))) 
     569           ;; Time to complain again, space significantly lower than last time 
     570           (SETQ COMPLAIN '< 
     571                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS 
     572                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS)) 
     573          ((AND (> FREE-REGIONS 
     574                   (// ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO)) 
     575                (> FREE-WORDS 
     576                   (// ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO))) 
     577           ;; Significantly more space than there was before, let user know 
     578           (SETQ COMPLAIN '> 
     579                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS 
     580                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS))) 
     581    ;; Re-queue self 
     582    (GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING 
     583                     (FIX (* FREE-REGIONS (- 1 ADDRESS-SPACE-WARNING-REGIONS-RATIO))) 
     584                     (FIX (* (// FREE-WORDS PAGE-SIZE) 
     585                             (- 1 ADDRESS-SPACE-WARNING-WORDS-RATIO))) 
     586                     ELEM) 
     587    ;; If suppose to complain, do so 
     588    (AND COMPLAIN 
     589         (TV:NOTIFY NIL "~:[Address space low!  ~]You have ~D regions and ~ 
     590                                      ~DK words of address space left" 
     591                    (EQ COMPLAIN '>) FREE-REGIONS (// FREE-WORDS 1024.))))) 
     592 
     593;; Start 
     594(GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING 0 0) 
    478595 
    479596;;; Peek display