1 ;;;; garbage collection and allocation-related code
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
17 ;;;; DYNAMIC-USAGE and friends
19 (declaim (special *read-only-space-free-pointer*
20 *static-space-free-pointer*))
22 (eval-when (:compile-toplevel :execute)
23 (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
25 #!-sb-fluid (declaim (inline ,lisp-fun))
27 (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
29 (def-c-var-frob read-only-space-start "read_only_space")
30 (def-c-var-frob static-space-start "static_space")
31 (def-c-var-frob dynamic-0-space-start "dynamic_0_space")
32 (def-c-var-frob dynamic-1-space-start "dynamic_1_space")
33 (def-c-var-frob control-stack-start "control_stack")
34 #!+x86 (def-c-var-frob control-stack-end "control_stack_end")
35 (def-c-var-frob binding-stack-start "binding_stack")
36 (def-c-var-frob current-dynamic-space-start "current_dynamic_space")
38 #!-sb-fluid (declaim (inline dynamic-usage))
40 (defun dynamic-usage ()
41 (the (unsigned-byte 32)
42 (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
43 (current-dynamic-space-start))))
45 (def-c-var-frob dynamic-usage "bytes_allocated")
47 (defun static-space-usage ()
48 (- (* sb!impl::*static-space-free-pointer* sb!vm:word-bytes)
49 (static-space-start)))
51 (defun read-only-space-usage ()
52 (- (* sb!impl::*read-only-space-free-pointer* sb!vm:word-bytes)
53 (read-only-space-start)))
55 (defun control-stack-usage ()
56 #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
57 (control-stack-start))
58 #!+x86 (- (control-stack-end)
59 (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
61 (defun binding-stack-usage ()
62 (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap)) (binding-stack-start)))
64 (defun current-dynamic-space ()
65 (let ((start (current-dynamic-space-start)))
66 (cond ((= start (dynamic-0-space-start))
68 ((= start (dynamic-1-space-start))
71 (error "Oh no! The current dynamic space is missing!")))))
75 (defun room-minimal-info ()
76 (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
77 (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
78 (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))
79 (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage))
80 (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage))
81 (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
82 (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
85 (defun room-intermediate-info ()
87 (sb!vm:memory-usage :count-spaces '(:dynamic)
92 (defun room-maximal-info ()
94 (sb!vm:memory-usage :count-spaces '(:static :dynamic))
95 (sb!vm:instance-usage :dynamic :top-n 10)
96 (sb!vm:instance-usage :static :top-n 10))
98 (defun room (&optional (verbosity :default))
100 "Prints to *STANDARD-OUTPUT* information about the state of internal
101 storage and its management. The optional argument controls the
102 verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
103 information. If it is NIL, ROOM prints out a minimal amount of
104 information. If it is :DEFAULT or it is not supplied, ROOM prints out
105 an intermediate amount of information. See also VM:MEMORY-USAGE and
106 VM:INSTANCE-USAGE for finer report control."
114 (room-intermediate-info)))
117 ;;;; GET-BYTES-CONSED
120 (defvar *last-bytes-in-use* nil)
121 (defvar *total-bytes-consed* 0)
122 (declaim (type (or index null) *last-bytes-in-use*))
123 (declaim (type integer *total-bytes-consed*))
125 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
126 (defun get-bytes-consed ()
128 "Returns the number of bytes consed since the first time this function
129 was called. The first time it is called, it returns zero."
130 (declare (optimize (speed 3) (safety 0)))
131 (cond ((null *last-bytes-in-use*)
132 (setq *last-bytes-in-use* (dynamic-usage))
133 (setq *total-bytes-consed* 0))
135 (let ((bytes (dynamic-usage)))
136 (incf *total-bytes-consed*
137 (the index (- bytes *last-bytes-in-use*)))
138 (setq *last-bytes-in-use* bytes))))
139 *total-bytes-consed*)
141 ;;;; variables and constants
143 ;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
144 (defconstant default-bytes-consed-between-gcs 2000000)
146 ;;; This variable is the user-settable variable that specifies the
147 ;;; minimum amount of dynamic space which must be consed before a GC
148 ;;; will be triggered.
150 ;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
151 ;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
152 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
154 "This number specifies the minimum number of bytes of dynamic space
155 that must be consed before the next GC will occur.")
156 (declaim (type index *bytes-consed-between-gcs*))
160 ;;; These variables are a list of functions which are run before and
161 ;;; after garbage collection occurs.
162 (defvar *before-gc-hooks* nil ; actually initialized in cold init
164 "A list of functions that are called before garbage collection occurs.
165 The functions should take no arguments.")
166 (defvar *after-gc-hooks* nil ; actually initialized in cold init
168 "A list of functions that are called after garbage collection occurs.
169 The functions should take no arguments.")
171 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
172 ;;; was explicitly forced by calling SB!EXT:GC). If the hook function
173 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
174 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
175 ;;; Presumably someone will call GC-ON later to collect the garbage.
176 (defvar *gc-inhibit-hook* nil
178 "Should be bound to a function or NIL. If it is a function, this
179 function should take one argument, the current amount of dynamic
180 usage. The function should return NIL if garbage collection should
181 continue and non-NIL if it should be inhibited. Use with caution.")
183 (defvar *gc-verbose* nil ; (actually initialized in cold init)
185 "Should low-level GC functions produce verbose diagnostic output?")
187 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
189 "When non-NIL, this must be a STREAM; and the functions bound to
190 *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
191 STREAM value before and after a garbage collection occurs
194 (defvar *gc-run-time* 0
196 "The total CPU time spent doing garbage collection (as reported by
197 GET-INTERNAL-RUN-TIME.)")
199 (declaim (type index *gc-run-time*))
201 ;;; Internal trigger. When the dynamic usage increases beyond this
202 ;;; amount, the system notes that a garbage collection needs to occur by
203 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
204 ;;; nobody has figured out what it should be yet.
205 (defvar *gc-trigger* nil)
207 (declaim (type (or index null) *gc-trigger*))
209 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
210 ;;; letting magic C code handle it. It gets initialized by the startup
211 ;;; code. The X86 port defines this here because it uses the `ibmrt'
212 ;;; feature in the C code for allocation and binding stack access and
213 ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
215 (defvar sb!vm::*internal-gc-trigger*)
217 ;;;; The following specials are used to control when garbage collection
220 ;;; When non-NIL, inhibits garbage collection.
221 (defvar *gc-inhibit*) ; initialized in cold init
223 ;;; This flag is used to prevent recursive entry into the garbage
225 (defvar *already-maybe-gcing*) ; initialized in cold init
227 ;;; When T, indicates that the dynamic usage has exceeded the value
229 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
231 (defun default-gc-notify-before (notify-stream bytes-in-use)
232 (declare (type stream notify-stream))
233 (format notify-stream
234 "~&; GC is beginning with ~:D bytes in use.~%"
236 (finish-output notify-stream))
237 (defparameter *gc-notify-before* #'default-gc-notify-before
239 "This function bound to this variable is invoked before GC'ing (unless
240 *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
241 current amount of dynamic usage (in bytes). It should notify the
242 user that the system is going to GC.")
244 (defun default-gc-notify-after (notify-stream
248 (declare (type stream notify-stream))
249 (format notify-stream
250 "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
253 (format notify-stream
254 "~&; The new GC trigger is ~:D bytes.~%"
256 (finish-output notify-stream))
257 (defparameter *gc-notify-after* #'default-gc-notify-after
259 "The function bound to this variable is invoked after GC'ing (unless
260 *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
261 the amount of dynamic usage (in bytes) now free, the number of
262 bytes freed by the GC, and the new GC trigger threshold. The function
263 should notify the user that the system has finished GC'ing.")
267 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
268 #!+gencgc (last-gen sb!c-call:int))
271 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
272 (dynamic-usage sb!c-call:unsigned-long))
275 (defun set-auto-gc-trigger (bytes)
276 (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
277 (unless (and (fixnump words) (plusp words))
278 (clear-auto-gc-trigger)
279 (warn "attempt to set GC trigger to something bogus: ~S" bytes))
280 (setf %rt::*internal-gc-trigger* words)))
283 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
286 (defun clear-auto-gc-trigger ()
287 (setf %rt::*internal-gc-trigger* -1))
289 ;;; This variable contains the function that does the real GC. This is
290 ;;; for low-level GC experimentation. Do not touch it if you do not
291 ;;; know what you are doing.
292 (defvar *internal-gc* #'collect-garbage)
296 ;;; Used to carefully invoke hooks.
297 (eval-when (:compile-toplevel :execute)
298 (sb!xc:defmacro carefully-funcall (function &rest args)
299 `(handler-case (funcall ,function ,@args)
301 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
304 ;;; SUB-GC decides when and if to do a garbage collection. The
305 ;;; VERBOSE-P flag controls whether or not the notify functions are
306 ;;; called. The FORCE-P flags controls if a GC should occur even if
307 ;;; the dynamic usage is not greater than *GC-TRIGGER*.
309 ;;; For GENCGC all generations < GEN will be GC'ed.
311 ;;; FIXME: The VERBOSE-P stuff is no longer used.
312 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0))
313 (/show0 "entering SUB-GC")
314 (unless *already-maybe-gcing*
315 (/show0 "not *ALREADY-MAYBE-GCING*")
316 (let* ((*already-maybe-gcing* t)
317 (start-time (get-internal-run-time))
318 (pre-gc-dyn-usage (dynamic-usage)))
319 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
320 ;; The noise w/ symbol-value above is to keep the compiler
321 ;; from optimizing the test away because of the type declaim
322 ;; for *bytes-consed-between-gcs*.
324 ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
325 ;; trust it, instead of doing this weird hack. It's not
326 ;; particularly trustable, since (SETF
327 ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
328 ;; very nice to have the type of the variable specified in two
329 ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
330 ;; INDEX) drift apart. So perhaps we should just add a note to
331 ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
332 ;; that it must be an INDEX, and remove the DECLAIM. Or we
333 ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
334 ;; and enforce the typing that way. And in fact the SETFable
335 ;; function already exists, so all we need do is make the
336 ;; variable private, and then we can trust the DECLAIM.
337 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
338 integer. Resetting it to ~D."
339 *bytes-consed-between-gcs*
340 default-bytes-consed-between-gcs)
341 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
342 (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
343 (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
344 (setf *need-to-collect-garbage* t))
346 (and *need-to-collect-garbage* (not *gc-inhibit*)))
347 (/show0 "Evidently we ought to collect garbage..")
348 (when (and (not force-p)
350 (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
351 (/show0 "..but we're inhibited.")
352 (setf *gc-inhibit* t)
353 (return-from sub-gc nil))
354 ;; KLUDGE: Wow, we really mask interrupts all the time we're
355 ;; collecting garbage? That seems like a long time.. -- WHN 19991129
357 ;; FIXME: We probably shouldn't do this evil thing to
358 ;; *STANDARD-OUTPUT* in a binding which is wrapped around
359 ;; calls to user-settable GC hook functions.
360 (let ((*standard-output* *terminal-io*))
361 (when *gc-notify-stream*
362 (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
363 (if (streamp *gc-notify-stream*)
364 (carefully-funcall *gc-notify-before*
368 "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
369 (dolist (hook *before-gc-hooks*)
370 (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
371 (carefully-funcall hook))
373 (clear-auto-gc-trigger))
374 (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
375 #!-gencgc (funcall *internal-gc*)
376 ;; FIXME: This EQ test is pretty gross. Among its other
377 ;; nastinesses, it looks as though it could break if we
378 ;; recompile COLLECT-GARBAGE.
379 #!+gencgc (if (eq *internal-gc* #'collect-garbage)
380 (funcall *internal-gc* gen)
381 (funcall *internal-gc*))
382 (/show0 "back from FUNCALL to *INTERNAL-GC*")
383 (let* ((post-gc-dyn-usage (dynamic-usage))
384 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
385 (when *last-bytes-in-use*
386 (incf *total-bytes-consed*
387 (- pre-gc-dyn-usage *last-bytes-in-use*))
388 (setq *last-bytes-in-use* post-gc-dyn-usage))
389 (setf *need-to-collect-garbage* nil)
390 (let ((new-gc-trigger (+ post-gc-dyn-usage
391 *bytes-consed-between-gcs*)))
392 (setf *gc-trigger* new-gc-trigger))
393 (set-auto-gc-trigger *gc-trigger*)
394 (dolist (hook *after-gc-hooks*)
395 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
396 ;; FIXME: This hook should be called with the
397 ;; same kind of information as *GC-NOTIFY-AFTER*.
398 ;; In particular, it would be nice for the
399 ;; hook function to be able to adjust *GC-TRIGGER*
400 ;; intelligently to e.g. 108% of total memory usage.
401 (carefully-funcall hook))
402 (when *gc-notify-stream*
403 (/show0 "doing the *GC-NOTIFY-AFTER* thing")
404 (if (streamp *gc-notify-stream*)
405 (carefully-funcall *gc-notify-after*
411 "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
412 (/show0 "scrubbing control stack")
413 (scrub-control-stack)))
414 (/show0 "updating *GC-RUN-TIME*")
415 (incf *gc-run-time* (- (get-internal-run-time)
417 ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
418 (/show "returning from tail of SUB-GC")
421 ;;; This routine is called by the allocation miscops to decide whether
422 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
423 ;;; object which must be returned to the caller.
424 (defun maybe-gc (&optional object)
428 ;;; This is the user-advertised garbage collection function.
430 ;;; KLUDGE: GC shouldn't have different parameters depending on what
431 ;;; garbage collector we use. -- WHN 19991020
433 (defun gc (&optional (verbose-p *gc-verbose*))
435 "Initiates a garbage collection. VERBOSE-P controls
436 whether or not GC statistics are printed."
437 (sub-gc :verbose-p verbose-p :force-p t))
439 (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
441 "Initiates a garbage collection. VERBOSE controls whether or not GC
442 statistics are printed. GEN controls the number of generations to garbage
444 ;; FIXME: The bare 6 here (corresponding to a bare 6 in
445 ;; the gencgc.c sources) is nasty.
446 (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
448 ;;;; auxiliary functions
450 (defun bytes-consed-between-gcs ()
452 "Return the amount of memory that will be allocated before the next garbage
453 collection is initiated. This can be set with SETF."
454 *bytes-consed-between-gcs*)
455 (defun (setf bytes-consed-between-gcs) (val)
456 ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
457 ;; be for a strictly positive number type, e.g.
458 ;; (AND (INTEGER 1) FIXNUM)?
459 (declare (type index val))
460 (let ((old *bytes-consed-between-gcs*))
461 (setf *bytes-consed-between-gcs* val)
463 (setf *gc-trigger* (+ *gc-trigger* (- val old)))
464 (cond ((<= (dynamic-usage) *gc-trigger*)
465 (clear-auto-gc-trigger)
466 (set-auto-gc-trigger *gc-trigger*))
468 (sb!sys:scrub-control-stack)
474 "Enables the garbage collector."
475 (setq *gc-inhibit* nil)
476 (when *need-to-collect-garbage*
482 "Disables the garbage collector."
483 (setq *gc-inhibit* t)
486 ;;;; initialization stuff
488 (defun gc-cold-init-or-reinit ()
490 (if (< *gc-trigger* (dynamic-usage))
492 (set-auto-gc-trigger *gc-trigger*))))