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