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")
14 ;;;; DYNAMIC-USAGE and friends
16 (declaim (special sb!vm:*read-only-space-free-pointer*
17 sb!vm:*static-space-free-pointer*))
19 (eval-when (:compile-toplevel :execute)
20 (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
22 #!-sb-fluid (declaim (inline ,lisp-fun))
24 (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
28 ;; This is called once per PROFILEd function call, so it's worth a
29 ;; little possible space cost to reduce its time cost.
31 (declaim (inline current-dynamic-space-start))
32 (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
35 (declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
37 (def-c-var-frob dynamic-usage "bytes_allocated")
39 (defun dynamic-usage ()
40 (the (unsigned-byte 32)
41 (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
42 (current-dynamic-space-start))))
44 (defun static-space-usage ()
45 (- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
46 sb!vm:static-space-start))
48 (defun read-only-space-usage ()
49 (- (* sb!vm::*read-only-space-free-pointer* sb!vm:word-bytes)
50 sb!vm:read-only-space-start))
52 (defun control-stack-usage ()
53 #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
54 sb!vm:control-stack-start)
55 #!+x86 (- sb!vm:control-stack-end
56 (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
58 (defun binding-stack-usage ()
59 (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
60 sb!vm:binding-stack-start))
64 (defun room-minimal-info ()
65 (format t "Dynamic space usage is: ~10:D bytes.~%" (dynamic-usage))
66 (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
67 (format t "Static space usage is: ~10:D bytes.~%" (static-space-usage))
68 (format t "Control stack usage is: ~10:D bytes.~%" (control-stack-usage))
69 (format t "Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage))
70 (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
73 (defun room-intermediate-info ()
75 (sb!vm:memory-usage :count-spaces '(:dynamic)
80 (defun room-maximal-info ()
82 (sb!vm:memory-usage :count-spaces '(:static :dynamic))
83 (sb!vm:instance-usage :dynamic :top-n 10)
84 (sb!vm:instance-usage :static :top-n 10))
86 (defun room (&optional (verbosity :default))
88 "Print to *STANDARD-OUTPUT* information about the state of internal
89 storage and its management. The optional argument controls the
90 verbosity of output. If it is T, ROOM prints out a maximal amount of
91 information. If it is NIL, ROOM prints out a minimal amount of
92 information. If it is :DEFAULT or it is not supplied, ROOM prints out
93 an intermediate amount of information."
101 (room-intermediate-info)))
104 ;;;; GET-BYTES-CONSED
106 ;;; the total number of bytes freed so far (including any freeing
107 ;;; which goes on in PURIFY)
109 ;;; (We save this so that we can calculate the total number of bytes
110 ;;; ever allocated by adding this to the number of bytes currently
111 ;;; allocated and never freed.)
112 (declaim (type pcounter *n-bytes-freed-or-purified-pcounter*))
113 (defvar *n-bytes-freed-or-purified-pcounter* (make-pcounter))
115 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
116 (defun get-bytes-consed ()
118 "Return the number of bytes consed since the program began. Typically
119 this result will be a consed bignum, so if you have an application (e.g.
120 profiling) which can't tolerate the overhead of consing bignums, you'll
121 probably want either to hack in at a lower level (as the code in the
122 SB-PROFILE package does), or to design a more microefficient interface
123 and submit it as a patch."
125 (pcounter->integer *n-bytes-freed-or-purified-pcounter*)))
127 ;;;; variables and constants
129 ;;; the minimum amount of dynamic space which must be consed before a
130 ;;; GC will be triggered
132 ;;; Unlike CMU CL, we don't export this variable. (There's no need to,
133 ;;; since our BYTES-CONSED-BETWEEN-GCS function is SETFable.)
134 (defvar *bytes-consed-between-gcs* (* 2 (expt 10 6)))
135 (declaim (type index *bytes-consed-between-gcs*))
139 (defvar *before-gc-hooks* nil ; actually initialized in cold init
141 "A list of functions that are called before garbage collection occurs.
142 The functions should take no arguments.")
144 (defvar *after-gc-hooks* nil ; actually initialized in cold init
146 "A list of functions that are called after garbage collection occurs.
147 The functions should take no arguments.")
149 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
151 "When non-NIL, this must be a STREAM; and the functions bound to
152 *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
153 STREAM value before and after a garbage collection occurs
156 (defvar *gc-run-time* 0
158 "the total CPU time spent doing garbage collection (as reported by
159 GET-INTERNAL-RUN-TIME)")
160 (declaim (type index *gc-run-time*))
162 ;;; a limit to help catch programs which allocate too much memory,
163 ;;; since a hard heap overflow is so hard to recover from
164 (declaim (type (or unsigned-byte null) *soft-heap-limit*))
165 (defvar *soft-heap-limit* nil)
167 ;;; When the dynamic usage increases beyond this amount, the system
168 ;;; notes that a garbage collection needs to occur by setting
169 ;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
170 ;;; nobody has figured out what it should be yet.
171 (defvar *gc-trigger* nil)
173 (declaim (type (or index null) *gc-trigger*))
175 ;;; On the X86, we store the GC trigger in a ``static'' symbol instead
176 ;;; of letting magic C code handle it. It gets initialized by the
179 (defvar sb!vm::*internal-gc-trigger*)
181 ;;;; The following specials are used to control when garbage collection
184 ;;; When non-NIL, inhibits garbage collection.
185 (defvar *gc-inhibit*) ; initialized in cold init
187 ;;; This flag is used to prevent recursive entry into the garbage
189 (defvar *already-maybe-gcing*) ; initialized in cold init
191 ;;; When T, indicates that the dynamic usage has exceeded the value
193 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
195 (defun default-gc-notify-before (notify-stream bytes-in-use)
196 (declare (type stream notify-stream))
197 (format notify-stream
198 "~&; GC is beginning with ~:D bytes in use at internal runtime ~:D.~%"
200 (get-internal-run-time))
201 (finish-output notify-stream))
202 (defparameter *gc-notify-before* #'default-gc-notify-before
204 "This function bound to this variable is invoked before GC'ing (unless
205 *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
206 current amount of dynamic usage (in bytes). It should notify the
207 user that the system is going to GC.")
209 (defun default-gc-notify-after (notify-stream
213 (declare (type stream notify-stream))
214 (format notify-stream
215 "~&; GC has finished with ~:D bytes in use (~:D bytes freed)~@
216 ; at internal runtime ~:D. The new GC trigger is ~:D bytes.~%"
219 (get-internal-run-time)
221 (finish-output notify-stream))
222 (defparameter *gc-notify-after* #'default-gc-notify-after
224 "The function bound to this variable is invoked after GC'ing with
225 the value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in
226 bytes) now free, the number of bytes freed by the GC, and the new GC
227 trigger threshold. The function should notify the user that the system
228 has finished GC'ing.")
232 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
233 #!+gencgc (last-gen sb!c-call:int))
235 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
236 (dynamic-usage sb!c-call:unsigned-long))
238 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
240 ;;; This variable contains the function that does the real GC. This is
241 ;;; for low-level GC experimentation. Do not touch it if you do not
242 ;;; know what you are doing.
243 (defvar *internal-gc* #'collect-garbage)
247 ;;; Used to carefully invoke hooks.
248 (eval-when (:compile-toplevel :execute)
249 (sb!xc:defmacro carefully-funcall (function &rest args)
250 `(handler-case (funcall ,function ,@args)
252 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
255 ;;; SUB-GC decides when and if to do a garbage collection. The FORCE-P
256 ;;; flags controls whether a GC should occur even if the dynamic usage
257 ;;; is not greater than *GC-TRIGGER*.
259 ;;; For GENCGC all generations < GEN will be GC'ed.
260 (defun sub-gc (&key force-p (gen 0))
261 (/show0 "entering SUB-GC")
262 (unless *already-maybe-gcing*
263 (let* ((*already-maybe-gcing* t)
264 (start-time (get-internal-run-time))
265 (pre-gc-dynamic-usage (dynamic-usage))
266 ;; Currently we only check *SOFT-HEAP-LIMIT* at GC time,
267 ;; not for every allocation. That makes it cheap to do,
268 ;; even if it is a little ugly.
269 (soft-heap-limit-exceeded? (and *soft-heap-limit*
270 (> pre-gc-dynamic-usage
272 (*soft-heap-limit* (if soft-heap-limit-exceeded?
273 (+ pre-gc-dynamic-usage
274 *bytes-consed-between-gcs*)
276 (when soft-heap-limit-exceeded?
277 (cerror "Continue with GC."
278 "soft heap limit exceeded (temporary new limit=~D)"
280 (when (and *gc-trigger* (> pre-gc-dynamic-usage *gc-trigger*))
281 (setf *need-to-collect-garbage* t))
283 (and *need-to-collect-garbage* (not *gc-inhibit*)))
284 ;; KLUDGE: Wow, we really mask interrupts all the time we're
285 ;; collecting garbage? That seems like a long time.. -- WHN 19991129
287 ;; FIXME: We probably shouldn't do this evil thing to
288 ;; *STANDARD-OUTPUT* in a binding which is wrapped around
289 ;; calls to user-settable GC hook functions.
290 (let ((*standard-output* *terminal-io*))
291 (when *gc-notify-stream*
292 (if (streamp *gc-notify-stream*)
293 (carefully-funcall *gc-notify-before*
295 pre-gc-dynamic-usage)
297 "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
298 (dolist (hook *before-gc-hooks*)
299 (carefully-funcall hook))
301 (clear-auto-gc-trigger))
302 (let* (;; We do DYNAMIC-USAGE once more here in order to
303 ;; get a more accurate measurement of the space
304 ;; actually freed, since the messing around, e.g.
305 ;; GC-notify stuff, since the DYNAMIC-USAGE which
306 ;; triggered GC could've done a fair amount of
308 (pre-internal-gc-dynamic-usage (dynamic-usage))
310 #!-gencgc (funcall *internal-gc*)
311 ;; FIXME: This EQ test is pretty gross. Among its other
312 ;; nastinesses, it looks as though it could break if we
313 ;; recompile COLLECT-GARBAGE. We should probably just
314 ;; straighten out the interface so that all *INTERNAL-GC*
315 ;; functions accept a GEN argument (and then the
316 ;; non-generational ones just ignore it).
317 #!+gencgc (if (eq *internal-gc* #'collect-garbage)
318 (funcall *internal-gc* gen)
319 (funcall *internal-gc*)))
320 (post-gc-dynamic-usage (dynamic-usage))
321 (n-bytes-freed (- pre-internal-gc-dynamic-usage
322 post-gc-dynamic-usage))
323 ;; In sbcl-0.6.12.39, the raw N-BYTES-FREED from
324 ;; GENCGC could sometimes be substantially negative
325 ;; (e.g. -5872). I haven't looked into what causes
326 ;; that, but I suspect it has to do with
327 ;; fluctuating inefficiency in the way that the
328 ;; GENCGC packs things into page boundaries.
329 ;; Bumping the raw result up to 0 is a little ugly,
330 ;; but shouldn't be a problem, and it's even
331 ;; possible to sort of justify it: the packing
332 ;; inefficiency which has caused (DYNAMIC-USAGE) to
333 ;; grow is effectively consing, or at least
334 ;; overhead of consing, so it's sort of correct to
335 ;; add it to the running total of consing. ("Man
336 ;; isn't a rational animal, he's a rationalizing
337 ;; animal.":-) -- WHN 2001-06-23
338 (eff-n-bytes-freed (max 0 n-bytes-freed)))
339 (declare (ignore ignore-me))
340 (/show0 "got (DYNAMIC-USAGE) and EFF-N-BYTES-FREED")
341 (incf-pcounter *n-bytes-freed-or-purified-pcounter*
343 (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
344 (setf *need-to-collect-garbage* nil)
345 (/show0 "calculating NEW-GC-TRIGGER")
346 (let ((new-gc-trigger (+ post-gc-dynamic-usage
347 *bytes-consed-between-gcs*)))
348 (/show0 "setting *GC-TRIGGER*")
349 (setf *gc-trigger* new-gc-trigger))
350 (/show0 "calling SET-AUTO-GC-TRIGGER")
351 (set-auto-gc-trigger *gc-trigger*)
352 (dolist (hook *after-gc-hooks*)
353 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
354 ;; FIXME: This hook should be called with the same
355 ;; kind of information as *GC-NOTIFY-AFTER*. In
356 ;; particular, it would be nice for the hook function
357 ;; to be able to adjust *GC-TRIGGER* intelligently to
358 ;; e.g. 108% of total memory usage.
359 (carefully-funcall hook))
360 (when *gc-notify-stream*
361 (if (streamp *gc-notify-stream*)
362 (carefully-funcall *gc-notify-after*
364 post-gc-dynamic-usage
368 "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
369 (scrub-control-stack))) ;XXX again? we did this from C ...
370 (incf *gc-run-time* (- (get-internal-run-time)
372 ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
375 ;;; This routine is called by the allocation miscops to decide whether
376 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
377 ;;; object which must be returned to the caller.
378 (defun maybe-gc (&optional object)
382 ;;; This is the user-advertised garbage collection function.
383 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
384 #!+(and sb-doc gencgc)
385 "Initiate a garbage collection. GEN controls the number of generations
387 #!+(and sb-doc (not gencgc))
388 "Initiate a garbage collection. GEN may be provided for compatibility with
389 generational garbage collectors, but is ignored in this implementation."
390 (sub-gc :force-p t :gen (if full 6 gen)))
393 ;;;; auxiliary functions
395 (defun bytes-consed-between-gcs ()
397 "Return the amount of memory that will be allocated before the next garbage
398 collection is initiated. This can be set with SETF."
399 *bytes-consed-between-gcs*)
400 (defun (setf bytes-consed-between-gcs) (val)
401 ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
402 ;; be for a strictly positive number type, e.g.
403 ;; (AND (INTEGER 1) FIXNUM)?
404 (declare (type index val))
405 (let ((old *bytes-consed-between-gcs*))
406 (setf *bytes-consed-between-gcs* val)
408 (setf *gc-trigger* (+ *gc-trigger* (- val old)))
409 (cond ((<= (dynamic-usage) *gc-trigger*)
410 (clear-auto-gc-trigger)
411 (set-auto-gc-trigger *gc-trigger*))
413 ;; FIXME: If SCRUB-CONTROL-STACK is required here, why
414 ;; isn't it built into SUB-GC? And *is* it required here?
415 (sb!sys:scrub-control-stack)
421 "Enable the garbage collector."
422 (setq *gc-inhibit* nil)
423 (when *need-to-collect-garbage*
429 "Disable the garbage collector."
430 (setq *gc-inhibit* t)
433 ;;;; initialization stuff
437 (if (< *gc-trigger* (dynamic-usage))
439 (set-auto-gc-trigger *gc-trigger*))))