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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5