1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / src / code / gc.lisp
blobeb7f13dc644382a0daebeb596ee8b1a0d4e48f68
1 ;;;; garbage collection and allocation-related code
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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 (eval-when (:compile-toplevel :execute)
17 (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name)
18 `(defun ,lisp-fun ()
19 (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32)))))
21 #!-sb-fluid
22 (declaim (inline current-dynamic-space-start))
23 #!+gencgc
24 (defun current-dynamic-space-start () sb!vm:dynamic-space-start)
25 #!-gencgc
26 (def-c-var-fun current-dynamic-space-start "current_dynamic_space")
28 #!-sb-fluid
29 (declaim (inline dynamic-usage))
30 #!+gencgc
31 (def-c-var-fun dynamic-usage "bytes_allocated")
32 #!-gencgc
33 (defun dynamic-usage ()
34 (the (unsigned-byte 32)
35 (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
36 (current-dynamic-space-start))))
38 (defun static-space-usage ()
39 (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)
40 sb!vm:static-space-start))
42 (defun read-only-space-usage ()
43 (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes)
44 sb!vm:read-only-space-start))
46 (defun control-stack-usage ()
47 #!-stack-grows-downward-not-upward
48 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
49 (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*)))
50 #!+stack-grows-downward-not-upward
51 (- (sb!sys:sap-int (sb!di::descriptor-sap 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!sys:sap-int (sb!di::descriptor-sap sb!vm:*binding-stack-start*))))
58 ;;;; ROOM
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 #!+sb-thread
67 (format t
68 "Control and binding stack usage is for the current thread only.~%")
69 (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
70 *gc-inhibit*))
72 (defun room-intermediate-info ()
73 (room-minimal-info)
74 (sb!vm:memory-usage :count-spaces '(:dynamic)
75 :print-spaces t
76 :cutoff 0.05f0
77 :print-summary nil))
79 (defun room-maximal-info ()
80 ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
81 (room-intermediate-info)
82 ;; old way, could be restored when bug 344 fixed:
83 ;;x (room-minimal-info)
84 ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
85 ;;x (sb!vm:instance-usage :dynamic :top-n 10)
86 ;;x (sb!vm:instance-usage :static :top-n 10)
89 (defun room (&optional (verbosity :default))
90 #!+sb-doc
91 "Print to *STANDARD-OUTPUT* information about the state of internal
92 storage and its management. The optional argument controls the
93 verbosity of output. If it is T, ROOM prints out a maximal amount of
94 information. If it is NIL, ROOM prints out a minimal amount of
95 information. If it is :DEFAULT or it is not supplied, ROOM prints out
96 an intermediate amount of information."
97 (fresh-line)
98 (ecase verbosity
99 ((t)
100 (room-maximal-info))
101 ((nil)
102 (room-minimal-info))
103 (:default
104 (room-intermediate-info)))
105 (values))
107 ;;;; GET-BYTES-CONSED
109 ;;; the total number of bytes freed so far (including any freeing
110 ;;; which goes on in PURIFY)
112 ;;; (We save this so that we can calculate the total number of bytes
113 ;;; ever allocated by adding this to the number of bytes currently
114 ;;; allocated and never freed.)
115 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
116 (defvar *n-bytes-freed-or-purified* 0)
117 (defun gc-reinit ()
118 (setq *gc-inhibit* nil)
119 (gc)
120 (setf *n-bytes-freed-or-purified* 0
121 *gc-run-time* 0
122 ;; See comment in interr.lisp
123 *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error)))
125 (declaim (ftype (sfunction () unsigned-byte) get-bytes-consed))
126 (defun get-bytes-consed ()
127 #!+sb-doc
128 "Return the number of bytes consed since the program began. Typically
129 this result will be a consed bignum, so if you have an application (e.g.
130 profiling) which can't tolerate the overhead of consing bignums, you'll
131 probably want either to hack in at a lower level (as the code in the
132 SB-PROFILE package does), or to design a more microefficient interface
133 and submit it as a patch."
134 (+ (dynamic-usage)
135 *n-bytes-freed-or-purified*))
137 ;;;; GC hooks
139 (defvar *after-gc-hooks* nil
140 "Called after each garbage collection, except for garbage collections
141 triggered during thread exits. In a multithreaded environment these hooks may
142 run in any thread.")
145 ;;;; internal GC
147 (sb!alien:define-alien-routine collect-garbage sb!alien:int
148 (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
150 #!+sb-thread
151 (progn
152 (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
153 (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
154 #!-sb-thread
155 (progn
156 (defun gc-stop-the-world ())
157 (defun gc-start-the-world ()))
160 ;;;; SUB-GC
162 ;;; SUB-GC does a garbage collection. This is called from three places:
163 ;;; (1) The C runtime will call here when it detects that we've consed
164 ;;; enough to exceed the gc trigger threshold. This is done in
165 ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc
166 ;;; (2) The user may request a collection using GC, below
167 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
168 ;;; *NEED-TO-COLLECT-GARBAGE* is true
170 ;;; This is different from the behaviour in 0.7 and earlier: it no
171 ;;; longer decides whether to GC based on thresholds. If you call
172 ;;; SUB-GC you will definitely get a GC either now or when the
173 ;;; WITHOUT-GCING is over
175 ;;; For GENCGC all generations < GEN will be GC'ed.
177 (defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock"))
179 ;;; A unique GC id. This is supplied for code that needs to detect
180 ;;; whether a GC has happened since some earlier point in time. For
181 ;;; example:
183 ;;; (let ((epoch *gc-epoch*))
184 ;;; ...
185 ;;; (unless (eql epoch *gc-epoch)
186 ;;; ....))
188 ;;; This isn't just a fixnum counter since then we'd have theoretical
189 ;;; problems when exactly 2^29 GCs happen between epoch
190 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
191 ;;; small to measure. -- JES, 2007-09-30
192 (declaim (type cons *gc-epoch*))
193 (defvar *gc-epoch* (cons nil nil))
195 (defun sub-gc (&key (gen 0))
196 (cond (*gc-inhibit*
197 (setf *gc-pending* t)
198 nil)
200 (without-interrupts
201 (setf *gc-pending* :in-progress)
202 ;; Tricks to to prevent triggerring a recursive gc. This is
203 ;; like a WITHOUT-GCING inside the lock except that we
204 ;; cannot call MAYBE-HANDLE-PENDING-GC at the end, because
205 ;; that would lead to a recursive attempt on the lock. In
206 ;; case you are wondering, wrapping the lock in a
207 ;; WITHOUT-GCING would also deadlock. The
208 ;; *IN-WITHOUT-GCING* part is used to tell the runtime that
209 ;; it's ok to have a pending gc even though *GC-INHIBIT* is
210 ;; NIL.
212 ;; Now, if GET-MUTEX did not cons, that would be enough.
213 ;; Because it does, we need the :IN-PROGRESS bit above to
214 ;; tell the runtime not to trigger gcs.
215 (let ((sb!impl::*in-without-gcing* t)
216 (sb!impl::*deadline* nil)
217 (sb!impl::*deadline-seconds* nil))
218 (sb!thread:with-mutex (*already-in-gc*)
219 (let ((*gc-inhibit* t))
220 (let ((old-usage (dynamic-usage))
221 (new-usage 0))
222 (unsafe-clear-roots)
223 (gc-stop-the-world)
224 (let ((start-time (get-internal-run-time)))
225 (collect-garbage gen)
226 (setf *gc-epoch* (cons nil nil))
227 (incf *gc-run-time*
228 (- (get-internal-run-time) start-time)))
229 (setf *gc-pending* nil
230 new-usage (dynamic-usage))
231 #!+sb-thread
232 (assert (not *stop-for-gc-pending*))
233 (gc-start-the-world)
234 ;; In a multithreaded environment the other threads
235 ;; will see *n-b-f-o-p* change a little late, but
236 ;; that's OK.
237 (let ((freed (- old-usage new-usage)))
238 ;; GENCGC occasionally reports negative here, but
239 ;; the current belief is that it is part of the
240 ;; normal order of things and not a bug.
241 (when (plusp freed)
242 (incf *n-bytes-freed-or-purified* freed)))))))
243 ;; While holding the mutex we were protected from
244 ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to
245 ;; preserve the invariant (*GC-PENDING* ->
246 ;; pseudo-atomic-interrupted or *GC-INHIBIT*), let's check
247 ;; explicitly for a pending gc before interrupts are
248 ;; enabled again.
249 (maybe-handle-pending-gc))
250 t)))
252 (defun post-gc ()
253 ;; Outside the mutex, interrupts may be enabled: these may cause
254 ;; another GC. FIXME: it can potentially exceed maximum interrupt
255 ;; nesting by triggering GCs.
257 ;; Can that be avoided by having the finalizers and hooks run only
258 ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
259 ;; handlers that's not enough.
261 ;; KLUDGE: Don't run the hooks in GC's if:
263 ;; A) this thread is dying, so that user-code never runs with
264 ;; (thread-alive-p *current-thread*) => nil
266 ;; B) interrupts are disabled somewhere up the call chain since we
267 ;; don't want to run user code in such a case.
269 ;; The long-term solution will be to keep a separate thread for
270 ;; finalizers and after-gc hooks.
271 (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
272 (when *allow-with-interrupts*
273 (with-interrupts
274 (run-pending-finalizers)
275 (call-hooks "after-GC" *after-gc-hooks* :on-error :warn)))))
277 ;;; This is the user-advertised garbage collection function.
278 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
279 #!+(and sb-doc gencgc)
280 "Initiate a garbage collection. GEN controls the number of generations
281 to garbage collect."
282 #!+(and sb-doc (not gencgc))
283 "Initiate a garbage collection. GEN may be provided for compatibility with
284 generational garbage collectors, but is ignored in this implementation."
285 (when (sub-gc :gen (if full 6 gen))
286 (post-gc)))
288 (define-alien-routine scrub-control-stack sb!alien:void)
290 (defun unsafe-clear-roots ()
291 ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
292 ;; as having these cons more then we have space left leads to huge
293 ;; badness.
294 (scrub-control-stack)
295 ;; Power cache of the bignum printer: drops overly large bignums and
296 ;; removes duplicate entries.
297 (scrub-power-cache)
298 ;; FIXME: CTYPE-OF-CACHE-CLEAR isn't thread-safe.
299 #!-sb-thread
300 (ctype-of-cache-clear))
303 ;;;; auxiliary functions
305 (defun bytes-consed-between-gcs ()
306 #!+sb-doc
307 "The amount of memory that will be allocated before the next garbage
308 collection is initiated. This can be set with SETF."
309 (sb!alien:extern-alien "bytes_consed_between_gcs"
310 (sb!alien:unsigned 32)))
312 (defun (setf bytes-consed-between-gcs) (val)
313 (declare (type index val))
314 (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
315 (sb!alien:unsigned 32))
316 val))
318 (declaim (inline maybe-handle-pending-gc))
319 (defun maybe-handle-pending-gc ()
320 (when (and (not *gc-inhibit*)
321 (or #!+sb-thread *stop-for-gc-pending*
322 *gc-pending*))
323 (sb!unix::receive-pending-interrupt)))
325 ;;;; GENCGC specifics
326 ;;;;
327 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
328 ;;;; as well.
329 #!+gencgc
330 (deftype generation-index ()
331 '(integer 0 #.sb!vm:+pseudo-static-generation+))
333 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
334 ;;; defined in Lisp, and written to header files by genesis, instead of this
335 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
336 #!+gencgc
337 (define-alien-type generation
338 (struct generation
339 (alloc-start-page page-index-t)
340 (alloc-unboxed-start-page page-index-t)
341 (alloc-large-start-page page-index-t)
342 (alloc-large-unboxed-start-page page-index-t)
343 (bytes-allocated unsigned-long)
344 (gc-trigger unsigned-long)
345 (bytes-consed-between-gcs unsigned-long)
346 (number-of-gcs int)
347 (number-of-gcs-before-promotion int)
348 (cum-sum-bytes-allocated unsigned-long)
349 (minimum-age-before-gc double)
350 ;; `struct lutex *' or `void *', depending.
351 (lutexes (* char))))
353 #!+gencgc
354 (define-alien-variable generations
355 (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
357 (macrolet ((def (slot doc &optional setfp)
358 (declare (ignorable doc))
359 `(progn
360 (defun ,(symbolicate "GENERATION-" slot) (generation)
361 #!+sb-doc
362 ,doc
363 #!+gencgc
364 (declare (generation-index generation))
365 #!-gencgc
366 (declare (ignore generation))
367 #!-gencgc
368 (error "~S is a GENCGC only function and unavailable in this build"
369 ',slot)
370 #!+gencgc
371 (slot (deref generations generation) ',slot))
372 ,@(when setfp
373 `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
374 #!+gencgc
375 (declare (generation-index generation))
376 #!-gencgc
377 (declare (ignore value generation))
378 #!-gencgc
379 (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
380 ',slot)
381 #!+gencgc
382 (setf (slot (deref generations generation) ',slot) value)))))))
383 (def bytes-consed-between-gcs
384 "Number of bytes that can be allocated to GENERATION before that
385 generation is considered for garbage collection. This value is meaningless for
386 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
387 20Mb. Can be assigned to using SETF. Available on GENCGC platforms only.
389 Experimental: interface subject to change."
391 (def minimum-age-before-gc
392 "Minimum average age of objects allocated to GENERATION before that
393 generation is may be garbage collected. Default is 0.75. See also
394 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
395 platforms only.
397 Experimental: interface subject to change."
399 (def number-of-gcs-before-promotion
400 "Number of times garbage collection is done on GENERATION before
401 automatic promotion to the next generation is triggered. Can be assigned to
402 using SETF. Available on GENCGC platforms only.
404 Experimental: interface subject to change."
406 (def bytes-allocated
407 "Number of bytes allocated to GENERATION currently. Available on GENCGC
408 platforms only.
410 Experimental: interface subject to change.")
411 (def number-of-gcs
412 "Number of times garbage collection has been done on GENERATION without
413 promotion. Available on GENCGC platforms only.
415 Experimental: interface subject to change."))
416 (defun generation-average-age (generation)
417 "Average age of memory allocated to GENERATION: average number of times
418 objects allocated to the generation have seen younger objects promoted to it.
419 Available on GENCGC platforms only.
421 Experimental: interface subject to change."
422 #!+gencgc
423 (declare (generation-index generation))
424 #!-gencgc (declare (ignore generation))
425 #!-gencgc
426 (error "~S is a GENCGC only function and unavailable in this build."
427 'generation-average-age)
428 #!+gencgc
429 (alien-funcall (extern-alien "generation_average_age"
430 (function double generation-index-t))
431 generation))