Ignore:
Timestamp:
08/18/11 18:03:57 (3 years ago)
Author:
rjs
Message:

Update from System 78.

File:
1 edited

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
     
    14885  (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE)
    14986                (GC-GET-SPACE-SIZES)
    150     (AND GC-REPORT-STREAM
    151          (FORMAT (GC-REPORT-STREAM) ;separate static from exited when exited exists?
    152              "~&[GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D.]~%"
    153              DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE))
     87    (GC-REPORT ;separate static from exited when exited exists?
     88                "GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D."
     89                DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE)
    15490    ;; Perform whatever actions other programs need to do on flips
    15591    (MAPC #'EVAL GC-EVERY-FLIP-LIST)
     
    175111       (STATIC-SIZE 0)
    176112       (EXITED-SIZE 0)
    177        (FREE-SIZE 0)
     113       (FREE-SIZE (GET-FREE-SPACE-SIZE))
    178114       (OLD-SIZE 0))
    179115      ((MINUSP REGION)
    180        (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
    181          (SETQ FREE-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION)) FREE-SIZE)))
    182116       (RETURN DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE OLD-SIZE))
    183117    (SETQ SZ (24-BIT-UNSIGNED (REGION-FREE-POINTER REGION)))
    184118    (SELECT (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION))
    185       ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
    186         (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE)))
     119      ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2
     120        %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6)
     121       (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE)))
    187122      (%REGION-SPACE-OLD
    188123        (SETQ OLD-SIZE (+ SZ OLD-SIZE)))
    189       ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED %REGION-SPACE-EXIT)
    190         (SETQ STATIC-SIZE (+ SZ STATIC-SIZE)))
    191       (%REGION-SPACE-EXITED
    192         (SETQ EXITED-SIZE (+ SZ EXITED-SIZE))))))
     124      ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED)
     125        (SETQ STATIC-SIZE (+ SZ STATIC-SIZE))))))
     126
     127;Returns the number of words of free space
     128(DEFUN GET-FREE-SPACE-SIZE ()
     129  (* (LOOP FOR I FROM (// (+ (REGION-ORIGIN INIT-LIST-AREA) (REGION-LENGTH INIT-LIST-AREA))
     130                          %ADDRESS-SPACE-QUANTUM-SIZE)
     131                 BELOW (// VIRTUAL-MEMORY-SIZE %ADDRESS-SPACE-QUANTUM-SIZE)
     132           COUNT (ZEROP (AREF #'ADDRESS-SPACE-MAP I)))
     133     %ADDRESS-SPACE-QUANTUM-SIZE))
    193134
    194135;;; If called when %GC-FLIP-READY is true, returns a conservative (over) estimate of
     
    281222(DEFUN GC-RECLAIM-OLDSPACE ()
    282223  ;; Make sure all regions are clean (no pointers to oldspace)
    283   (DO ((%SCAVENGER-WS-ENABLE NIL))  ;Use all of memory as long as using all of processor
     224  (DO ((%SCAVENGER-WS-ENABLE 0))  ;Use all of memory as long as using all of processor
    284225      (%GC-FLIP-READY)  ;Stop when scavenger says all is clean
    285226    (%GC-SCAVENGE 10000))
     
    290231              (OLD-USED-SIZE 0))
    291232             ((MINUSP REGION)
    292               (FORMAT (GC-REPORT-STREAM)
    293                       "~&[GC: Flushing oldspace.  allocated=~D., used=~D.]~%"
    294                       OLD-TOTAL-SIZE OLD-USED-SIZE))
     233              (GC-REPORT "GC: Flushing oldspace.  allocated=~D., used=~D."
     234                         OLD-TOTAL-SIZE OLD-USED-SIZE))
    295235           (COND ((= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-OLD)
    296236                  (SETQ OLD-TOTAL-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION))
     
    303243      (AND (OR (MINUSP AREA-NUMBER) (> AREA-NUMBER SIZE-OF-AREA-ARRAYS))
    304244           (FERROR NIL "Area-symbol ~S clobbered" AREA)) ;don't get grossly faked out
    305       (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER))))
     245      (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER)))
     246  (SETQ GC-DAEMON-PAGE-CONS-ALARM -1))  ;Wake up daemon process
    306247
    307248;;; GC-RECLAIM-OLDSPACE-AREA - deletes all old-space regions of a specified area,
     
    371312              (T                ;Wait a while before flipping, then compute frob again
    372313               (SETQ %PAGE-CONS-ALARM 0)
    373                (AND GC-REPORT-STREAM
    374                     (FORMAT (GC-REPORT-STREAM)
    375                             "~&[GC: Allowing ~D. words more consing before flip.]~%"
    376                             (- FREE-SPACE COMMITTED-FREE-SPACE)))
     314               (GC-REPORT "GC: Allowing ~D. words more consing before flip."
     315                          (- FREE-SPACE COMMITTED-FREE-SPACE))
    377316               (SETQ GC-PAGE-CONS-ALARM-MARK
    378317                     (// (- FREE-SPACE COMMITTED-FREE-SPACE) PAGE-SIZE))
     
    385324(DEFUN GC-ON ()
    386325  (OR (BOUNDP 'GC-PROCESS)
    387       (SETQ GC-PROCESS (PROCESS-CREATE "Garbage Collector")))
     326      (SETQ GC-PROCESS (MAKE-PROCESS "Garbage Collector")))
    388327  (PROCESS-PRESET GC-PROCESS #'GC-PROCESS)
    389328  (PROCESS-ENABLE GC-PROCESS)                   ;Start flipper process
     
    420359                   (GC-FLIP-NOW))
    421360                (T              ;Wait a while before flipping, then compute frob again
    422                  (AND GC-REPORT-STREAM
    423                       (FORMAT (GC-REPORT-STREAM)
    424                               "~&[GC: Allowing ~D. words more consing before flip.]~%"
    425                               (- FREE-SPACE COMMITTED-FREE-SPACE)))
     361                 (GC-REPORT "GC: Allowing ~D. words more consing before flip."
     362                            (- FREE-SPACE COMMITTED-FREE-SPACE))
    426363                 (SETQ %PAGE-CONS-ALARM 0
    427364                       GC-PAGE-CONS-ALARM-MARK (// (- FREE-SPACE COMMITTED-FREE-SPACE)
     
    444381      (LET ((BITS (REGION-BITS REGION)))
    445382        (SELECT (LDB %%REGION-SPACE-TYPE BITS)
    446           ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
    447              (STORE (REGION-BITS REGION)
    448                     (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE
    449                              (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS)))))))))
     383          ((%REGION-SPACE-NEW %REGION-SPACE-COPY %REGION-SPACE-NEW1 %REGION-SPACE-NEW2
     384            %REGION-SPACE-NEW3 %REGION-SPACE-NEW4 %REGION-SPACE-NEW5 %REGION-SPACE-NEW6)
     385           (STORE (REGION-BITS REGION)
     386                  (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE
     387                           (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS)))))))))
    450388
    451389;;; Make a static area dynamic.  This can happen right away, although it really
     
    481419  (MAKE-AREA-DYNAMIC AREA))
    482420
     421;Find boundary in physical core for scavenger working set.  Scan up until right number
     422; of non-wired pages passed.
     423(DEFUN SET-SCAVENGER-WS (WS-SIZE)
     424  (DO ((PHYS-ADR 0 (+ PHYS-ADR PAGE-SIZE))
     425       (PAGES-FOUND 0))
     426      ((>= PAGES-FOUND WS-SIZE)
     427       (SETQ GC-SCAVENGER-WS-SIZE WS-SIZE
     428             %SCAVENGER-WS-ENABLE PHYS-ADR))
     429    (LET ((PPD-ADR (+ (REGION-ORIGIN PHYSICAL-PAGE-DATA)
     430                      (// PHYS-ADR PAGE-SIZE))))
     431      (IF (NOT (AND (= (%P-LDB 0020 PPD-ADR) 177777)            ;flush if fixed wired
     432                    ( (%P-LDB 2020 PPD-ADR) 177777)))
     433          (LET ((PHT-ADR (+ (%P-LDB 0020 PPD-ADR) (REGION-ORIGIN PAGE-TABLE-AREA))))
     434            (IF (NOT
     435                  (AND (NOT (ZEROP (%P-LDB %%PHT1-VALID-BIT PHT-ADR)))
     436                       (= (%P-LDB %%PHT1-SWAP-STATUS-CODE PHT-ADR) %PHT-SWAP-STATUS-WIRED)))
     437                (SETQ PAGES-FOUND (1+ PAGES-FOUND))))))))
     438
     439(DEFUN SET-SWAP-RECOMMENDATIONS-OF-AREA (AREA SWAP-RECOMMENDATIONS)
     440  (CHECK-ARG AREA (AND (NUMBERP AREA) (
     441 AREA 0) (
     442 AREA SIZE-OF-AREA-ARRAYS))
     443             "an area number")
     444  (WITHOUT-INTERRUPTS
     445    (STORE (AREA-SWAP-RECOMMENDATIONS AREA) SWAP-RECOMMENDATIONS)
     446    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
     447      (STORE (REGION-BITS REGION)
     448             (%LOGDPB SWAP-RECOMMENDATIONS %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))))))
     449
     450(DEFUN CHECK-SWAP-RECOMMENDATIONS-OF-AREA (AREA)
     451  (LET ((SWAP-RECOMMENDATIONS (AREA-SWAP-RECOMMENDATIONS AREA)))
     452    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
     453        (IF (NOT (= (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))
     454                    SWAP-RECOMMENDATIONS))
     455            (FORMAT T "~%Swap recomendations of region ~S are ~s but should be ~s."
     456                    REGION
     457                    (%LOGLDB %%REGION-SWAPIN-QUANTUM (REGION-BITS REGION))
     458                    SWAP-RECOMMENDATIONS)))))
     459
     460(DEFUN SET-ALL-SWAP-RECOMMENDATIONS (N)
     461  (DOLIST (NAME-OF-AREA AREA-LIST)
     462    (SET-SWAP-RECOMMENDATIONS-OF-AREA (SYMEVAL NAME-OF-AREA) N)))
     463
     464
     465
     466;;; GC-Daemon facility.
     467
     468;;; A GC-daemon is a set of address-space conditions to wait for, and a
     469;;; function to run (in a separate process) when conditions are met.
     470
     471;;; This simple process implements the queue
     472(DEFVAR GC-DAEMON-PROCESS)
     473
     474;;; Each element on this queue is a list at least four long:
     475;;;     (name function region-cons-alarm page-cons-alarm)
     476;;; If either alarm is
     477 the value in the queue, the function is called
     478;;; in a background process with the queue element as its argument.
     479;;; If any oldspace is reclaimed, all entries on the queue go off, since the
     480;;; allocation of address space has just changed.  This may need improvement
     481;;; in the future, when oldspace reclamation is more frequent.
     482(DEFVAR GC-DAEMON-QUEUE NIL)
     483
     484(DEFVAR GC-DAEMON-PAGE-CONS-ALARM 0)
     485(DEFVAR GC-DAEMON-REGION-CONS-ALARM 0)
     486
     487;;; Add to the queue.  Arguments are how many more regions and pages
     488;;; must be consed before the function goes off.  If you want your
     489;;; queue element to be more than four long, pre-create it and pass it in
     490(DEFUN GC-DAEMON-QUEUE (NAME FUNCTION N-REGIONS N-PAGES &OPTIONAL ELEM)
     491  (OR ELEM (SETQ ELEM (ASSQ NAME GC-DAEMON-QUEUE)) (SETQ ELEM (LIST NAME FUNCTION NIL NIL)))
     492  (WITHOUT-INTERRUPTS
     493    (SETF (THIRD ELEM) (+ %REGION-CONS-ALARM N-REGIONS))
     494    (SETF (FOURTH ELEM) (+ %PAGE-CONS-ALARM N-PAGES))
     495    (OR (MEMQ ELEM GC-DAEMON-QUEUE)
     496        (PUSH ELEM GC-DAEMON-QUEUE))
     497    (SETQ GC-DAEMON-PAGE-CONS-ALARM -1)))       ;Wake up daemon process
     498
     499;;; This is the function that runs in the scheduler
     500(DEFUN GC-DAEMON-FUNCTION ()
     501  ;; Fire off any interesting queue entries
     502  (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     503        WHEN (OR (
     504 %REGION-CONS-ALARM (THIRD ELEM))
     505                 (
     506 %PAGE-CONS-ALARM (FOURTH ELEM)))
     507          DO (SETQ GC-DAEMON-QUEUE (DELQ ELEM GC-DAEMON-QUEUE))
     508             (PROCESS-RUN-FUNCTION (STRING (FIRST ELEM)) (SECOND ELEM) ELEM)) 
     509  ;; Cause process to sleep until next interesting time
     510  (IF GC-DAEMON-QUEUE
     511      (SETQ GC-DAEMON-REGION-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     512                                              MINIMIZE (THIRD ELEM))
     513            GC-DAEMON-PAGE-CONS-ALARM (LOOP FOR ELEM IN GC-DAEMON-QUEUE
     514                                            MINIMIZE (FOURTH ELEM)))
     515      (SETQ GC-DAEMON-REGION-CONS-ALARM 37777777
     516            GC-DAEMON-PAGE-CONS-ALARM 37777777))     
     517  (SET-PROCESS-WAIT CURRENT-PROCESS
     518                    #'(LAMBDA ()
     519                        (OR (
     520 %REGION-CONS-ALARM GC-DAEMON-REGION-CONS-ALARM)
     521                            (
     522 %PAGE-CONS-ALARM GC-DAEMON-PAGE-CONS-ALARM)))
     523                    NIL)
     524  (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) "GC Daemon"))
     525
     526(DEFUN START-GC-DAEMON ()
     527  (OR (BOUNDP 'GC-DAEMON-PROCESS)
     528      (SETQ GC-DAEMON-PROCESS (MAKE-PROCESS "GC Daemon"
     529                                ':SIMPLE-P T
     530                                ':WARM-BOOT-ACTION 'GC-DAEMON-RESTART)))
     531  (FUNCALL GC-DAEMON-PROCESS ':PRESET 'GC-DAEMON-FUNCTION)
     532  (FUNCALL GC-DAEMON-PROCESS ':RUN-REASON 'START-GC-DAEMON))
     533
     534(DEFUN GC-DAEMON-RESTART (P)
     535  ;; %REGION-CONS-ALARM and %PAGE-CONS-ALARM have changed unpredictably
     536  ;; so schedule all gc-daemons to go off almost immediately
     537  (DOLIST (ELEM GC-DAEMON-QUEUE)
     538    (GC-DAEMON-QUEUE (FIRST ELEM) (SECOND ELEM) 1 1 ELEM))
     539  (PROCESS-WARM-BOOT-DELAYED-RESTART P))
     540
     541(START-GC-DAEMON)
     542
     543
     544;;; GC-daemon which watches for exhaustion of address space
     545
     546;;; Controlling parameters:
     547;;; Amount of free space at which to start complaining, fraction by which to go down
     548(DEFCONST ADDRESS-SPACE-WARNING-LOW-WORDS 1000000.)
     549(DEFCONST ADDRESS-SPACE-WARNING-LOW-REGIONS 50.)
     550(DEFCONST ADDRESS-SPACE-WARNING-WORDS-RATIO 0.75)
     551(DEFCONST ADDRESS-SPACE-WARNING-REGIONS-RATIO 0.75)
     552;; These two are where it last notified the user
     553(DEFVAR ADDRESS-SPACE-WARNING-WORDS NIL)
     554(DEFVAR ADDRESS-SPACE-WARNING-REGIONS NIL)
     555
     556(DEFUN ADDRESS-SPACE-WARNING (ELEM &AUX (COMPLAIN NIL))
     557  ;; Is it time to complain?
     558  (LET ((FREE-WORDS (GET-FREE-SPACE-SIZE))
     559        (FREE-REGIONS
     560          (LOOP FOR REGION = (SYSTEM-COMMUNICATION-AREA %SYS-COM-FREE-REGION#-LIST)
     561                           THEN (REGION-LIST-THREAD REGION)
     562                UNTIL (MINUSP REGION)
     563                COUNT T)))
     564    (COND ((AND (
     565 FREE-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS)
     566                (
     567 FREE-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS))
     568           ;; No need to complain at all, reset everything
     569           (SETQ ADDRESS-SPACE-WARNING-WORDS ADDRESS-SPACE-WARNING-LOW-WORDS)
     570           (SETQ ADDRESS-SPACE-WARNING-REGIONS ADDRESS-SPACE-WARNING-LOW-REGIONS))
     571          ((OR (< FREE-WORDS
     572                  (* ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO))
     573               (< FREE-REGIONS
     574                  (* ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO)))
     575           ;; Time to complain again, space significantly lower than last time
     576           (SETQ COMPLAIN '<
     577                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS
     578                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS))
     579          ((AND (> FREE-REGIONS
     580                   (// ADDRESS-SPACE-WARNING-LOW-REGIONS ADDRESS-SPACE-WARNING-REGIONS-RATIO))
     581                (> FREE-WORDS
     582                   (// ADDRESS-SPACE-WARNING-LOW-WORDS ADDRESS-SPACE-WARNING-WORDS-RATIO)))
     583           ;; Significantly more space than there was before, let user know
     584           (SETQ COMPLAIN '>
     585                 ADDRESS-SPACE-WARNING-WORDS FREE-WORDS
     586                 ADDRESS-SPACE-WARNING-REGIONS FREE-REGIONS)))
     587    ;; Re-queue self
     588    (GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING
     589                     (FIX (* FREE-REGIONS (- 1 ADDRESS-SPACE-WARNING-REGIONS-RATIO)))
     590                     (FIX (* (// FREE-WORDS PAGE-SIZE)
     591                             (- 1 ADDRESS-SPACE-WARNING-WORDS-RATIO)))
     592                     ELEM)
     593    ;; If suppose to complain, do so
     594    (AND COMPLAIN
     595         (TV:NOTIFY NIL "~:[Address space low!  ~]You have ~D regions and ~
     596                                      ~DK words of address space left"
     597                    (EQ COMPLAIN '>) FREE-REGIONS (// FREE-WORDS 1024.)))))
     598
     599;; Start
     600(GC-DAEMON-QUEUE 'ADDRESS-SPACE-WARNING 'ADDRESS-SPACE-WARNING 0 0)
     601
    483602
    484603;;; Peek display
Note: See TracChangeset for help on using the changeset viewer.