/[cmucl]/src/code/gc.lisp
ViewVC logotype

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Thu Mar 26 03:24:14 1992 UTC (22 years ago) by wlott
Branch: MAIN
Changes since 1.11: +36 -32 lines
Added GC-INIT to facilitate making sure set-auto-gc-trigger.  Changed
room-minimal-info to print everything that doesn't use map-allocated-
objects and also to indicate whether or not the garbage collector is
currenty on or off.  Changed sub-gc to handle updating *total-bytes-consed*
instead of having %GC do it so that it happens even when *internal-gc*
is bound to something else.  Flush %GC because it now does nothing but
call COLLECT-GARBAGE.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.12 1992/03/26 03:24:14 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Garbage collection and allocation related code.
15 ;;;
16 ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
17 ;;; New code for MIPS port by Christopher Hoover.
18 ;;;
19
20 (in-package "EXTENSIONS")
21 (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
22 *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
23 *gc-notify-before* *gc-notify-after* get-bytes-consed
24 *gc-run-time*))
25
26 (in-package "LISP")
27 (export '(room))
28
29
30 ;;;; DYNAMIC-USAGE and friends.
31
32 (proclaim '(special *read-only-space-free-pointer*
33 *static-space-free-pointer*))
34
35 (eval-when (compile eval)
36 (defmacro c-var-frob (lisp-fun c-var-name)
37 `(progn
38 (declaim (inline ,lisp-fun))
39 (defun ,lisp-fun ()
40 (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
41
42 (c-var-frob read-only-space-start "read_only_space")
43 (c-var-frob static-space-start "static_space")
44 (c-var-frob dynamic-0-space-start "dynamic_0_space")
45 (c-var-frob dynamic-1-space-start "dynamic_1_space")
46 (c-var-frob control-stack-start "control_stack")
47 (c-var-frob binding-stack-start "binding_stack")
48 (c-var-frob current-dynamic-space-start "current_dynamic_space")
49
50 (declaim (inline dynamic-usage))
51
52 (defun dynamic-usage ()
53 (the (unsigned-byte 32)
54 (- (system:sap-int (c::dynamic-space-free-pointer))
55 (current-dynamic-space-start))))
56
57 (defun static-space-usage ()
58 (- (* lisp::*static-space-free-pointer* vm:word-bytes)
59 (static-space-start)))
60
61 (defun read-only-space-usage ()
62 (- (* lisp::*read-only-space-free-pointer* vm:word-bytes)
63 (read-only-space-start)))
64
65 (defun control-stack-usage ()
66 (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)))
67
68 (defun binding-stack-usage ()
69 (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
70
71
72 (defun current-dynamic-space ()
73 (let ((start (current-dynamic-space-start)))
74 (cond ((= start (dynamic-0-space-start))
75 0)
76 ((= start (dynamic-1-space-start))
77 1)
78 (t
79 (error "Oh no. The current dynamic space is missing!")))))
80
81
82 ;;;; Room.
83
84 (defun room-minimal-info ()
85 (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
86 (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
87 (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))
88 (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage))
89 (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage))
90 (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
91 (format t "Garbage collection is currently ~:[DISABLED~;enabled.~]~%"
92 *gc-trigger*))
93
94 (defun room-intermediate-info ()
95 (room-minimal-info)
96 (vm:memory-usage :count-spaces '(:dynamic)
97 :print-spaces t
98 :cutoff 0.05
99 :print-summary nil))
100
101 (defun room-maximal-info ()
102 (room-minimal-info)
103 (vm:memory-usage :count-spaces '(:static :dynamic))
104 (vm:structure-usage :dynamic :top-n 10)
105 (vm:structure-usage :static :top-n 10))
106
107 (defun room (&optional (verbosity :default))
108 "Prints to *STANDARD-OUTPUT* information about the state of internal
109 storage and its management. The optional argument controls the
110 verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
111 information. If it is NIL, ROOM prints out a minimal amount of
112 information. If it is :DEFAULT or it is not supplied, ROOM prints out
113 an intermediate amount of information. See also VM:MEMORY-USAGE and
114 VM:STRUCTURE-USAGE for finer report control."
115 (fresh-line)
116 (case verbosity
117 ((t)
118 (room-maximal-info))
119 ((nil)
120 (room-minimal-info))
121 (:default
122 (room-intermediate-info))
123 (t
124 (error "No way man! The optional argument to ROOM must be T, NIL, ~
125 or :DEFAULT.~%What do you think you are doing?")))
126 (values))
127
128
129 ;;;; GET-BYTES-CONSED.
130
131 ;;;
132 ;;; Internal State
133 ;;;
134 (defvar *last-bytes-in-use* nil)
135 (defvar *total-bytes-consed* 0)
136
137 (declaim (type (or index null) *last-bytes-in-use*))
138 (declaim (type index *total-bytes-consed*))
139
140 ;;; GET-BYTES-CONSED -- Exported
141 ;;;
142 (defun get-bytes-consed ()
143 "Returns the number of bytes consed since the first time this function
144 was called. The first time it is called, it returns zero."
145 (declare (optimize (speed 3) (safety 0)))
146 (cond ((null *last-bytes-in-use*)
147 (setq *last-bytes-in-use* (dynamic-usage))
148 (setq *total-bytes-consed* 0))
149 (t
150 (let ((bytes (dynamic-usage)))
151 (incf *total-bytes-consed*
152 (the index (- bytes *last-bytes-in-use*)))
153 (setq *last-bytes-in-use* bytes))))
154 *total-bytes-consed*)
155
156
157 ;;;; Variables and Constants.
158
159 ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
160 ;;;
161 (defconstant default-bytes-consed-between-gcs 2000000)
162
163 ;;; This variable is the user-settable variable that specifices the
164 ;;; minimum amount of dynamic space which must be consed before a GC
165 ;;; will be triggered.
166 ;;;
167 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
168 "This number specifies the minimum number of bytes of dynamic space
169 that must be consed before the next gc will occur.")
170
171 (declaim (type index *bytes-consed-between-gcs*))
172
173 ;;; Public
174 (defvar *gc-run-time* 0
175 "The total CPU time spend doing garbage collection (as reported by
176 GET-INTERNAL-RUN-TIME.)")
177
178 (declaim (type index *gc-run-time*))
179
180 ;;; Internal trigger. When the dynamic usage increases beyond this
181 ;;; amount, the system notes that a garbage collection needs to occur by
182 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
183 ;;; nobody has figured out what it should be yet.
184 ;;;
185 (defvar *gc-trigger* nil)
186
187 (declaim (type (or index null) *gc-trigger*))
188
189 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
190 ;;; letting magic C code handle it. It gets initialized by the startup
191 ;;; code.
192 #+ibmrt
193 (defvar rt::*internal-gc-trigger*)
194
195 ;;;
196 ;;; The following specials are used to control when garbage collection
197 ;;; occurs.
198 ;;;
199
200 ;;;
201 ;;; *GC-INHIBIT*
202 ;;;
203 ;;; When non-NIL, inhibits garbage collection.
204 ;;;
205 (defvar *gc-inhibit* nil)
206
207 ;;;
208 ;;; *ALREADY-MAYBE-GCING*
209 ;;;
210 ;;; This flag is used to prevent recursive entry into the garbage
211 ;;; collector.
212 ;;;
213 (defvar *already-maybe-gcing* nil)
214
215 ;;; When T, indicates that the dynamic usage has exceeded the value
216 ;;; *GC-TRIGGER*.
217 ;;;
218 (defvar *need-to-collect-garbage* nil)
219
220
221 ;;;; GC Hooks.
222
223 ;;;
224 ;;; *BEFORE-GC-HOOKS*
225 ;;; *AFTER-GC-HOOKS*
226 ;;;
227 ;;; These variables are a list of functions which are run before and
228 ;;; after garbage collection occurs.
229 ;;;
230 (defvar *before-gc-hooks* nil
231 "A list of functions that are called before garbage collection occurs.
232 The functions should take no arguments.")
233 ;;;
234 (defvar *after-gc-hooks* nil
235 "A list of functions that are called after garbage collection occurs.
236 The functions should take no arguments.")
237
238 ;;;
239 ;;; *GC-INHIBIT-HOOK*
240 ;;;
241 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
242 ;;; was explicitly forced by calling EXT:GC). If the hook function
243 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
244 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
245 ;;; Presumably someone will call GC-ON later to collect the garbage.
246 ;;;
247 (defvar *gc-inhibit-hook* nil
248 "Should be bound to a function or NIL. If it is a function, this
249 function should take one argument, the current amount of dynamic
250 usage. The function should return NIL if garbage collection should
251 continue and non-NIL if it should be inhibited. Use with caution.")
252
253
254
255 ;;;
256 ;;; *GC-VERBOSE*
257 ;;;
258 (defvar *gc-verbose* t
259 "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
260 *GC-NOTIFY-AFTER* to be called before and after a garbage collection
261 occurs respectively. If :BEEP, causes the default notify functions to beep
262 annoyingly.")
263
264
265 (defun default-gc-notify-before (bytes-in-use)
266 (when (eq *gc-verbose* :beep)
267 (system:beep *standard-output*))
268 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
269 Commencing GC.]~%" bytes-in-use)
270 (finish-output))
271 ;;;
272 (defparameter *gc-notify-before* #'default-gc-notify-before
273 "This function bound to this variable is invoked before GC'ing (unless
274 *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
275 bytes). It should notify the user that the system is going to GC.")
276
277 (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
278 (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
279 bytes-retained bytes-freed)
280 (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
281 new-trigger)
282 (when (eq *gc-verbose* :beep)
283 (system:beep *standard-output*))
284 (finish-output))
285 ;;;
286 (defparameter *gc-notify-after* #'default-gc-notify-after
287 "The function bound to this variable is invoked after GC'ing (unless
288 *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
289 free, the number of bytes freed by the GC, and the new GC trigger
290 threshold. The function should notify the user that the system has
291 finished GC'ing.")
292
293
294 ;;;; Internal GC
295
296 (alien:def-alien-routine collect-garbage c-call:int)
297
298 #-ibmrt
299 (alien:def-alien-routine set-auto-gc-trigger c-call:void
300 (dynamic-usage c-call:unsigned-long))
301
302 #+ibmrt
303 (defun set-auto-gc-trigger (bytes)
304 (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
305 (unless (and (fixnump words) (plusp words))
306 (clear-auto-gc-trigger)
307 (warn "Attempt to set GC trigger to something bogus: ~S" bytes))
308 (setf rt::*internal-gc-trigger* words)))
309
310 #-ibmrt
311 (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
312
313 #+ibmrt
314 (defun clear-auto-gc-trigger ()
315 (setf rt::*internal-gc-trigger* -1))
316
317 ;;;
318 ;;; *INTERNAL-GC*
319 ;;;
320 ;;; This variables contains the function that does the real GC. This is
321 ;;; for low-level GC experimentation. Do not touch it if you do not
322 ;;; know what you are doing.
323 ;;;
324 (defvar *internal-gc* #'collect-garbage)
325
326
327 ;;;; SUB-GC
328
329 ;;;
330 ;;; CAREFULLY-FUNCALL -- Internal
331 ;;;
332 ;;; Used to carefully invoke hooks.
333 ;;;
334 (defmacro carefully-funcall (function &rest args)
335 `(handler-case (funcall ,function ,@args)
336 (error (cond)
337 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
338 nil)))
339
340 ;;;
341 ;;; SUB-GC -- Internal
342 ;;;
343 ;;; SUB-GC decides when and if to do a garbage collection. The
344 ;;; VERBOSE-P flag controls whether or not the notify functions are
345 ;;; called. The FORCE-P flags controls if a GC should occur even if the
346 ;;; dynamic usage is not greater than *GC-TRIGGER*.
347 ;;;
348 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p)
349 (unless *already-maybe-gcing*
350 (let* ((*already-maybe-gcing* t)
351 (start-time (get-internal-run-time))
352 (pre-gc-dyn-usage (dynamic-usage)))
353 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
354 ;; The noise w/ symbol-value above is to keep the compiler from
355 ;; optimizing the test away because of the type declaim for
356 ;; *bytes-consed-between-gcs*.
357 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
358 integer. Reseting it to ~D." *bytes-consed-between-gcs*
359 default-bytes-consed-between-gcs)
360 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
361 (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
362 (setf *need-to-collect-garbage* t))
363 (when (or force-p
364 (and *need-to-collect-garbage* (not *gc-inhibit*)))
365 (when (and (not force-p)
366 *gc-inhibit-hook*
367 (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
368 (setf *gc-inhibit* t)
369 (return-from sub-gc nil))
370 (without-interrupts
371 (let ((*standard-output* *terminal-io*))
372 (when verbose-p
373 (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
374 (dolist (hook *before-gc-hooks*)
375 (carefully-funcall hook))
376 (when *gc-trigger*
377 (clear-auto-gc-trigger))
378 (funcall *internal-gc*)
379 (let* ((post-gc-dyn-usage (dynamic-usage))
380 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
381 (when *last-bytes-in-use*
382 (incf *total-bytes-consed*
383 (- pre-gc-dyn-usage *last-bytes-in-use*))
384 (setq *last-bytes-in-use* post-gc-dyn-usage))
385 (setf *need-to-collect-garbage* nil)
386 (setf *gc-trigger*
387 (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
388 (set-auto-gc-trigger *gc-trigger*)
389 (dolist (hook *after-gc-hooks*)
390 (carefully-funcall hook))
391 (when verbose-p
392 (carefully-funcall *gc-notify-after*
393 post-gc-dyn-usage bytes-freed
394 *gc-trigger*))))))
395 (incf *gc-run-time* (- (get-internal-run-time) start-time))))
396 nil)
397
398 ;;;
399 ;;; MAYBE-GC -- Internal
400 ;;;
401 ;;; This routine is called by the allocation miscops to decide if a GC
402 ;;; should occur. The argument, object, is the newly allocated object
403 ;;; which must be returned to the caller.
404 ;;;
405 (defun maybe-gc (&optional object)
406 (sub-gc)
407 object)
408
409 ;;;
410 ;;; GC -- Exported
411 ;;;
412 ;;; This is the user advertised garbage collection function.
413 ;;;
414 (defun gc (&optional (verbose-p *gc-verbose*))
415 "Initiates a garbage collection. The optional argument, VERBOSE-P,
416 which defaults to the value of the variable *GC-VERBOSE* controls
417 whether or not GC statistics are printed."
418 (sub-gc :verbose-p verbose-p :force-p t))
419
420
421 ;;;; Auxiliary Functions.
422
423
424 (defun gc-on ()
425 "Enables the garbage collector."
426 (setq *gc-inhibit* nil)
427 (when *need-to-collect-garbage*
428 (sub-gc))
429 nil)
430
431 (defun gc-off ()
432 "Disables the garbage collector."
433 (setq *gc-inhibit* t)
434 nil)
435
436
437
438 ;;;; Initialization stuff.
439
440 (defun gc-init ()
441 (when *gc-trigger*
442 (if (< *gc-trigger* (dynamic-usage))
443 (sub-gc)
444 (set-auto-gc-trigger *gc-trigger*))))

  ViewVC Help
Powered by ViewVC 1.1.5