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:n-word-bytes)
46 sb!vm:static-space-start))
48 (defun read-only-space-usage ()
49 (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes)
50 sb!vm:read-only-space-start))
52 (defun control-stack-usage ()
53 #!-stack-grows-downward-not-upward
54 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
55 (sb!vm:fixnumize sb!vm:*control-stack-start*))
56 #!+stack-grows-downward-not-upward
57 (- (sb!vm:fixnumize sb!vm:*control-stack-end*)
58 (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
60 (defun binding-stack-usage ()
61 (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
62 (sb!vm:fixnumize sb!vm:*binding-stack-start*)))
66 (defun room-minimal-info ()
67 (format t "Dynamic space usage is: ~10:D bytes.~%" (dynamic-usage))
68 (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
69 (format t "Static space usage is: ~10:D bytes.~%" (static-space-usage))
70 (format t "Control stack usage is: ~10:D bytes.~%" (control-stack-usage))
71 (format t "Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage))
74 "Control and binding stack usage is for the current thread only.~%")
75 (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
78 (defun room-intermediate-info ()
80 (sb!vm:memory-usage :count-spaces '(:dynamic)
85 (defun room-maximal-info ()
86 ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
87 (room-intermediate-info)
88 ;; old way, could be restored when bug 344 fixed:
89 ;;x (room-minimal-info)
90 ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
91 ;;x (sb!vm:instance-usage :dynamic :top-n 10)
92 ;;x (sb!vm:instance-usage :static :top-n 10)
95 (defun room (&optional (verbosity :default))
97 "Print to *STANDARD-OUTPUT* information about the state of internal
98 storage and its management. The optional argument controls the
99 verbosity of output. If it is T, ROOM prints out a maximal amount of
100 information. If it is NIL, ROOM prints out a minimal amount of
101 information. If it is :DEFAULT or it is not supplied, ROOM prints out
102 an intermediate amount of information."
110 (room-intermediate-info)))
113 ;;;; GET-BYTES-CONSED
115 ;;; the total number of bytes freed so far (including any freeing
116 ;;; which goes on in PURIFY)
118 ;;; (We save this so that we can calculate the total number of bytes
119 ;;; ever allocated by adding this to the number of bytes currently
120 ;;; allocated and never freed.)
121 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
122 (defvar *n-bytes-freed-or-purified* 0)
124 (setf *n-bytes-freed-or-purified* 0))
125 ;; KLUDGE: It's probably not quite safely right either to do
126 ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
127 ;; worse, something which depended on (GET-BYTES-CONSED), might
128 ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
129 ;; it's probably not a big problem, and there seems to be no
130 ;; other obvious time to do it. -- WHN 2001-07-30
131 *after-save-initializations*)
133 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
134 (defun get-bytes-consed ()
136 "Return the number of bytes consed since the program began. Typically
137 this result will be a consed bignum, so if you have an application (e.g.
138 profiling) which can't tolerate the overhead of consing bignums, you'll
139 probably want either to hack in at a lower level (as the code in the
140 SB-PROFILE package does), or to design a more microefficient interface
141 and submit it as a patch."
143 *n-bytes-freed-or-purified*))
147 (defvar *before-gc-hooks* nil ; actually initialized in cold init
149 "A list of functions that are called before garbage collection occurs.
150 The functions are run with interrupts disabled and all other threads
151 paused. They should take no arguments.")
153 (defvar *after-gc-hooks* nil ; actually initialized in cold init
155 "A list of functions that are called after garbage collection occurs.
156 The functions are run with interrupts disabled and all other threads
157 paused. They should take no arguments.")
159 ;;;; The following specials are used to control when garbage
160 ;;;; collection occurs.
162 ;;; When the dynamic usage increases beyond this amount, the system
163 ;;; notes that a garbage collection needs to occur by setting
164 ;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
165 ;;; nobody has figured out what it should be yet.
167 ;;; FIXME: *GC-TRIGGER* seems to be denominated in bytes, not words.
168 ;;; And limiting it to INDEX is fairly reasonable in order to avoid
169 ;;; bignum arithmetic on every allocation, and to minimize the need
170 ;;; for thought about weird gotchas of the GC-control mechanism itself
171 ;;; consing as it operates. But as of sbcl-0.7.5, 512Mbytes of memory
172 ;;; costs $54.95 at Fry's in Dallas but cheap consumer 64-bit machines
173 ;;; are still over the horizon, so gratuitously limiting our heap size
174 ;;; to FIXNUM bytes seems fairly stupid. It'd be reasonable to
175 ;;; (1) allow arbitrary UNSIGNED-BYTE values of *GC-TRIGGER*, or
176 ;;; (2) redenominate this variable in words instead of bytes, postponing
177 ;;; the problem to heaps which exceed 50% of the machine's address
179 ;;; (3) redemoninate this variable in CONS-sized two-word units,
180 ;;; allowing it to cover the entire memory space at the price of
181 ;;; possible loss of clarity.
182 ;;; (And whatever is done, it'd also be good to rename the variable so
183 ;;; that it's clear what unit it's denominated in.)
184 (declaim (type (or index null) *gc-trigger*))
185 (defvar *gc-trigger* nil)
187 ;;; When T, indicates that a GC should have happened but did not due to
189 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
193 (sb!alien:define-alien-routine collect-garbage sb!alien:int
194 (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
198 (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
199 (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
202 (defun gc-stop-the-world ())
203 (defun gc-start-the-world ()))
208 ;;; This is used to carefully invoke hooks.
209 (eval-when (:compile-toplevel :execute)
210 (sb!xc:defmacro carefully-funcall (function &rest args)
211 `(handler-case (funcall ,function ,@args)
213 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
216 ;;; SUB-GC does a garbage collection. This is called from three places:
217 ;;; (1) The C runtime will call here when it detects that we've consed
218 ;;; enough to exceed the gc trigger threshold. This is done in
219 ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc
220 ;;; (2) The user may request a collection using GC, below
221 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
222 ;;; *NEED-TO-COLLECT-GARBAGE* is true
224 ;;; This is different from the behaviour in 0.7 and earlier: it no
225 ;;; longer decides whether to GC based on thresholds. If you call
226 ;;; SUB-GC you will definitely get a GC either now or when the
227 ;;; WITHOUT-GCING is over
229 ;;; For GENCGC all generations < GEN will be GC'ed.
231 (defvar *already-in-gc*
232 (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
234 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
235 (let ((me (sb!thread:current-thread-id)))
236 (when (eql (sb!thread::mutex-value *already-in-gc*) me)
237 (return-from sub-gc nil))
238 (setf *need-to-collect-garbage* t)
239 (when (zerop *gc-inhibit*)
241 (sb!thread:with-mutex (*already-in-gc*)
242 (unless *need-to-collect-garbage* (return-from sub-gc nil))
245 (collect-garbage gen)
246 (incf *n-bytes-freed-or-purified*
247 (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
248 (scrub-control-stack)
249 (setf *need-to-collect-garbage* nil)
250 (dolist (h *after-gc-hooks*) (carefully-funcall h))
251 (gc-start-the-world))
252 (sb!thread::reap-dead-threads))))))
254 ;;; This is the user-advertised garbage collection function.
255 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
256 #!+(and sb-doc gencgc)
257 "Initiate a garbage collection. GEN controls the number of generations
259 #!+(and sb-doc (not gencgc))
260 "Initiate a garbage collection. GEN may be provided for compatibility with
261 generational garbage collectors, but is ignored in this implementation."
262 (sub-gc :gen (if full 6 gen)))
265 ;;;; auxiliary functions
267 (defun bytes-consed-between-gcs ()
269 "Return the amount of memory that will be allocated before the next garbage
270 collection is initiated. This can be set with SETF."
271 (sb!alien:extern-alien "bytes_consed_between_gcs"
272 (sb!alien:unsigned 32)))
274 (defun (setf bytes-consed-between-gcs) (val)
275 (declare (type index val))
276 (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
277 (sb!alien:unsigned 32))
282 "Enable the garbage collector."
283 (setq *gc-inhibit* 0)
284 (when *need-to-collect-garbage*
290 "Disable the garbage collector."
291 (setq *gc-inhibit* 1)