bc5c9200855aa77ac62a09a78b0034863aa2a400
[sbcl.git] / src / code / gc.lisp
1 ;;;; garbage collection and allocation-related code
2
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.
11
12 (in-package "SB!KERNEL")
13 \f
14 ;;;; DYNAMIC-USAGE and friends
15
16 #!-sb-fluid
17 (declaim (inline current-dynamic-space-start))
18 #!+gencgc
19 (defun current-dynamic-space-start () sb!vm:dynamic-space-start)
20 #!-gencgc
21 (defun current-dynamic-space-start ()
22   (sb!alien:extern-alien "current_dynamic_space" sb!alien:unsigned-long))
23
24 #!-sb-fluid
25 (declaim (inline dynamic-usage))
26 #!+gencgc
27 (defun dynamic-usage ()
28   (sb!alien:extern-alien "bytes_allocated" sb!alien:unsigned-long))
29 #!-gencgc
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))))
34
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))
38
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))
42
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))))
50
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*))))
54 \f
55 ;;;; ROOM
56
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))
63   #!+sb-thread
64   (format t
65           "Control and binding stack usage is for the current thread only.~%")
66   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
67           *gc-inhibit*))
68
69 (defun room-intermediate-info ()
70   (room-minimal-info)
71   (sb!vm:memory-usage :count-spaces '(:dynamic)
72                       :print-spaces t
73                       :cutoff 0.05f0
74                       :print-summary nil))
75
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)
84   )
85
86 (defun room (&optional (verbosity :default))
87   #!+sb-doc
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."
94   (fresh-line)
95   (ecase verbosity
96     ((t)
97      (room-maximal-info))
98     ((nil)
99      (room-minimal-info))
100     (:default
101      (room-intermediate-info)))
102   (values))
103 \f
104 ;;;; GET-BYTES-CONSED
105
106 ;;; the total number of bytes freed so far (including any freeing
107 ;;; which goes on in PURIFY)
108 ;;;
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)
114 (defun gc-reinit ()
115   (setq *gc-inhibit* nil)
116   (gc)
117   (setf *n-bytes-freed-or-purified* 0
118         *gc-run-time* 0
119         ;; See comment in interr.lisp
120         *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error)))
121
122 (declaim (ftype (sfunction () unsigned-byte) get-bytes-consed))
123 (defun get-bytes-consed ()
124   #!+sb-doc
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."
131   (+ (dynamic-usage)
132      *n-bytes-freed-or-purified*))
133 \f
134 ;;;; GC hooks
135
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
139 run in any thread.")
140
141 \f
142 ;;;; internal GC
143
144 (sb!alien:define-alien-routine collect-garbage sb!alien:int
145   (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
146
147 #!+sb-thread
148 (progn
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))
151 #!-sb-thread
152 (progn
153   (defun gc-stop-the-world ())
154   (defun gc-start-the-world ()))
155
156 #!+gencgc
157 (progn
158   (sb!alien:define-alien-variable ("gc_logfile" %gc-logfile) (* char))
159   (defun (setf gc-logfile) (pathname)
160     "Use PATHNAME to log garbage collections. If non-null, the
161 designated file is opened before and after each collection, and
162 generation statistics are appended to it. To stop writing the log, use
163 NIL as the pathname."
164     (let ((new (when pathname
165                  (sb!alien:make-alien-string
166                   (native-namestring (translate-logical-pathname pathname)
167                                      :as-file t))))
168           (old %gc-logfile))
169       (setf %gc-logfile new)
170       (when old
171         (sb!alien:free-alien old))))
172   (defun gc-logfile ()
173     "Return the name of the current GC logfile."
174     (let ((val %gc-logfile))
175       (when val
176         (native-pathname (cast val c-string)))))
177   (declaim (inline dynamic-space-size))
178   (defun dynamic-space-size ()
179     (sb!alien:extern-alien "dynamic_space_size" sb!alien:unsigned-long)))
180 \f
181 ;;;; SUB-GC
182
183 ;;; SUB-GC does a garbage collection.  This is called from three places:
184 ;;; (1) The C runtime will call here when it detects that we've consed
185 ;;;     enough to exceed the gc trigger threshold.  This is done in
186 ;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
187 ;;; (2) The user may request a collection using GC, below
188 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
189 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
190 ;;;
191 ;;; This is different from the behaviour in 0.7 and earlier: it no
192 ;;; longer decides whether to GC based on thresholds.  If you call
193 ;;; SUB-GC you will definitely get a GC either now or when the
194 ;;; WITHOUT-GCING is over
195
196 ;;; For GENCGC all generations < GEN will be GC'ed.
197
198 (defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock"))
199
200 ;;; A unique GC id. This is supplied for code that needs to detect
201 ;;; whether a GC has happened since some earlier point in time. For
202 ;;; example:
203 ;;;
204 ;;;   (let ((epoch *gc-epoch*))
205 ;;;      ...
206 ;;;      (unless (eql epoch *gc-epoch)
207 ;;;        ....))
208 ;;;
209 ;;; This isn't just a fixnum counter since then we'd have theoretical
210 ;;; problems when exactly 2^29 GCs happen between epoch
211 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
212 ;;; small to measure. -- JES, 2007-09-30
213 (declaim (type cons *gc-epoch*))
214 (defvar *gc-epoch* (cons nil nil))
215
216 (defun sub-gc (&key (gen 0))
217   (cond (*gc-inhibit*
218          (setf *gc-pending* t)
219          nil)
220         (t
221          (without-interrupts
222            (setf *gc-pending* :in-progress)
223            ;; Tricks to to prevent triggerring a recursive gc. This is
224            ;; like a WITHOUT-GCING inside the lock except that we
225            ;; cannot call MAYBE-HANDLE-PENDING-GC at the end, because
226            ;; that would lead to a recursive attempt on the lock. In
227            ;; case you are wondering, wrapping the lock in a
228            ;; WITHOUT-GCING would also deadlock. The
229            ;; *IN-WITHOUT-GCING* part is used to tell the runtime that
230            ;; it's ok to have a pending gc even though *GC-INHIBIT* is
231            ;; NIL.
232            ;;
233            ;; Now, if GET-MUTEX did not cons, that would be enough.
234            ;; Because it does, we need the :IN-PROGRESS bit above to
235            ;; tell the runtime not to trigger gcs.
236            (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
237              (let* ((sb!impl::*in-without-gcing* t)
238                     (sb!impl::*deadline* nil)
239                     (sb!impl::*deadline-seconds* nil))
240                (sb!thread:with-mutex (*already-in-gc*)
241                  (let ((*gc-inhibit* t))
242                    (let ((old-usage (dynamic-usage))
243                          (new-usage 0))
244                      (unsafe-clear-roots gen)
245                      (gc-stop-the-world)
246                      (let ((start-time (get-internal-run-time)))
247                        (collect-garbage gen)
248                        (setf *gc-epoch* (cons nil nil))
249                        (let ((run-time (- (get-internal-run-time) start-time)))
250                          ;; KLUDGE: Sometimes we see the second getrusage() call
251                          ;; return a smaller value than the first, which can
252                          ;; lead to *GC-RUN-TIME* to going negative, which in
253                          ;; turn is a type-error.
254                          (when (plusp run-time)
255                            (incf *gc-run-time* run-time))))
256                      (setf *gc-pending* nil
257                            new-usage (dynamic-usage))
258                      #!+sb-thread
259                      (assert (not *stop-for-gc-pending*))
260                      (gc-start-the-world)
261                      ;; In a multithreaded environment the other threads
262                      ;; will see *n-b-f-o-p* change a little late, but
263                      ;; that's OK.
264                      (let ((freed (- old-usage new-usage)))
265                        ;; GENCGC occasionally reports negative here, but
266                        ;; the current belief is that it is part of the
267                        ;; normal order of things and not a bug.
268                        (when (plusp freed)
269                          (incf *n-bytes-freed-or-purified* freed))))))))
270            ;; While holding the mutex we were protected from
271            ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to
272            ;; preserve the invariant (*GC-PENDING* ->
273            ;; pseudo-atomic-interrupted or *GC-INHIBIT*), let's check
274            ;; explicitly for a pending gc before interrupts are
275            ;; enabled again.
276            (maybe-handle-pending-gc))
277          t)))
278
279 (defun post-gc ()
280   ;; Outside the mutex, interrupts may be enabled: these may cause
281   ;; another GC. FIXME: it can potentially exceed maximum interrupt
282   ;; nesting by triggering GCs.
283   ;;
284   ;; Can that be avoided by having the finalizers and hooks run only
285   ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
286   ;; handlers that's not enough.
287   ;;
288   ;; KLUDGE: Don't run the hooks in GC's if:
289   ;;
290   ;; A) this thread is dying, so that user-code never runs with
291   ;;    (thread-alive-p *current-thread*) => nil
292   ;;
293   ;; B) interrupts are disabled somewhere up the call chain since we
294   ;;    don't want to run user code in such a case.
295   ;;
296   ;; The long-term solution will be to keep a separate thread for
297   ;; finalizers and after-gc hooks.
298   (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
299     (when *allow-with-interrupts*
300       (sb!thread::without-thread-waiting-for ()
301         (with-interrupts
302           (run-pending-finalizers)
303           (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))
304
305 ;;; This is the user-advertised garbage collection function.
306 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
307   #!+(and sb-doc gencgc)
308   "Initiate a garbage collection. GEN controls the number of generations
309   to garbage collect."
310   #!+(and sb-doc (not gencgc))
311   "Initiate a garbage collection. GEN may be provided for compatibility with
312   generational garbage collectors, but is ignored in this implementation."
313   (when (sub-gc :gen (if full 6 gen))
314     (post-gc)))
315
316 (define-alien-routine scrub-control-stack sb!alien:void)
317
318 (defun unsafe-clear-roots (gen)
319   #!-gencgc (declare (ignore gen))
320   ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
321   ;; as having these cons more then we have space left leads to huge
322   ;; badness.
323   (scrub-control-stack)
324   ;; Power cache of the bignum printer: drops overly large bignums and
325   ;; removes duplicate entries.
326   (scrub-power-cache)
327   ;; Clear caches depending on the generation being collected.
328   #!+gencgc
329   (cond ((eql 0 gen))
330         ((eql 1 gen)
331          (ctype-of-cache-clear))
332         (t
333          (drop-all-hash-caches)))
334   #!-gencgc
335   (drop-all-hash-caches))
336 \f
337 ;;;; auxiliary functions
338
339 (defun bytes-consed-between-gcs ()
340   #!+sb-doc
341   "The amount of memory that will be allocated before the next garbage
342 collection is initiated. This can be set with SETF."
343   (sb!alien:extern-alien "bytes_consed_between_gcs"
344                          (sb!alien:unsigned 32)))
345
346 (defun (setf bytes-consed-between-gcs) (val)
347   (declare (type index val))
348   (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
349                                (sb!alien:unsigned 32))
350         val))
351
352 (declaim (inline maybe-handle-pending-gc))
353 (defun maybe-handle-pending-gc ()
354   (when (and (not *gc-inhibit*)
355              (or #!+sb-thread *stop-for-gc-pending*
356                  *gc-pending*))
357     (sb!unix::receive-pending-interrupt)))
358
359 ;;;; GENCGC specifics
360 ;;;;
361 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
362 ;;;; as well.
363 #!+gencgc
364 (deftype generation-index ()
365   '(integer 0 #.sb!vm:+pseudo-static-generation+))
366
367 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
368 ;;; defined in Lisp, and written to header files by genesis, instead of this
369 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
370 #!+gencgc
371 (define-alien-type generation
372     (struct generation
373             (alloc-start-page page-index-t)
374             (alloc-unboxed-start-page page-index-t)
375             (alloc-large-start-page page-index-t)
376             (alloc-large-unboxed-start-page page-index-t)
377             (bytes-allocated unsigned-long)
378             (gc-trigger unsigned-long)
379             (bytes-consed-between-gcs unsigned-long)
380             (number-of-gcs int)
381             (number-of-gcs-before-promotion int)
382             (cum-sum-bytes-allocated unsigned-long)
383             (minimum-age-before-gc double)))
384
385 #!+gencgc
386 (define-alien-variable generations
387     (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
388
389 (macrolet ((def (slot doc &optional setfp)
390              (declare (ignorable doc))
391              `(progn
392                 (defun ,(symbolicate "GENERATION-" slot) (generation)
393                   #!+sb-doc
394                   ,doc
395                   #!+gencgc
396                   (declare (generation-index generation))
397                   #!-gencgc
398                   (declare (ignore generation))
399                   #!-gencgc
400                   (error "~S is a GENCGC only function and unavailable in this build"
401                          ',slot)
402                   #!+gencgc
403                   (slot (deref generations generation) ',slot))
404                 ,@(when setfp
405                         `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
406                             #!+gencgc
407                             (declare (generation-index generation))
408                             #!-gencgc
409                             (declare (ignore value generation))
410                             #!-gencgc
411                             (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
412                                    ',slot)
413                             #!+gencgc
414                             (setf (slot (deref generations generation) ',slot) value)))))))
415   (def bytes-consed-between-gcs
416       "Number of bytes that can be allocated to GENERATION before that
417 generation is considered for garbage collection. This value is meaningless for
418 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
419 20Mb. Can be assigned to using SETF. Available on GENCGC platforms only.
420
421 Experimental: interface subject to change."
422     t)
423   (def minimum-age-before-gc
424       "Minimum average age of objects allocated to GENERATION before that
425 generation is may be garbage collected. Default is 0.75. See also
426 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
427 platforms only.
428
429 Experimental: interface subject to change."
430     t)
431   (def number-of-gcs-before-promotion
432       "Number of times garbage collection is done on GENERATION before
433 automatic promotion to the next generation is triggered. Can be assigned to
434 using SETF. Available on GENCGC platforms only.
435
436 Experimental: interface subject to change."
437     t)
438   (def bytes-allocated
439       "Number of bytes allocated to GENERATION currently. Available on GENCGC
440 platforms only.
441
442 Experimental: interface subject to change.")
443   (def number-of-gcs
444       "Number of times garbage collection has been done on GENERATION without
445 promotion. Available on GENCGC platforms only.
446
447 Experimental: interface subject to change."))
448   (defun generation-average-age (generation)
449     "Average age of memory allocated to GENERATION: average number of times
450 objects allocated to the generation have seen younger objects promoted to it.
451 Available on GENCGC platforms only.
452
453 Experimental: interface subject to change."
454     #!+gencgc
455     (declare (generation-index generation))
456     #!-gencgc (declare (ignore generation))
457     #!-gencgc
458     (error "~S is a GENCGC only function and unavailable in this build."
459            'generation-average-age)
460     #!+gencgc
461     (alien-funcall (extern-alien "generation_average_age"
462                                  (function double generation-index-t))
463                    generation))