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))