root/trunk/lisp/lispm2/gc.lisp @ 247

Revision 247, 21.8 KB (checked in by rjs, 3 years ago)

Update.

Line 
1;;; -*- Mode: Lisp; Package: System-Internals -*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4;;; This file contains the Lisp-coded support for the Garbage Collector
5;;; Some GC-related functions that need to be in the cold-load can be found in QRAND.
6
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
9
10
11(DEFVAR GC-REPORT-STREAM T)
12        ;Where junk output from the garbage collector goes:
13        ;NIL - discard
14        ;stream - send there
15        ;T - notify (this is the default)
16
17(DEFVAR GC-PROCESS)             ;Process that runs the flipper
18
19;; These are lists of forms which are evaluated after reclaiming oldspace
20;; and before flipping newspace into oldspace.
21(DEFVAR GC-EVERY-FLIP-LIST NIL) ;Forms to evaluate on every flip
22(DEFVAR GC-NEXT-FLIP-LIST NIL)  ;Forms to evaluate just on the next flip
23(DEFVAR GC-SECOND-NEXT-FLIP-LIST NIL)   ;Forms to evaluate just on the flip after that
24(DEFVAR GC-AFTER-FLIP-LIST NIL) ;Forms to evaluate after flipping
25
26(DEFVAR GC-PAGE-CONS-ALARM-MARK 0)      ;Value that %PAGE-CONS-ALARM
27                                        ; must be greater than in order to do a flip.
28                                        ; Set by the GC process.  If %GC-FLIP-READY
29                                        ; is off, this is ignored
30
31(DEFVAR GC-FLIP-RATIO 1)                ;If the product of this number and
32                                        ;committed free space is greater
33                                        ;then the amount of free space,
34                                        ;then a flip will take place.
35
36(DEFVAR GC-RECLAIM-IMMEDIATELY NIL)     ;If non-NIL, then as soon as a flip
37                                        ;takes place, a GC-RECLAIM-OLDSPACE
38                                        ;occurs.  This essentially flushes
39                                        ;the "Await Scavenge" state of the
40                                        ;garbage collector, and removes the
41                                        ;real-time aspect, making it more
42                                        ;like a copying garbage collector.
43
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))
116
117;;; Flipper
118
119;;; This function performs a flip only if "a good idea", i.e. if the scavenger
120;;; is done and we are anywhere near running out of free space.
121;;; How close we are to running out of free space is determined by FREE-SPACE-RATIO.
122;;; This number should be greater than or equal to 1 if most of the committed free
123;;; space contains meaningful data.  If there is a lot of garbage around, then
124;;; this number can be less than 1 to reduce the frequency of flips.  The higher
125;;; this number is, the greater the chance of actually doing the flip.
126;;; The RECLAIM-IMMEDIATELY parameter will cause the scavenger to take off
127;;; as soon as the flip is done and reclaim all oldspace.  If you want to
128;;; flush all garbage "immediately", call this function with a large ratio
129;;; and with a second argument of T.
130;;; Returns T if it flipped and NIL if it didn't.
131(DEFUN GC-FLIP-MAYBE (&OPTIONAL (FLIP-RATIO GC-FLIP-RATIO) (RECLAIM-IMMEDIATELY NIL))
132  (AND %GC-FLIP-READY
133       (MULTIPLE-VALUE-BIND (COMMITTED-FREE-SPACE FREE-SPACE)
134           (GC-GET-COMMITTED-FREE-SPACE)
135         (COND (( (* FLIP-RATIO COMMITTED-FREE-SPACE) FREE-SPACE)
136                (GC-FLIP-NOW)
137                (IF RECLAIM-IMMEDIATELY (GC-RECLAIM-OLDSPACE))
138                T)))))
139
140;;; This function performs a flip.  It can be called either by the user
141;;; or by the GC process, at any time (much faster if scavenger is done already!)
142;;; Must return T for GC-FLIP-MAYBE.
143(DEFUN GC-FLIP-NOW ()
144  (IF (NOT %GC-FLIP-READY) (GC-RECLAIM-OLDSPACE)) ;In case not reclaimed already
145  (SETQ %PAGE-CONS-ALARM 0 %REGION-CONS-ALARM 0)  ;avoid overflow in these fixnums
146  (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE)
147                (GC-GET-SPACE-SIZES)
148    (AND GC-REPORT-STREAM
149         (FORMAT (GC-REPORT-STREAM) ;separate static from exited when exited exists?
150             "~&[GC: About to flip.  Dynamic space=~D., Static space=~D., Free space=~D.]~%"
151             DYNAMIC-SIZE (+ STATIC-SIZE EXITED-SIZE) FREE-SIZE))
152    ;; Perform whatever actions other programs need to do on flips
153    (MAPC #'EVAL GC-EVERY-FLIP-LIST)
154    (MAPC #'EVAL (PROG1 GC-NEXT-FLIP-LIST
155                        (SETQ GC-NEXT-FLIP-LIST GC-SECOND-NEXT-FLIP-LIST
156                              GC-SECOND-NEXT-FLIP-LIST NIL)))
157    ;; Reset the GC scan pointers of all regions, actually only in static and fixed areas
158    ;; is it necessary.
159    (DO REGION SIZE-OF-AREA-ARRAYS (1- REGION) (MINUSP REGION)
160      (STORE (REGION-GC-POINTER REGION) 0))
161    ;; Don't forget to actually flip! (Change newspace to oldspace in all dynamic areas)
162    (%GC-FLIP T)
163    (MAPC #'EVAL GC-AFTER-FLIP-LIST)
164    T))
165
166;;; Compute total occupation of dynamic space, static space, exited space, free space,
167;;; and old space.
168;;; Returns those as five values
169(DEFUN GC-GET-SPACE-SIZES ()
170  (DO ((REGION SIZE-OF-AREA-ARRAYS (1- REGION))
171       (SZ)
172       (DYNAMIC-SIZE 0)
173       (STATIC-SIZE 0)
174       (EXITED-SIZE 0)
175       (FREE-SIZE 0)
176       (OLD-SIZE 0))
177      ((MINUSP REGION)
178       (DO REGION (AREA-REGION-LIST FREE-AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
179         (SETQ FREE-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION)) FREE-SIZE)))
180       (RETURN DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE OLD-SIZE))
181    (SETQ SZ (24-BIT-UNSIGNED (REGION-FREE-POINTER REGION)))
182    (SELECT (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION))
183      ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
184        (SETQ DYNAMIC-SIZE (+ SZ DYNAMIC-SIZE)))
185      (%REGION-SPACE-OLD
186        (SETQ OLD-SIZE (+ SZ OLD-SIZE)))
187      ((%REGION-SPACE-STATIC %REGION-SPACE-FIXED %REGION-SPACE-EXIT)
188        (SETQ STATIC-SIZE (+ SZ STATIC-SIZE)))
189      (%REGION-SPACE-EXITED
190        (SETQ EXITED-SIZE (+ SZ EXITED-SIZE))))))
191
192;;; If called when %GC-FLIP-READY is true, returns a conservative (over) estimate of
193;;; the amount of free space which will be used up during the next cycle before
194;;; %GC-FLIP-READY can set again.  This is based on the way consing drives scavenging.
195;;; Also returns the current amount of free space since it happens to know it.
196
197;;; In the below, the size of static and dynamic spaces are at the time of the flip,
198;;; which is bigger than the current values.  The objective is to compute how much
199;;; bigger they can be allowed to grow.
200
201;;; Total scavenger work = amount of static space to be scavenged
202;;;                        + 2 x dynamic space (which is both scavenged and copied)
203;;;                        + scavenging of static space consed after the flip
204;;;                             [dynamic space consed after the flip is newspace
205;;;                              rather than copyspace and need not be scavenged]
206;;; Total consing (consumption of free space) =
207;;;                     (1/K) x scav work
208;;;                     + amount of dynamic space which is copied
209;;;                     + region breakage
210;;; K=4 in the current microcode
211;;;
212;;; Uncertainties which can use up more free space:
213;;;     Consing after the flip in static space rather than dynamic or exited space
214;;;     Region breakage
215;;;     Consing during GC process wakeup delay
216;;; Uncertainties which decrease consumption of free space:
217;;;     Scavenging by the idle-loop rather than by CONS
218;;;     Certain fixed areas which count as static space but aren't actually scavenged
219;;;     Shrinkage of dynamic space (generally some is garbage and will be
220;;;             neither copied nor scavenged)
221;;;     Consing of additional static space before the flip, which is less
222;;;             expensive than additional dynamic space.
223;;;     Space already assigned to regions but not yet allocated by CONS
224;;;
225;;; For maximum delay of fliping, we want to allow enough consing before the
226;;; flip so that the remaining free space is exactly equal to the consing after
227;;; the flip.  The algebraic manipulation is as follows (incorporating the
228;;; worst case assumptions: no garbage, all consing before flip is dynamic,
229;;; all consing after flip is static).  Normally I wouldn't bother commenting
230;;; this but several people have got it wrong, so it must be hard.
231;;;     F0 = free space now
232;;;     D0 = dynamic space now
233;;;     ND = additional dynamic space consed before the flip
234;;;     S0 = static space now
235;;;     W  = scavenger work to do after the flip
236;;;     C  = consing required after the flip.
237;;;
238;;; C = D0 + ND + W/k           ;copy all dynamic plus do necessary scavenger work
239;;; W = S0 + 2(D0 + ND) + C     ;scav static, scav and copy all dynamic, scav new static
240;;; F0 = ND + C                 ;free space divided between before & after consing
241;;;
242;;; (k-1)C = (k+2)(D0+ND) + S0          ;plugging in for W and collecting C on the left
243;;; (k-1)C = (k+2)D0 + S0 + (k+2)(F0-C) ;plugging in for ND
244;;; C = [ (k+2)D0 + S0 + (k+2)F0 ] / (2k+1)     ;solving for C
245;;; Note that old-space is counted as free.
246
247(DEFUN GC-GET-COMMITTED-FREE-SPACE ( &AUX (K 4) )       ;K is the magic constant
248  (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE FREE-SIZE OLD-SIZE)
249        (GC-GET-SPACE-SIZES)
250    (SETQ FREE-SIZE (+ FREE-SIZE OLD-SIZE))     ;Old space will be reclaimed
251    EXITED-SIZE                                 ;Scavenger never deals with exited space
252    (LET ((CONSING (// (+ (* (+ K 2) (+ DYNAMIC-SIZE FREE-SIZE)) STATIC-SIZE)
253                       (+ (* 2 K) 1))))
254      (PROG () (RETURN (+ CONSING 1000000) ;add 256K as a fudge for region breakage
255                       FREE-SIZE)))))
256
257;;; Print various statistics
258(DEFUN GC-ROOM (&OPTIONAL (STREAM STANDARD-OUTPUT))
259  (MULTIPLE-VALUE-BIND (COMMITTED-FREE-SPACE FREE-SPACE)
260                (GC-GET-COMMITTED-FREE-SPACE)
261    (MULTIPLE-VALUE-BIND (DYNAMIC-SIZE STATIC-SIZE EXITED-SIZE IGNORE OLD-SIZE)
262                (GC-GET-SPACE-SIZES)
263         (FORMAT STREAM "~&Dynamic (new+copy) space ~D., Old space ~D., Static space ~D.,
264Exited space ~D., Free space ~D., Committed guess ~D., leaving ~D.~%"
265                   DYNAMIC-SIZE OLD-SIZE STATIC-SIZE
266                   EXITED-SIZE FREE-SPACE COMMITTED-FREE-SPACE
267                   (- FREE-SPACE COMMITTED-FREE-SPACE))))
268  (FORMAT STREAM "Garbage collector process state: ~A~%"
269          (IF (AND (BOUNDP 'GC-PROCESS) (ASSQ GC-PROCESS ACTIVE-PROCESSES))
270              (IF %GC-FLIP-READY "Await Flip" "Await Scavenge")
271              "Disabled"))
272  (FORMAT STREAM "Scavenging during cons: ~:[On~;Off~], Idle scavenging: ~:[On~;Off~]~%"
273          INHIBIT-SCAVENGING-FLAG INHIBIT-IDLE-SCAVENGING-FLAG)
274  (FORMAT STREAM "GC Flip Ratio: ~D, GC Reclaim Immediately: ~:[Off~;On~]~%"
275          GC-FLIP-RATIO GC-RECLAIM-IMMEDIATELY))
276
277;;; This function gets rid of oldspace.
278(DEFUN GC-RECLAIM-OLDSPACE ()
279  ;; Make sure all regions are clean (no pointers to oldspace)
280  (DO ((%SCAVENGER-WS-ENABLE NIL))  ;Use all of memory as long as using all of processor
281      (%GC-FLIP-READY)  ;Stop when scavenger says all is clean
282    (%GC-SCAVENGE 10000))
283  ;; Report oldspace statistics
284  (COND (GC-REPORT-STREAM
285         (DO ((REGION SIZE-OF-AREA-ARRAYS (1- REGION))
286              (OLD-TOTAL-SIZE 0)
287              (OLD-USED-SIZE 0))
288             ((MINUSP REGION)
289              (FORMAT (GC-REPORT-STREAM)
290                      "~&[GC: Flushing oldspace.  allocated=~D., used=~D.]~%"
291                      OLD-TOTAL-SIZE OLD-USED-SIZE))
292           (COND ((= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-OLD)
293                  (SETQ OLD-TOTAL-SIZE (+ (24-BIT-UNSIGNED (REGION-LENGTH REGION))
294                                          OLD-TOTAL-SIZE)
295                        OLD-USED-SIZE (+ (24-BIT-UNSIGNED (REGION-FREE-POINTER REGION))
296                                         OLD-USED-SIZE)))))))
297  ;; Discard oldspace
298  (DOLIST (AREA AREA-LIST)
299    (LET ((AREA-NUMBER (SYMEVAL AREA)))
300      (AND (OR (MINUSP AREA-NUMBER) (> AREA-NUMBER SIZE-OF-AREA-ARRAYS))
301           (FERROR NIL "Area-symbol ~S clobbered" AREA)) ;don't get grossly faked out
302      (GC-RECLAIM-OLDSPACE-AREA AREA-NUMBER))))
303
304;;; GC-RECLAIM-OLDSPACE-AREA - deletes all old-space regions of a specified area,
305;;; unthreading from the lists, and returning the virtual memory to free.
306;;; Call this for each area, if %GC-FLIP-READY is true and before calling %GC-FLIP.
307;;; Note that if an area has only one oldspace region, we have a problem with
308;;; losing the REGION-BITS.  For now just keep around one region.  This only
309;;; happens when an area is completely disused.
310(DEFUN GC-RECLAIM-OLDSPACE-AREA (AREA)
311  (CHECK-ARG AREA (AND (NUMBERP AREA) ( AREA 0) ( AREA SIZE-OF-AREA-ARRAYS))
312             "an area number")
313  (OR %GC-FLIP-READY
314      (FERROR NIL "You cannot reclaim oldspace now, there may be pointers to it"))
315  (WITHOUT-INTERRUPTS
316    (DO ((REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION))
317         (REGION-TO-FREE)
318         (PREV-REGION NIL REGION))
319        (NIL)
320     NEXTLOOP ;May GO here to avoid advancing DO variables
321      (AND (MINUSP REGION) (RETURN NIL))
322      (AND (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-OLD)
323           ;; Free this region unless that would leave the area without any regions
324           ;; at all, which would lose since there would be no place to remember its bits.
325           ;; Before freeing, unthread from area's region list.
326           (COND ((OR PREV-REGION (NOT (MINUSP (REGION-LIST-THREAD REGION))))
327                  (SETQ REGION-TO-FREE REGION
328                        REGION (REGION-LIST-THREAD REGION))
329                  (IF PREV-REGION (STORE (REGION-LIST-THREAD PREV-REGION) REGION)
330                                  (STORE (AREA-REGION-LIST AREA) REGION))
331                  (%GC-FREE-REGION REGION-TO-FREE)
332                  (GO NEXTLOOP))))
333      (AND (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) %REGION-SPACE-COPY)
334           ;;; Change this region to NEW space so that it can be used for normal
335           ;;; consing
336           (STORE (REGION-BITS REGION) (%LOGDPB 0 %%REGION-SCAVENGE-ENABLE
337                                                (%LOGDPB %REGION-SPACE-NEW
338                                                         %%REGION-SPACE-TYPE
339                                                         (REGION-BITS REGION))))))))
340
341;;; GC Process
342
343;;; This function runs in a separate process.  It wakes up when oldspace needs
344;;; to be reclaimed and when a flip is required, and does them.
345;;;*** Doesn't yet know about finite number of regions ***
346(DEFUN GC-PROCESS ()
347  (DO () (NIL)  ;Do forever
348    (IF (NOT GC-RECLAIM-IMMEDIATELY)
349        ;;Wait until scavenger done, unless we aren't doing real-time
350        ;;garbage collection.
351        (PROCESS-WAIT "Await scav" #'(LAMBDA () %GC-FLIP-READY)))
352    ;;Then flush oldspace and print "flushing oldspace" message.  A complete
353    ;;scavenge will take place here if %GC-FLIP-READY is NIL.
354    (GC-RECLAIM-OLDSPACE)
355    (DO () (NIL) ;May iterate a few times before flipping
356      (OR %GC-FLIP-READY (RETURN NIL))  ;Some other process must have flipped first
357      (MULTIPLE-VALUE-BIND (COMMITTED-FREE-SPACE FREE-SPACE)
358             (GC-GET-COMMITTED-FREE-SPACE)
359        ;;Hook to let the user influence how conservative the garbage
360        ;;collector will be.  GC-FLIP-RATIO may be a flonum.
361        (SETQ COMMITTED-FREE-SPACE (FIX (* GC-FLIP-RATIO COMMITTED-FREE-SPACE)))
362        (COND (( COMMITTED-FREE-SPACE FREE-SPACE)      ;Better flip now
363               (RETURN (GC-FLIP-NOW))) ;*** slight window for other process to flip first ***
364              (T                ;Wait a while before flipping, then compute frob again
365               (SETQ %PAGE-CONS-ALARM 0)
366               (AND GC-REPORT-STREAM
367                    (FORMAT (GC-REPORT-STREAM)
368                            "~&[GC: Allowing ~D. words more consing before flip.]~%"
369                            (- FREE-SPACE COMMITTED-FREE-SPACE)))
370               (SETQ GC-PAGE-CONS-ALARM-MARK
371                     (// (- FREE-SPACE COMMITTED-FREE-SPACE) PAGE-SIZE))
372               (PROCESS-WAIT "Await flip"
373                             #'(LAMBDA () (OR (NOT %GC-FLIP-READY)
374                                              (> %PAGE-CONS-ALARM
375                                                 GC-PAGE-CONS-ALARM-MARK))))))))))
376
377;;; Function to turn on the garbage collector
378(DEFUN GC-ON ()
379  (OR (BOUNDP 'GC-PROCESS)
380      (SETQ GC-PROCESS (PROCESS-CREATE "Garbage Collector")))
381  (PROCESS-PRESET GC-PROCESS #'GC-PROCESS)
382  (PROCESS-ENABLE GC-PROCESS)                   ;Start flipper process
383  (SETQ INHIBIT-SCAVENGING-FLAG NIL             ;Enable scavenging during cons
384        INHIBIT-IDLE-SCAVENGING-FLAG NIL)       ;Enable scavenging by scheduler during idle
385  (ADD-INITIALIZATION "GC-PROCESS" '(GC-ON) '(WARM)))   ;Do this on future warm boots
386
387;;; Function to shut off the garbage collector
388(DEFUN GC-OFF ()
389  (DELETE-INITIALIZATION "GC-PROCESS" '(WARM))  ;Don't start GC on warm boots anymore
390  (PROCESS-DISABLE GC-PROCESS)                  ;Disable flipper process
391  (SETQ INHIBIT-SCAVENGING-FLAG T               ;Disable scavenging during cons
392        INHIBIT-IDLE-SCAVENGING-FLAG T))        ;Disable scavenging during idle time
393
394;;; Function to be called by user if running for a long time with interrupts off.
395;;; Does a flip if necessary
396(DECLARE (SPECIAL GC-RECLAIMED-OLDSPACE))
397
398(SETQ GC-RECLAIMED-OLDSPACE NIL)
399
400(DEFUN GC-FLIP-IF-NECESSARY ()
401  (WITHOUT-INTERRUPTS                           ;Don't give the other process a chance to
402                                                ; have timing screws and get flipped twice
403   (COND ((AND %GC-FLIP-READY (NOT GC-RECLAIMED-OLDSPACE))
404          (GC-RECLAIM-OLDSPACE)
405          (SETQ GC-RECLAIMED-OLDSPACE T)))
406   (COND ((AND %GC-FLIP-READY
407               (> %PAGE-CONS-ALARM GC-PAGE-CONS-ALARM-MARK))
408          (MULTIPLE-VALUE-BIND (COMMITTED-FREE-SPACE FREE-SPACE)
409              (GC-GET-COMMITTED-FREE-SPACE)
410            (COND ((>= COMMITTED-FREE-SPACE FREE-SPACE) ;Better flip now
411                   (SETQ GC-PAGE-CONS-ALARM-MARK -1
412                         GC-RECLAIMED-OLDSPACE NIL)
413                   (GC-FLIP-NOW))
414                (T              ;Wait a while before flipping, then compute frob again
415                 (AND GC-REPORT-STREAM
416                      (FORMAT (GC-REPORT-STREAM)
417                              "~&[GC: Allowing ~D. words more consing before flip.]~%"
418                              (- FREE-SPACE COMMITTED-FREE-SPACE)))
419                 (SETQ %PAGE-CONS-ALARM 0
420                       GC-PAGE-CONS-ALARM-MARK (// (- FREE-SPACE COMMITTED-FREE-SPACE)
421                                                   PAGE-SIZE)))))))))
422
423;;; Make a dynamic area static.  On the next flip, when it's all been compacted
424;;; into new/copy space, change the space-type to static.
425(DEFUN MAKE-AREA-STATIC (AREA)
426  (CHECK-ARG AREA (AND (NUMBERP AREA) ( AREA 0) ( AREA SIZE-OF-AREA-ARRAYS))
427             "an area number")
428  (PUSH `(MAKE-AREA-STATIC-INTERNAL ,AREA) GC-NEXT-FLIP-LIST)
429  T)
430
431(DEFUN MAKE-AREA-STATIC-INTERNAL (AREA)
432  (WITHOUT-INTERRUPTS
433    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
434      (LET ((BITS (REGION-BITS REGION)))
435        (SELECT (LDB %%REGION-SPACE-TYPE BITS)
436          ((%REGION-SPACE-NEW %REGION-SPACE-COPY)
437             (STORE (REGION-BITS REGION)
438                    (%LOGDPB 1 %%REGION-SCAVENGE-ENABLE
439                             (%LOGDPB %REGION-SPACE-STATIC %%REGION-SPACE-TYPE BITS)))))))))
440
441;;; Make a static area dynamic.  This can happen right away, although it really
442;;; only takes effect on the next flip, when the area will acquire its first oldspace.
443(DEFUN MAKE-AREA-DYNAMIC (AREA)
444  (CHECK-ARG AREA (AND (NUMBERP AREA) ( AREA 0) ( AREA SIZE-OF-AREA-ARRAYS))
445             "an area number")
446  (WITHOUT-INTERRUPTS
447    (DO REGION (AREA-REGION-LIST AREA) (REGION-LIST-THREAD REGION) (MINUSP REGION)
448      (LET ((BITS (REGION-BITS REGION)))
449        (AND (= (LDB %%REGION-SPACE-TYPE BITS) %REGION-SPACE-STATIC)
450             (STORE (REGION-BITS REGION)
451                    (%LOGDPB %REGION-SPACE-NEW %%REGION-SPACE-TYPE BITS)))))))
452
453;;; "Clean up" a static area by garbage collecting it once, thus compactifying
454;;; it and freeing anything it points to.  This works by changing the area to dynamic,
455;;; then after the next flip it will all be in oldspace.  On the flip after that,
456;;; the non-garbage contents will have moved into new/copy space, and we can change
457;;; the area's type back to static.  Note, while all this is going on, you better
458;;; not change your mind.
459(DEFUN CLEAN-UP-STATIC-AREA (AREA)
460  (CHECK-ARG AREA (AND (NUMBERP AREA)
461                       ( AREA 0)
462                       ( AREA SIZE-OF-AREA-ARRAYS)
463                       (= (LDB %%REGION-SPACE-TYPE (REGION-BITS (AREA-REGION-LIST AREA)))
464                          %REGION-SPACE-STATIC))
465             "the area number of a static area")
466  (PUSH `(MAKE-AREA-STATIC-INTERNAL ,AREA) GC-SECOND-NEXT-FLIP-LIST)
467  (MAKE-AREA-DYNAMIC AREA))
468
469;;; Peek display
470
471;;; Hash arrays
472
473;;; Weak links
Note: See TracBrowser for help on using the browser.