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
17 (declaim (inline current-dynamic-space-start))
19 (defun current-dynamic-space-start () sb!vm:dynamic-space-start)
21 (defun current-dynamic-space-start ()
22 (sb!alien:extern-alien "current_dynamic_space" sb!alien:unsigned-long))
25 (declaim (inline dynamic-usage))
27 (defun dynamic-usage ()
28 (sb!alien:extern-alien "bytes_allocated" os-vm-size-t))
30 (defun dynamic-usage ()
31 (the (unsigned-byte 32)
32 (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
33 (current-dynamic-space-start))))
35 (defun static-space-usage ()
36 (- (ash sb!vm:*static-space-free-pointer* sb!vm:n-fixnum-tag-bits)
37 sb!vm:static-space-start))
39 (defun read-only-space-usage ()
40 (- (ash sb!vm::*read-only-space-free-pointer* sb!vm:n-fixnum-tag-bits)
41 sb!vm:read-only-space-start))
43 (defun control-stack-usage ()
44 #!-stack-grows-downward-not-upward
45 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
46 (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*)))
47 #!+stack-grows-downward-not-upward
48 (- (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
49 (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
51 (defun binding-stack-usage ()
52 (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
53 (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*binding-stack-start*))))
57 (defun room-minimal-info ()
58 (format t "Dynamic space usage is: ~10:D bytes.~%" (dynamic-usage))
59 (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
60 (format t "Static space usage is: ~10:D bytes.~%" (static-space-usage))
61 (format t "Control stack usage is: ~10:D bytes.~%" (control-stack-usage))
62 (format t "Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage))
65 "Control and binding stack usage is for the current thread only.~%")
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 ()
77 ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
78 (room-intermediate-info)
79 ;; old way, could be restored when bug 344 fixed:
80 ;;x (room-minimal-info)
81 ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
82 ;;x (sb!vm:instance-usage :dynamic :top-n 10)
83 ;;x (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 unsigned-byte *n-bytes-freed-or-purified*))
113 (defvar *n-bytes-freed-or-purified* 0)
115 (setq *gc-inhibit* nil)
117 (setf *n-bytes-freed-or-purified* 0
119 ;; See comment in interr.lisp
120 *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error)))
122 (declaim (ftype (sfunction () unsigned-byte) get-bytes-consed))
123 (defun get-bytes-consed ()
125 "Return the number of bytes consed since the program began. Typically
126 this result will be a consed bignum, so if you have an application (e.g.
127 profiling) which can't tolerate the overhead of consing bignums, you'll
128 probably want either to hack in at a lower level (as the code in the
129 SB-PROFILE package does), or to design a more microefficient interface
130 and submit it as a patch."
132 *n-bytes-freed-or-purified*))
136 (defvar *after-gc-hooks* nil
137 "Called after each garbage collection, except for garbage collections
138 triggered during thread exits. In a multithreaded environment these hooks may
144 (sb!alien:define-alien-routine collect-garbage sb!alien:int
145 (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
149 (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
150 (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
153 (defun gc-stop-the-world ())
154 (defun gc-start-the-world ()))
158 (sb!alien:define-alien-variable ("gc_logfile" %gc-logfile) (* char))
159 (defun (setf gc-logfile) (pathname)
160 (let ((new (when pathname
161 (sb!alien:make-alien-string
162 (native-namestring (translate-logical-pathname pathname)
165 (setf %gc-logfile new)
167 (sb!alien:free-alien old))
171 "Return the pathname used to log garbage collections. Can be SETF.
172 Default is NIL, meaning collections are not logged. If non-null, the
173 designated file is opened before and after each collection, and generation
174 statistics are appended to it."
175 (let ((val (cast %gc-logfile c-string)))
177 (native-pathname val))))
178 (declaim (inline dynamic-space-size))
179 (defun dynamic-space-size ()
180 "Size of the dynamic space in bytes."
181 (sb!alien:extern-alien "dynamic_space_size" os-vm-size-t)))
185 ;;; SUB-GC does a garbage collection. This is called from three places:
186 ;;; (1) The C runtime will call here when it detects that we've consed
187 ;;; enough to exceed the gc trigger threshold. This is done in
188 ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc
189 ;;; (2) The user may request a collection using GC, below
190 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
191 ;;; *NEED-TO-COLLECT-GARBAGE* is true
193 ;;; This is different from the behaviour in 0.7 and earlier: it no
194 ;;; longer decides whether to GC based on thresholds. If you call
195 ;;; SUB-GC you will definitely get a GC either now or when the
196 ;;; WITHOUT-GCING is over
198 ;;; For GENCGC all generations < GEN will be GC'ed.
200 (defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock"))
202 ;;; A unique GC id. This is supplied for code that needs to detect
203 ;;; whether a GC has happened since some earlier point in time. For
206 ;;; (let ((epoch *gc-epoch*))
208 ;;; (unless (eql epoch *gc-epoch)
211 ;;; This isn't just a fixnum counter since then we'd have theoretical
212 ;;; problems when exactly 2^29 GCs happen between epoch
213 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
214 ;;; small to measure. -- JES, 2007-09-30
215 (declaim (type cons *gc-epoch*))
216 (defvar *gc-epoch* (cons nil nil))
218 (defun sub-gc (&key (gen 0))
220 (setf *gc-pending* t)
223 (flet ((perform-gc ()
224 ;; Called from WITHOUT-GCING and WITHOUT-INTERRUPTS
225 ;; after the world has been stopped, but it's an
226 ;; awkwardly long piece of code to nest so deeply.
227 (let ((old-usage (dynamic-usage))
229 (start-time (get-internal-run-time)))
230 (collect-garbage gen)
231 (setf *gc-epoch* (cons nil nil))
232 (let ((run-time (- (get-internal-run-time) start-time)))
233 ;; KLUDGE: Sometimes we see the second getrusage() call
234 ;; return a smaller value than the first, which can
235 ;; lead to *GC-RUN-TIME* to going negative, which in
236 ;; turn is a type-error.
237 (when (plusp run-time)
238 (incf *gc-run-time* run-time)))
240 (setf *stop-for-gc-pending* nil)
241 (setf *gc-pending* nil
242 new-usage (dynamic-usage))
244 (assert (not *stop-for-gc-pending*))
246 ;; In a multithreaded environment the other threads
247 ;; will see *n-b-f-o-p* change a little late, but
249 ;; N.B. the outer without-gcing prevents this
250 ;; function from being entered, so no need for
252 (let ((freed (- old-usage new-usage)))
253 ;; GENCGC occasionally reports negative here, but
254 ;; the current belief is that it is part of the
255 ;; normal order of things and not a bug.
257 (incf *n-bytes-freed-or-purified* freed))))))
258 (declare (inline perform-gc))
259 ;; Let's make sure we're not interrupted and that none of
260 ;; the deadline or deadlock detection stuff triggers.
262 (sb!thread::without-thread-waiting-for
263 (:already-without-interrupts t)
264 (let ((sb!impl::*deadline* nil)
265 (sb!impl::*deadline-seconds* nil)
268 ;; GCing must be done without-gcing to avoid
269 ;; recursive GC... but we can't block on
270 ;; *already-in-gc* inside without-gcing: that would
273 ;; Try to grab that mutex. On acquisition, stop
274 ;; the world from with the mutex held, and then
275 ;; execute the remainder of the GC: stopping the
276 ;; world with interrupts disabled is the mother of
277 ;; all critical sections.
278 (cond ((sb!thread:with-mutex (*already-in-gc* :wait-p nil)
279 (unsafe-clear-roots gen)
284 ;; Return, but leave *gc-pending* as is: we
285 ;; did allocate a tiny bit after GCing. In
286 ;; theory, this could lead to a long chain
287 ;; of tail-recursive (but not in explicit
288 ;; tail position) GCs, but that doesn't
289 ;; seem likely to happen too often... And
290 ;; the old code already suffered from this
294 ;; Some other thread is trying to GC. Clear
295 ;; *gc-pending* (we already know we want a
296 ;; GC to happen) and either let
297 ;; without-gcing figure out that the world
298 ;; is stopping, or try again.
299 (setf *gc-pending* nil))))
300 ;; we just wanted a minor GC, and a GC has
301 ;; occurred. Leave, but don't execute after-gc
304 ;; Return a 0 for easy ternary logic in the C
306 (when (and (eql gen 0)
307 (neq epoch *gc-pending*))
311 ;; Outside the mutex, interrupts may be enabled: these may cause
312 ;; another GC. FIXME: it can potentially exceed maximum interrupt
313 ;; nesting by triggering GCs.
315 ;; Can that be avoided by having the finalizers and hooks run only
316 ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
317 ;; handlers that's not enough.
319 ;; KLUDGE: Don't run the hooks in GC's if:
321 ;; A) this thread is dying, so that user-code never runs with
322 ;; (thread-alive-p *current-thread*) => nil
324 ;; B) interrupts are disabled somewhere up the call chain since we
325 ;; don't want to run user code in such a case.
327 ;; The long-term solution will be to keep a separate thread for
328 ;; finalizers and after-gc hooks.
329 (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
330 (when *allow-with-interrupts*
331 (sb!thread::without-thread-waiting-for ()
333 (run-pending-finalizers)
334 (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))
336 ;;; This is the user-advertised garbage collection function.
337 (defun gc (&key (full nil) (gen 0) &allow-other-keys)
338 #!+(and sb-doc gencgc)
339 "Initiate a garbage collection.
341 The default is to initiate a nursery collection, which may in turn
342 trigger a collection of one or more older generations as well. If FULL
343 is true, all generations are collected. If GEN is provided, it can be
344 used to specify the oldest generation guaranteed to be collected.
346 On CheneyGC platforms arguments FULL and GEN take no effect: a full
347 collection is always preformed."
348 #!+(and sb-doc (not gencgc))
349 "Initiate a garbage collection.
351 The collection is always a full collection.
353 Arguments FULL and GEN can be used for compatibility with GENCGC
354 platforms: there the default is to initiate a nursery collection,
355 which may in turn trigger a collection of one or more older
356 generations as well. If FULL is true, all generations are collected.
357 If GEN is provided, it can be used to specify the oldest generation
358 guaranteed to be collected."
359 #!-gencgc (declare (ignore full))
360 (let (#!+gencgc (gen (if full sb!vm:+pseudo-static-generation+ gen)))
361 (when (eq t (sub-gc :gen gen))
364 (define-alien-routine scrub-control-stack sb!alien:void)
366 (defun unsafe-clear-roots (gen)
367 #!-gencgc (declare (ignore gen))
368 ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
369 ;; as having these cons more then we have space left leads to huge
371 (scrub-control-stack)
372 ;; Power cache of the bignum printer: drops overly large bignums and
373 ;; removes duplicate entries.
375 ;; Clear caches depending on the generation being collected.
379 (ctype-of-cache-clear))
381 (drop-all-hash-caches)))
383 (drop-all-hash-caches))
385 ;;;; auxiliary functions
387 (defun bytes-consed-between-gcs ()
389 "The amount of memory that will be allocated before the next garbage
390 collection is initiated. This can be set with SETF.
392 On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic
395 Note: currently changes to this value are lost when saving core."
396 (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t))
398 (defun (setf bytes-consed-between-gcs) (val)
399 (declare (type index val))
400 (setf (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t)
403 (declaim (inline maybe-handle-pending-gc))
404 (defun maybe-handle-pending-gc ()
405 (when (and (not *gc-inhibit*)
406 (or #!+sb-thread *stop-for-gc-pending*
408 (sb!unix::receive-pending-interrupt)))
410 ;;;; GENCGC specifics
412 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
415 (deftype generation-index ()
416 '(integer 0 #.sb!vm:+pseudo-static-generation+))
418 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
419 ;;; defined in Lisp, and written to header files by genesis, instead of this
420 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
422 (define-alien-type generation
424 (alloc-start-page page-index-t)
425 (alloc-unboxed-start-page page-index-t)
426 (alloc-large-start-page page-index-t)
427 (alloc-large-unboxed-start-page page-index-t)
428 (bytes-allocated os-vm-size-t)
429 (gc-trigger os-vm-size-t)
430 (bytes-consed-between-gcs os-vm-size-t)
432 (number-of-gcs-before-promotion int)
433 (cum-sum-bytes-allocated os-vm-size-t)
434 (minimum-age-before-gc double)))
437 (define-alien-variable generations
438 (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
440 (macrolet ((def (slot doc &optional setfp)
441 (declare (ignorable doc))
443 (defun ,(symbolicate "GENERATION-" slot) (generation)
447 (declare (generation-index generation))
449 (declare (ignore generation))
451 (error "~S is a GENCGC only function and unavailable in this build"
454 (slot (deref generations generation) ',slot))
456 `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
458 (declare (generation-index generation))
460 (declare (ignore value generation))
462 (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
465 (setf (slot (deref generations generation) ',slot) value)))))))
466 (def bytes-consed-between-gcs
467 "Number of bytes that can be allocated to GENERATION before that
468 generation is considered for garbage collection. This value is meaningless for
469 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
470 5% of the dynamic space size divided by the number of non-nursery generations.
471 Can be assigned to using SETF. Available on GENCGC platforms only.
473 Experimental: interface subject to change."
475 (def minimum-age-before-gc
476 "Minimum average age of objects allocated to GENERATION before that
477 generation is may be garbage collected. Default is 0.75. See also
478 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
481 Experimental: interface subject to change."
483 (def number-of-gcs-before-promotion
484 "Number of times garbage collection is done on GENERATION before
485 automatic promotion to the next generation is triggered. Default is 1. Can be
486 assigned to using SETF. Available on GENCGC platforms only.
488 Experimental: interface subject to change."
491 "Number of bytes allocated to GENERATION currently. Available on GENCGC
494 Experimental: interface subject to change.")
496 "Number of times garbage collection has been done on GENERATION without
497 promotion. Available on GENCGC platforms only.
499 Experimental: interface subject to change."))
500 (defun generation-average-age (generation)
501 "Average age of memory allocated to GENERATION: average number of times
502 objects allocated to the generation have seen younger objects promoted to it.
503 Available on GENCGC platforms only.
505 Experimental: interface subject to change."
507 (declare (generation-index generation))
508 #!-gencgc (declare (ignore generation))
510 (error "~S is a GENCGC only function and unavailable in this build."
511 'generation-average-age)
513 (alien-funcall (extern-alien "generation_average_age"
514 (function double generation-index-t))