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 dynamic-usage
))
19 (defun dynamic-usage ()
20 (extern-alien "bytes_allocated" os-vm-size-t
))
22 (defun dynamic-usage ()
24 (- (sap-int (sb!c
::dynamic-space-free-pointer
))
25 (current-dynamic-space-start))))
27 (defun static-space-usage ()
28 (- (ash sb
!vm
:*static-space-free-pointer
* sb
!vm
:n-fixnum-tag-bits
)
29 sb
!vm
:static-space-start
))
31 (defun read-only-space-usage ()
32 (- (ash sb
!vm
::*read-only-space-free-pointer
* sb
!vm
:n-fixnum-tag-bits
)
33 sb
!vm
:read-only-space-start
))
35 (defun control-stack-usage ()
36 #!-stack-grows-downward-not-upward
37 (- (sap-int (sb!c
::control-stack-pointer-sap
))
38 (sap-int (sb!di
::descriptor-sap sb
!vm
:*control-stack-start
*)))
39 #!+stack-grows-downward-not-upward
40 (- (sap-int (sb!di
::descriptor-sap sb
!vm
:*control-stack-end
*))
41 (sap-int (sb!c
::control-stack-pointer-sap
))))
43 (defun binding-stack-usage ()
44 (- (sap-int (sb!c
::binding-stack-pointer-sap
))
45 (sap-int (sb!di
::descriptor-sap sb
!vm
:*binding-stack-start
*))))
49 (defun room-minimal-info ()
50 (format t
"Dynamic space usage is: ~10:D bytes.~%" (dynamic-usage))
51 (format t
"Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
52 (format t
"Static space usage is: ~10:D bytes.~%" (static-space-usage))
53 (format t
"Control stack usage is: ~10:D bytes.~%" (control-stack-usage))
54 (format t
"Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage))
57 "Control and binding stack usage is for the current thread only.~%")
58 (format t
"Garbage collection is currently ~:[enabled~;DISABLED~].~%"
61 (defun room-intermediate-info ()
63 (sb!vm
:memory-usage
:count-spaces
'(:dynamic
)
68 (defun room-maximal-info ()
69 ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
70 (room-intermediate-info)
71 ;; old way, could be restored when bug 344 fixed:
72 ;;x (room-minimal-info)
73 ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
74 ;;x (sb!vm:instance-usage :dynamic :top-n 10)
75 ;;x (sb!vm:instance-usage :static :top-n 10)
78 (defun room (&optional
(verbosity :default
))
79 "Print to *STANDARD-OUTPUT* information about the state of internal
80 storage and its management. The optional argument controls the
81 verbosity of output. If it is T, ROOM prints out a maximal amount of
82 information. If it is NIL, ROOM prints out a minimal amount of
83 information. If it is :DEFAULT or it is not supplied, ROOM prints out
84 an intermediate amount of information."
92 (room-intermediate-info)))
97 ;;; the total number of bytes freed so far (including any freeing
98 ;;; which goes on in PURIFY)
100 ;;; (We save this so that we can calculate the total number of bytes
101 ;;; ever allocated by adding this to the number of bytes currently
102 ;;; allocated and never freed.)
103 (declaim (type unsigned-byte
*n-bytes-freed-or-purified
*))
104 (defvar *n-bytes-freed-or-purified
* 0)
106 (setq *gc-inhibit
* nil
)
108 (setf *n-bytes-freed-or-purified
* 0
111 (declaim (ftype (sfunction () unsigned-byte
) get-bytes-consed
))
112 (defun get-bytes-consed ()
113 "Return the number of bytes consed since the program began. Typically
114 this result will be a consed bignum, so if you have an application (e.g.
115 profiling) which can't tolerate the overhead of consing bignums, you'll
116 probably want either to hack in at a lower level (as the code in the
117 SB-PROFILE package does), or to design a more microefficient interface
118 and submit it as a patch."
120 *n-bytes-freed-or-purified
*))
124 (!defvar
*after-gc-hooks
* nil
125 "Called after each garbage collection, except for garbage collections
126 triggered during thread exits. In a multithreaded environment these hooks may
132 (define-alien-routine collect-garbage int
133 (#!+gencgc last-gen
#!-gencgc ignore int
))
137 (define-alien-routine gc-stop-the-world void
)
138 (define-alien-routine gc-start-the-world void
))
141 (defun gc-stop-the-world ())
142 (defun gc-start-the-world ()))
146 (define-alien-variable ("gc_logfile" %gc-logfile
) (* char
))
147 (defun (setf gc-logfile
) (pathname)
148 (let ((new (when pathname
150 (native-namestring (translate-logical-pathname pathname
)
153 (setf %gc-logfile new
)
158 "Return the pathname used to log garbage collections. Can be SETF.
159 Default is NIL, meaning collections are not logged. If non-null, the
160 designated file is opened before and after each collection, and generation
161 statistics are appended to it."
162 (let ((val (cast %gc-logfile c-string
)))
164 (native-pathname val
)))))
166 (declaim (inline dynamic-space-size
))
167 (defun dynamic-space-size ()
168 "Size of the dynamic space in bytes."
169 (extern-alien "dynamic_space_size" os-vm-size-t
))
171 (define-symbol-macro sb
!vm
:dynamic-space-end
172 (+ (dynamic-space-size) sb
!vm
:dynamic-space-start
))
176 ;;; SUB-GC does a garbage collection. This is called from three places:
177 ;;; (1) The C runtime will call here when it detects that we've consed
178 ;;; enough to exceed the gc trigger threshold. This is done in
179 ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc
180 ;;; (2) The user may request a collection using GC, below
181 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
182 ;;; *NEED-TO-COLLECT-GARBAGE* is true
184 ;;; This is different from the behaviour in 0.7 and earlier: it no
185 ;;; longer decides whether to GC based on thresholds. If you call
186 ;;; SUB-GC you will definitely get a GC either now or when the
187 ;;; WITHOUT-GCING is over
189 ;;; For GENCGC all generations < GEN will be GC'ed.
191 (defvar *already-in-gc
* (sb!thread
:make-mutex
:name
"GC lock"))
193 (defun sub-gc (&key
(gen 0))
195 (setf *gc-pending
* t
)
198 (flet ((perform-gc ()
199 ;; Called from WITHOUT-GCING and WITHOUT-INTERRUPTS
200 ;; after the world has been stopped, but it's an
201 ;; awkwardly long piece of code to nest so deeply.
202 (let ((old-usage (dynamic-usage))
204 (start-time (get-internal-run-time)))
205 (collect-garbage gen
)
206 (setf *gc-epoch
* (cons nil nil
))
207 (let ((run-time (- (get-internal-run-time) start-time
)))
208 ;; KLUDGE: Sometimes we see the second getrusage() call
209 ;; return a smaller value than the first, which can
210 ;; lead to *GC-RUN-TIME* to going negative, which in
211 ;; turn is a type-error.
212 (when (plusp run-time
)
213 (incf *gc-run-time
* run-time
)))
215 (setf *stop-for-gc-pending
* nil
)
216 (setf *gc-pending
* nil
217 new-usage
(dynamic-usage))
219 (assert (not *stop-for-gc-pending
*))
221 ;; In a multithreaded environment the other threads
222 ;; will see *n-b-f-o-p* change a little late, but
224 ;; N.B. the outer without-gcing prevents this
225 ;; function from being entered, so no need for
227 (let ((freed (- old-usage new-usage
)))
228 ;; GENCGC occasionally reports negative here, but
229 ;; the current belief is that it is part of the
230 ;; normal order of things and not a bug.
232 (incf *n-bytes-freed-or-purified
* freed
))))))
233 (declare (inline perform-gc
))
234 ;; Let's make sure we're not interrupted and that none of
235 ;; the deadline or deadlock detection stuff triggers.
237 (sb!thread
::without-thread-waiting-for
238 (:already-without-interrupts t
)
239 (let ((sb!impl
::*deadline
* nil
)
240 (sb!impl
::*deadline-seconds
* nil
)
243 ;; GCing must be done without-gcing to avoid
244 ;; recursive GC... but we can't block on
245 ;; *already-in-gc* inside without-gcing: that would
248 ;; Try to grab that mutex. On acquisition, stop
249 ;; the world from with the mutex held, and then
250 ;; execute the remainder of the GC: stopping the
251 ;; world with interrupts disabled is the mother of
252 ;; all critical sections.
253 (cond ((sb!thread
:with-mutex
(*already-in-gc
* :wait-p nil
)
254 (unsafe-clear-roots gen
)
259 ;; Return, but leave *gc-pending* as is: we
260 ;; did allocate a tiny bit after GCing. In
261 ;; theory, this could lead to a long chain
262 ;; of tail-recursive (but not in explicit
263 ;; tail position) GCs, but that doesn't
264 ;; seem likely to happen too often... And
265 ;; the old code already suffered from this
269 ;; Some other thread is trying to GC. Clear
270 ;; *gc-pending* (we already know we want a
271 ;; GC to happen) and either let
272 ;; without-gcing figure out that the world
273 ;; is stopping, or try again.
274 (setf *gc-pending
* nil
))))
275 ;; we just wanted a minor GC, and a GC has
276 ;; occurred. Leave, but don't execute after-gc
279 ;; Return a 0 for easy ternary logic in the C
281 (when (and (eql gen
0)
282 (neq epoch
*gc-pending
*))
286 ;; Outside the mutex, interrupts may be enabled: these may cause
287 ;; another GC. FIXME: it can potentially exceed maximum interrupt
288 ;; nesting by triggering GCs.
290 ;; Can that be avoided by having the finalizers and hooks run only
291 ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
292 ;; handlers that's not enough.
294 ;; KLUDGE: Don't run the hooks in GC's if:
296 ;; A) this thread is dying, so that user-code never runs with
297 ;; (thread-alive-p *current-thread*) => nil
299 ;; B) interrupts are disabled somewhere up the call chain since we
300 ;; don't want to run user code in such a case.
302 ;; The long-term solution will be to keep a separate thread for
303 ;; finalizers and after-gc hooks.
304 (when (sb!thread
:thread-alive-p sb
!thread
:*current-thread
*)
305 (when *allow-with-interrupts
*
306 (sb!thread
::without-thread-waiting-for
()
308 (run-pending-finalizers)
309 (call-hooks "after-GC" *after-gc-hooks
* :on-error
:warn
))))))
311 ;;; This is the user-advertised garbage collection function.
312 (defun gc (&key
(full nil
) (gen 0) &allow-other-keys
)
314 "Initiate a garbage collection.
316 The default is to initiate a nursery collection, which may in turn
317 trigger a collection of one or more older generations as well. If FULL
318 is true, all generations are collected. If GEN is provided, it can be
319 used to specify the oldest generation guaranteed to be collected.
321 On CheneyGC platforms arguments FULL and GEN take no effect: a full
322 collection is always performed."
324 "Initiate a garbage collection.
326 The collection is always a full collection.
328 Arguments FULL and GEN can be used for compatibility with GENCGC
329 platforms: there the default is to initiate a nursery collection,
330 which may in turn trigger a collection of one or more older
331 generations as well. If FULL is true, all generations are collected.
332 If GEN is provided, it can be used to specify the oldest generation
333 guaranteed to be collected."
334 #!-gencgc
(declare (ignore full
))
335 (let (#!+gencgc
(gen (if full sb
!vm
:+pseudo-static-generation
+ gen
)))
336 (when (eq t
(sub-gc :gen gen
))
339 (define-alien-routine scrub-control-stack void
)
341 (defun unsafe-clear-roots (gen)
342 #!-gencgc
(declare (ignore gen
))
343 ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
344 ;; as having these cons more than we have space left leads to huge
346 (scrub-control-stack)
347 ;; Power cache of the bignum printer: drops overly large bignums and
348 ;; removes duplicate entries.
350 ;; Clear caches depending on the generation being collected.
353 ;; Drop strings because the hash is pointer-hash
354 ;; but there is no automatic cache rehashing after GC.
355 (sb!format
::tokenize-control-string-cache-clear
))
357 (sb!format
::tokenize-control-string-cache-clear
)
358 (ctype-of-cache-clear))
360 (drop-all-hash-caches)))
362 (drop-all-hash-caches))
364 ;;;; auxiliary functions
366 (defun bytes-consed-between-gcs ()
367 "The amount of memory that will be allocated before the next garbage
368 collection is initiated. This can be set with SETF.
370 On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic
373 Note: currently changes to this value are lost when saving core."
374 (extern-alien "bytes_consed_between_gcs" os-vm-size-t
))
376 (defun (setf bytes-consed-between-gcs
) (val)
377 (declare (type index val
))
378 (setf (extern-alien "bytes_consed_between_gcs" os-vm-size-t
)
381 (declaim (inline maybe-handle-pending-gc
))
382 (defun maybe-handle-pending-gc ()
383 (when (and (not *gc-inhibit
*)
384 (or #!+sb-thread
*stop-for-gc-pending
*
386 (sb!unix
::receive-pending-interrupt
)))
388 ;;;; GENCGC specifics
390 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
393 (deftype generation-index
()
394 '(integer 0 #.sb
!vm
:+pseudo-static-generation
+))
396 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
397 ;;; defined in Lisp, and written to header files by genesis, instead of this
398 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
400 (define-alien-type generation
402 (alloc-large-start-page page-index-t
)
403 (alloc-start-page page-index-t
)
404 (alloc-unboxed-start-page page-index-t
)
405 #!+segregated-code
(alloc-code-start-page page-index-t
)
406 (bytes-allocated os-vm-size-t
)
407 (gc-trigger os-vm-size-t
)
408 (bytes-consed-between-gcs os-vm-size-t
)
410 (number-of-gcs-before-promotion int
)
411 (cum-sum-bytes-allocated os-vm-size-t
)
412 (minimum-age-before-gc double
)))
415 (define-alien-variable generations
416 (array generation
#.
(1+ sb
!vm
:+pseudo-static-generation
+)))
418 (macrolet ((def (slot doc
&optional setfp
)
420 (defun ,(symbolicate "GENERATION-" slot
) (generation)
423 (declare (generation-index generation
))
425 (declare (ignore generation
))
427 (error "~S is a GENCGC only function and unavailable in this build"
430 (slot (deref generations generation
) ',slot
))
432 `((defun (setf ,(symbolicate "GENERATION-" slot
)) (value generation
)
434 (declare (generation-index generation
))
436 (declare (ignore value generation
))
438 (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
441 (setf (slot (deref generations generation
) ',slot
) value
)))))))
442 (def bytes-consed-between-gcs
443 "Number of bytes that can be allocated to GENERATION before that
444 generation is considered for garbage collection. This value is meaningless for
445 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
446 5% of the dynamic space size divided by the number of non-nursery generations.
447 Can be assigned to using SETF. Available on GENCGC platforms only.
449 Experimental: interface subject to change."
451 (def minimum-age-before-gc
452 "Minimum average age of objects allocated to GENERATION before that
453 generation is may be garbage collected. Default is 0.75. See also
454 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
457 Experimental: interface subject to change."
459 (def number-of-gcs-before-promotion
460 "Number of times garbage collection is done on GENERATION before
461 automatic promotion to the next generation is triggered. Default is 1. Can be
462 assigned to using SETF. Available on GENCGC platforms only.
464 Experimental: interface subject to change."
467 "Number of bytes allocated to GENERATION currently. Available on GENCGC
470 Experimental: interface subject to change.")
472 "Number of times garbage collection has been done on GENERATION without
473 promotion. Available on GENCGC platforms only.
475 Experimental: interface subject to change."))
476 (defun generation-average-age (generation)
477 "Average age of memory allocated to GENERATION: average number of times
478 objects allocated to the generation have seen younger objects promoted to it.
479 Available on GENCGC platforms only.
481 Experimental: interface subject to change."
483 (declare (generation-index generation
))
484 #!-gencgc
(declare (ignore generation
))
486 (error "~S is a GENCGC only function and unavailable in this build."
487 'generation-average-age
)
489 (alien-funcall (extern-alien "generation_average_age"
490 (function double generation-index-t
))