Context Navigation

gc.lisp @ 247

Revision 247, 21.8 KB (checked in by rjs, 21 months 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.,
264	Exited 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.

Download in other formats:

Original Format