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
))
80 "Print to *STANDARD-OUTPUT* information about the state of internal
81 storage and its management. The optional argument controls the
82 verbosity of output. If it is T, ROOM prints out a maximal amount of
83 information. If it is NIL, ROOM prints out a minimal amount of
84 information. If it is :DEFAULT or it is not supplied, ROOM prints out
85 an intermediate amount of information."
93 (room-intermediate-info)))
98 ;;; the total number of bytes freed so far (including any freeing
99 ;;; which goes on in PURIFY)
101 ;;; (We save this so that we can calculate the total number of bytes
102 ;;; ever allocated by adding this to the number of bytes currently
103 ;;; allocated and never freed.)
104 (declaim (type unsigned-byte
*n-bytes-freed-or-purified
*))
105 (defvar *n-bytes-freed-or-purified
* 0)
107 (setq *gc-inhibit
* nil
)
109 (setf *n-bytes-freed-or-purified
* 0
111 ;; See comment in interr.lisp
112 *heap-exhausted-error-condition
* (make-condition 'heap-exhausted-error
)))
114 (declaim (ftype (sfunction () unsigned-byte
) get-bytes-consed
))
115 (defun get-bytes-consed ()
117 "Return the number of bytes consed since the program began. Typically
118 this result will be a consed bignum, so if you have an application (e.g.
119 profiling) which can't tolerate the overhead of consing bignums, you'll
120 probably want either to hack in at a lower level (as the code in the
121 SB-PROFILE package does), or to design a more microefficient interface
122 and submit it as a patch."
124 *n-bytes-freed-or-purified
*))
128 (!defvar
*after-gc-hooks
* nil
130 "Called after each garbage collection, except for garbage collections
131 triggered during thread exits. In a multithreaded environment these hooks may
137 (define-alien-routine collect-garbage int
138 (#!+gencgc last-gen
#!-gencgc ignore int
))
142 (define-alien-routine gc-stop-the-world void
)
143 (define-alien-routine gc-start-the-world void
))
146 (defun gc-stop-the-world ())
147 (defun gc-start-the-world ()))
151 (define-alien-variable ("gc_logfile" %gc-logfile
) (* char
))
152 (defun (setf gc-logfile
) (pathname)
153 (let ((new (when pathname
155 (native-namestring (translate-logical-pathname pathname
)
158 (setf %gc-logfile new
)
164 "Return the pathname used to log garbage collections. Can be SETF.
165 Default is NIL, meaning collections are not logged. If non-null, the
166 designated file is opened before and after each collection, and generation
167 statistics are appended to it."
168 (let ((val (cast %gc-logfile c-string
)))
170 (native-pathname val
)))))
172 (declaim (inline dynamic-space-size
))
173 (defun dynamic-space-size ()
175 "Size of the dynamic space in bytes."
176 (extern-alien "dynamic_space_size" os-vm-size-t
))
180 ;;; SUB-GC does a garbage collection. This is called from three places:
181 ;;; (1) The C runtime will call here when it detects that we've consed
182 ;;; enough to exceed the gc trigger threshold. This is done in
183 ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc
184 ;;; (2) The user may request a collection using GC, below
185 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
186 ;;; *NEED-TO-COLLECT-GARBAGE* is true
188 ;;; This is different from the behaviour in 0.7 and earlier: it no
189 ;;; longer decides whether to GC based on thresholds. If you call
190 ;;; SUB-GC you will definitely get a GC either now or when the
191 ;;; WITHOUT-GCING is over
193 ;;; For GENCGC all generations < GEN will be GC'ed.
195 (defvar *already-in-gc
* (sb!thread
:make-mutex
:name
"GC lock"))
197 ;;; A unique GC id. This is supplied for code that needs to detect
198 ;;; whether a GC has happened since some earlier point in time. For
201 ;;; (let ((epoch *gc-epoch*))
203 ;;; (unless (eql epoch *gc-epoch)
206 ;;; This isn't just a fixnum counter since then we'd have theoretical
207 ;;; problems when exactly 2^29 GCs happen between epoch
208 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
209 ;;; small to measure. -- JES, 2007-09-30
210 (declaim (type cons
*gc-epoch
*))
211 (!defvar
*gc-epoch
* '(nil . nil
))
213 (defun sub-gc (&key
(gen 0))
215 (setf *gc-pending
* t
)
218 (flet ((perform-gc ()
219 ;; Called from WITHOUT-GCING and WITHOUT-INTERRUPTS
220 ;; after the world has been stopped, but it's an
221 ;; awkwardly long piece of code to nest so deeply.
222 (let ((old-usage (dynamic-usage))
224 (start-time (get-internal-run-time)))
225 (collect-garbage gen
)
226 (setf *gc-epoch
* (cons nil nil
))
227 (let ((run-time (- (get-internal-run-time) start-time
)))
228 ;; KLUDGE: Sometimes we see the second getrusage() call
229 ;; return a smaller value than the first, which can
230 ;; lead to *GC-RUN-TIME* to going negative, which in
231 ;; turn is a type-error.
232 (when (plusp run-time
)
233 (incf *gc-run-time
* run-time
)))
235 (setf *stop-for-gc-pending
* nil
)
236 (setf *gc-pending
* nil
237 new-usage
(dynamic-usage))
239 (assert (not *stop-for-gc-pending
*))
241 ;; In a multithreaded environment the other threads
242 ;; will see *n-b-f-o-p* change a little late, but
244 ;; N.B. the outer without-gcing prevents this
245 ;; function from being entered, so no need for
247 (let ((freed (- old-usage new-usage
)))
248 ;; GENCGC occasionally reports negative here, but
249 ;; the current belief is that it is part of the
250 ;; normal order of things and not a bug.
252 (incf *n-bytes-freed-or-purified
* freed
))))))
253 (declare (inline perform-gc
))
254 ;; Let's make sure we're not interrupted and that none of
255 ;; the deadline or deadlock detection stuff triggers.
257 (sb!thread
::without-thread-waiting-for
258 (:already-without-interrupts t
)
259 (let ((sb!impl
::*deadline
* nil
)
260 (sb!impl
::*deadline-seconds
* nil
)
263 ;; GCing must be done without-gcing to avoid
264 ;; recursive GC... but we can't block on
265 ;; *already-in-gc* inside without-gcing: that would
268 ;; Try to grab that mutex. On acquisition, stop
269 ;; the world from with the mutex held, and then
270 ;; execute the remainder of the GC: stopping the
271 ;; world with interrupts disabled is the mother of
272 ;; all critical sections.
273 (cond ((sb!thread
:with-mutex
(*already-in-gc
* :wait-p nil
)
274 (unsafe-clear-roots gen
)
279 ;; Return, but leave *gc-pending* as is: we
280 ;; did allocate a tiny bit after GCing. In
281 ;; theory, this could lead to a long chain
282 ;; of tail-recursive (but not in explicit
283 ;; tail position) GCs, but that doesn't
284 ;; seem likely to happen too often... And
285 ;; the old code already suffered from this
289 ;; Some other thread is trying to GC. Clear
290 ;; *gc-pending* (we already know we want a
291 ;; GC to happen) and either let
292 ;; without-gcing figure out that the world
293 ;; is stopping, or try again.
294 (setf *gc-pending
* nil
))))
295 ;; we just wanted a minor GC, and a GC has
296 ;; occurred. Leave, but don't execute after-gc
299 ;; Return a 0 for easy ternary logic in the C
301 (when (and (eql gen
0)
302 (neq epoch
*gc-pending
*))
306 ;; Outside the mutex, interrupts may be enabled: these may cause
307 ;; another GC. FIXME: it can potentially exceed maximum interrupt
308 ;; nesting by triggering GCs.
310 ;; Can that be avoided by having the finalizers and hooks run only
311 ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
312 ;; handlers that's not enough.
314 ;; KLUDGE: Don't run the hooks in GC's if:
316 ;; A) this thread is dying, so that user-code never runs with
317 ;; (thread-alive-p *current-thread*) => nil
319 ;; B) interrupts are disabled somewhere up the call chain since we
320 ;; don't want to run user code in such a case.
322 ;; The long-term solution will be to keep a separate thread for
323 ;; finalizers and after-gc hooks.
324 (when (sb!thread
:thread-alive-p sb
!thread
:*current-thread
*)
325 (when *allow-with-interrupts
*
326 (sb!thread
::without-thread-waiting-for
()
328 (run-pending-finalizers)
329 (call-hooks "after-GC" *after-gc-hooks
* :on-error
:warn
))))))
331 ;;; This is the user-advertised garbage collection function.
332 (defun gc (&key
(full nil
) (gen 0) &allow-other-keys
)
333 #!+(and sb-doc gencgc
)
334 "Initiate a garbage collection.
336 The default is to initiate a nursery collection, which may in turn
337 trigger a collection of one or more older generations as well. If FULL
338 is true, all generations are collected. If GEN is provided, it can be
339 used to specify the oldest generation guaranteed to be collected.
341 On CheneyGC platforms arguments FULL and GEN take no effect: a full
342 collection is always performed."
343 #!+(and sb-doc
(not gencgc
))
344 "Initiate a garbage collection.
346 The collection is always a full collection.
348 Arguments FULL and GEN can be used for compatibility with GENCGC
349 platforms: there the default is to initiate a nursery collection,
350 which may in turn trigger a collection of one or more older
351 generations as well. If FULL is true, all generations are collected.
352 If GEN is provided, it can be used to specify the oldest generation
353 guaranteed to be collected."
354 #!-gencgc
(declare (ignore full
))
355 (let (#!+gencgc
(gen (if full sb
!vm
:+pseudo-static-generation
+ gen
)))
356 (when (eq t
(sub-gc :gen gen
))
359 (define-alien-routine scrub-control-stack void
)
361 (defun unsafe-clear-roots (gen)
362 #!-gencgc
(declare (ignore gen
))
363 ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
364 ;; as having these cons more than we have space left leads to huge
366 (scrub-control-stack)
367 ;; Power cache of the bignum printer: drops overly large bignums and
368 ;; removes duplicate entries.
370 ;; Clear caches depending on the generation being collected.
373 ;; Drop strings because the hash is pointer-hash
374 ;; but there is no automatic cache rehashing after GC.
375 (sb!format
::tokenize-control-string-cache-clear
))
377 (sb!format
::tokenize-control-string-cache-clear
)
378 (ctype-of-cache-clear))
380 (drop-all-hash-caches)))
382 (drop-all-hash-caches))
384 ;;;; auxiliary functions
386 (defun bytes-consed-between-gcs ()
388 "The amount of memory that will be allocated before the next garbage
389 collection is initiated. This can be set with SETF.
391 On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic
394 Note: currently changes to this value are lost when saving core."
395 (extern-alien "bytes_consed_between_gcs" os-vm-size-t
))
397 (defun (setf bytes-consed-between-gcs
) (val)
398 (declare (type index val
))
399 (setf (extern-alien "bytes_consed_between_gcs" os-vm-size-t
)
402 (declaim (inline maybe-handle-pending-gc
))
403 (defun maybe-handle-pending-gc ()
404 (when (and (not *gc-inhibit
*)
405 (or #!+sb-thread
*stop-for-gc-pending
*
407 (sb!unix
::receive-pending-interrupt
)))
409 ;;;; GENCGC specifics
411 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
414 (deftype generation-index
()
415 '(integer 0 #.sb
!vm
:+pseudo-static-generation
+))
417 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
418 ;;; defined in Lisp, and written to header files by genesis, instead of this
419 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
421 (define-alien-type generation
423 (alloc-start-page page-index-t
)
424 (alloc-unboxed-start-page page-index-t
)
425 (alloc-large-start-page page-index-t
)
426 (alloc-large-unboxed-start-page page-index-t
)
427 (bytes-allocated os-vm-size-t
)
428 (gc-trigger os-vm-size-t
)
429 (bytes-consed-between-gcs os-vm-size-t
)
431 (number-of-gcs-before-promotion int
)
432 (cum-sum-bytes-allocated os-vm-size-t
)
433 (minimum-age-before-gc double
)))
436 (define-alien-variable generations
437 (array generation
#.
(1+ sb
!vm
:+pseudo-static-generation
+)))
439 (macrolet ((def (slot doc
&optional setfp
)
440 (declare (ignorable doc
))
442 (defun ,(symbolicate "GENERATION-" slot
) (generation)
446 (declare (generation-index generation
))
448 (declare (ignore generation
))
450 (error "~S is a GENCGC only function and unavailable in this build"
453 (slot (deref generations generation
) ',slot
))
455 `((defun (setf ,(symbolicate "GENERATION-" slot
)) (value generation
)
457 (declare (generation-index generation
))
459 (declare (ignore value generation
))
461 (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
464 (setf (slot (deref generations generation
) ',slot
) value
)))))))
465 (def bytes-consed-between-gcs
466 "Number of bytes that can be allocated to GENERATION before that
467 generation is considered for garbage collection. This value is meaningless for
468 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
469 5% of the dynamic space size divided by the number of non-nursery generations.
470 Can be assigned to using SETF. Available on GENCGC platforms only.
472 Experimental: interface subject to change."
474 (def minimum-age-before-gc
475 "Minimum average age of objects allocated to GENERATION before that
476 generation is may be garbage collected. Default is 0.75. See also
477 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
480 Experimental: interface subject to change."
482 (def number-of-gcs-before-promotion
483 "Number of times garbage collection is done on GENERATION before
484 automatic promotion to the next generation is triggered. Default is 1. Can be
485 assigned to using SETF. Available on GENCGC platforms only.
487 Experimental: interface subject to change."
490 "Number of bytes allocated to GENERATION currently. Available on GENCGC
493 Experimental: interface subject to change.")
495 "Number of times garbage collection has been done on GENERATION without
496 promotion. Available on GENCGC platforms only.
498 Experimental: interface subject to change."))
499 (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
))