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" os-vm-size-t))
  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     (let ((new (when pathname
 161                  (sb!alien:make-alien-string
 162                   (native-namestring (translate-logical-pathname pathname)
 163                                      :as-file t))))
 164           (old %gc-logfile))
 165       (setf %gc-logfile new)
 166       (when old
 167         (sb!alien:free-alien old))
 168       pathname))
 169   (defun gc-logfile ()
 170     #!+sb-doc
 171     "Return the pathname used to log garbage collections. Can be SETF.
 172 Default is NIL, meaning collections are not logged. If non-null, the
 173 designated file is opened before and after each collection, and generation
 174 statistics are appended to it."
 175     (let ((val (cast %gc-logfile c-string)))
 176       (when val
 177         (native-pathname val))))
 178   (declaim (inline dynamic-space-size))
 179   (defun dynamic-space-size ()
 180     "Size of the dynamic space in bytes."
 181     (sb!alien:extern-alien "dynamic_space_size" os-vm-size-t)))
 182 \f
 183 ;;;; SUB-GC
 184
 185 ;;; SUB-GC does a garbage collection.  This is called from three places:
 186 ;;; (1) The C runtime will call here when it detects that we've consed
 187 ;;;     enough to exceed the gc trigger threshold.  This is done in
 188 ;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
 189 ;;; (2) The user may request a collection using GC, below
 190 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
 191 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
 192 ;;;
 193 ;;; This is different from the behaviour in 0.7 and earlier: it no
 194 ;;; longer decides whether to GC based on thresholds.  If you call
 195 ;;; SUB-GC you will definitely get a GC either now or when the
 196 ;;; WITHOUT-GCING is over
 197
 198 ;;; For GENCGC all generations < GEN will be GC'ed.
 199
 200 (defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock"))
 201
 202 ;;; A unique GC id. This is supplied for code that needs to detect
 203 ;;; whether a GC has happened since some earlier point in time. For
 204 ;;; example:
 205 ;;;
 206 ;;;   (let ((epoch *gc-epoch*))
 207 ;;;      ...
 208 ;;;      (unless (eql epoch *gc-epoch)
 209 ;;;        ....))
 210 ;;;
 211 ;;; This isn't just a fixnum counter since then we'd have theoretical
 212 ;;; problems when exactly 2^29 GCs happen between epoch
 213 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
 214 ;;; small to measure. -- JES, 2007-09-30
 215 (declaim (type cons *gc-epoch*))
 216 (defvar *gc-epoch* (cons nil nil))
 217
 218 (defun sub-gc (&key (gen 0))
 219   (cond (*gc-inhibit*
 220          (setf *gc-pending* t)
 221          nil)
 222         (t
 223          (flet ((perform-gc ()
 224                   ;; Called from WITHOUT-GCING and WITHOUT-INTERRUPTS
 225                   ;; after the world has been stopped, but it's an
 226                   ;; awkwardly long piece of code to nest so deeply.
 227                   (let ((old-usage (dynamic-usage))
 228                         (new-usage 0)
 229                         (start-time (get-internal-run-time)))
 230                     (collect-garbage gen)
 231                     (setf *gc-epoch* (cons nil nil))
 232                     (let ((run-time (- (get-internal-run-time) start-time)))
 233                       ;; KLUDGE: Sometimes we see the second getrusage() call
 234                       ;; return a smaller value than the first, which can
 235                       ;; lead to *GC-RUN-TIME* to going negative, which in
 236                       ;; turn is a type-error.
 237                       (when (plusp run-time)
 238                         (incf *gc-run-time* run-time)))
 239                     #!+sb-safepoint
 240                     (setf *stop-for-gc-pending* nil)
 241                     (setf *gc-pending* nil
 242                           new-usage (dynamic-usage))
 243                     #!+sb-thread
 244                     (assert (not *stop-for-gc-pending*))
 245                     (gc-start-the-world)
 246                     ;; In a multithreaded environment the other threads
 247                     ;; will see *n-b-f-o-p* change a little late, but
 248                     ;; that's OK.
 249                     ;; N.B. the outer without-gcing prevents this
 250                     ;; function from being entered, so no need for
 251                     ;; locking.
 252                     (let ((freed (- old-usage new-usage)))
 253                       ;; GENCGC occasionally reports negative here, but
 254                       ;; the current belief is that it is part of the
 255                       ;; normal order of things and not a bug.
 256                       (when (plusp freed)
 257                         (incf *n-bytes-freed-or-purified* freed))))))
 258            (declare (inline perform-gc))
 259            ;; Let's make sure we're not interrupted and that none of
 260            ;; the deadline or deadlock detection stuff triggers.
 261            (without-interrupts
 262              (sb!thread::without-thread-waiting-for
 263                  (:already-without-interrupts t)
 264                (let ((sb!impl::*deadline* nil)
 265                      (sb!impl::*deadline-seconds* nil)
 266                      (epoch *gc-epoch*))
 267                  (loop
 268                   ;; GCing must be done without-gcing to avoid
 269                   ;; recursive GC... but we can't block on
 270                   ;; *already-in-gc* inside without-gcing: that would
 271                   ;; cause a deadlock.
 272                   (without-gcing
 273                     ;; Try to grab that mutex.  On acquisition, stop
 274                     ;; the world from with the mutex held, and then
 275                     ;; execute the remainder of the GC: stopping the
 276                     ;; world with interrupts disabled is the mother of
 277                     ;; all critical sections.
 278                     (cond ((sb!thread:with-mutex (*already-in-gc* :wait-p nil)
 279                              (unsafe-clear-roots gen)
 280                              (gc-stop-the-world)
 281                              t)
 282                            ;; Success! GC.
 283                            (perform-gc)
 284                            ;; Return, but leave *gc-pending* as is: we
 285                            ;; did allocate a tiny bit after GCing.  In
 286                            ;; theory, this could lead to a long chain
 287                            ;; of tail-recursive (but not in explicit
 288                            ;; tail position) GCs, but that doesn't
 289                            ;; seem likely to happen too often... And
 290                            ;; the old code already suffered from this
 291                            ;; problem.
 292                            (return t))
 293                           (t
 294                            ;; Some other thread is trying to GC. Clear
 295                            ;; *gc-pending* (we already know we want a
 296                            ;; GC to happen) and either let
 297                            ;; without-gcing figure out that the world
 298                            ;; is stopping, or try again.
 299                            (setf *gc-pending* nil))))
 300                   ;; we just wanted a minor GC, and a GC has
 301                   ;; occurred. Leave, but don't execute after-gc
 302                   ;; hooks.
 303                   ;;
 304                   ;; Return a 0 for easy ternary logic in the C
 305                   ;; runtime.
 306                   (when (and (eql gen 0)
 307                              (neq epoch *gc-pending*))
 308                     (return 0))))))))))
 309
 310 (defun post-gc ()
 311   ;; Outside the mutex, interrupts may be enabled: these may cause
 312   ;; another GC. FIXME: it can potentially exceed maximum interrupt
 313   ;; nesting by triggering GCs.
 314   ;;
 315   ;; Can that be avoided by having the finalizers and hooks run only
 316   ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
 317   ;; handlers that's not enough.
 318   ;;
 319   ;; KLUDGE: Don't run the hooks in GC's if:
 320   ;;
 321   ;; A) this thread is dying, so that user-code never runs with
 322   ;;    (thread-alive-p *current-thread*) => nil
 323   ;;
 324   ;; B) interrupts are disabled somewhere up the call chain since we
 325   ;;    don't want to run user code in such a case.
 326   ;;
 327   ;; The long-term solution will be to keep a separate thread for
 328   ;; finalizers and after-gc hooks.
 329   (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
 330     (when *allow-with-interrupts*
 331       (sb!thread::without-thread-waiting-for ()
 332         (with-interrupts
 333           (run-pending-finalizers)
 334           (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))
 335
 336 ;;; This is the user-advertised garbage collection function.
 337 (defun gc (&key (full nil) (gen 0) &allow-other-keys)
 338   #!+(and sb-doc gencgc)
 339   "Initiate a garbage collection.
 340
 341 The default is to initiate a nursery collection, which may in turn
 342 trigger a collection of one or more older generations as well. If FULL
 343 is true, all generations are collected. If GEN is provided, it can be
 344 used to specify the oldest generation guaranteed to be collected.
 345
 346 On CheneyGC platforms arguments FULL and GEN take no effect: a full
 347 collection is always preformed."
 348   #!+(and sb-doc (not gencgc))
 349   "Initiate a garbage collection.
 350
 351 The collection is always a full collection.
 352
 353 Arguments FULL and GEN can be used for compatibility with GENCGC
 354 platforms: there the default is to initiate a nursery collection,
 355 which may in turn trigger a collection of one or more older
 356 generations as well. If FULL is true, all generations are collected.
 357 If GEN is provided, it can be used to specify the oldest generation
 358 guaranteed to be collected."
 359   (when (eq t (sub-gc :gen (if full sb!vm:+pseudo-static-generation+ gen)))
 360     (post-gc)))
 361
 362 (define-alien-routine scrub-control-stack sb!alien:void)
 363
 364 (defun unsafe-clear-roots (gen)
 365   #!-gencgc (declare (ignore gen))
 366   ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
 367   ;; as having these cons more then we have space left leads to huge
 368   ;; badness.
 369   (scrub-control-stack)
 370   ;; Power cache of the bignum printer: drops overly large bignums and
 371   ;; removes duplicate entries.
 372   (scrub-power-cache)
 373   ;; Clear caches depending on the generation being collected.
 374   #!+gencgc
 375   (cond ((eql 0 gen))
 376         ((eql 1 gen)
 377          (ctype-of-cache-clear))
 378         (t
 379          (drop-all-hash-caches)))
 380   #!-gencgc
 381   (drop-all-hash-caches))
 382 \f
 383 ;;;; auxiliary functions
 384
 385 (defun bytes-consed-between-gcs ()
 386   #!+sb-doc
 387   "The amount of memory that will be allocated before the next garbage
 388 collection is initiated. This can be set with SETF.
 389
 390 On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic
 391 space size.
 392
 393 Note: currently changes to this value are lost when saving core."
 394   (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t))
 395
 396 (defun (setf bytes-consed-between-gcs) (val)
 397   (declare (type index val))
 398   (setf (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t)
 399         val))
 400
 401 (declaim (inline maybe-handle-pending-gc))
 402 (defun maybe-handle-pending-gc ()
 403   (when (and (not *gc-inhibit*)
 404              (or #!+sb-thread *stop-for-gc-pending*
 405                  *gc-pending*))
 406     (sb!unix::receive-pending-interrupt)))
 407
 408 ;;;; GENCGC specifics
 409 ;;;;
 410 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
 411 ;;;; as well.
 412 #!+gencgc
 413 (deftype generation-index ()
 414   '(integer 0 #.sb!vm:+pseudo-static-generation+))
 415
 416 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
 417 ;;; defined in Lisp, and written to header files by genesis, instead of this
 418 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
 419 #!+gencgc
 420 (define-alien-type generation
 421     (struct generation
 422             (alloc-start-page page-index-t)
 423             (alloc-unboxed-start-page page-index-t)
 424             (alloc-large-start-page page-index-t)
 425             (alloc-large-unboxed-start-page page-index-t)
 426             (bytes-allocated os-vm-size-t)
 427             (gc-trigger os-vm-size-t)
 428             (bytes-consed-between-gcs os-vm-size-t)
 429             (number-of-gcs int)
 430             (number-of-gcs-before-promotion int)
 431             (cum-sum-bytes-allocated os-vm-size-t)
 432             (minimum-age-before-gc double)))
 433
 434 #!+gencgc
 435 (define-alien-variable generations
 436     (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
 437
 438 (macrolet ((def (slot doc &optional setfp)
 439              (declare (ignorable doc))
 440              `(progn
 441                 (defun ,(symbolicate "GENERATION-" slot) (generation)
 442                   #!+sb-doc
 443                   ,doc
 444                   #!+gencgc
 445                   (declare (generation-index generation))
 446                   #!-gencgc
 447                   (declare (ignore generation))
 448                   #!-gencgc
 449                   (error "~S is a GENCGC only function and unavailable in this build"
 450                          ',slot)
 451                   #!+gencgc
 452                   (slot (deref generations generation) ',slot))
 453                 ,@(when setfp
 454                         `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
 455                             #!+gencgc
 456                             (declare (generation-index generation))
 457                             #!-gencgc
 458                             (declare (ignore value generation))
 459                             #!-gencgc
 460                             (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
 461                                    ',slot)
 462                             #!+gencgc
 463                             (setf (slot (deref generations generation) ',slot) value)))))))
 464   (def bytes-consed-between-gcs
 465       "Number of bytes that can be allocated to GENERATION before that
 466 generation is considered for garbage collection. This value is meaningless for
 467 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
 468 5% of the dynamic space size divided by the number of non-nursery generations.
 469 Can be assigned to using SETF. Available on GENCGC platforms only.
 470
 471 Experimental: interface subject to change."
 472     t)
 473   (def minimum-age-before-gc
 474       "Minimum average age of objects allocated to GENERATION before that
 475 generation is may be garbage collected. Default is 0.75. See also
 476 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
 477 platforms only.
 478
 479 Experimental: interface subject to change."
 480     t)
 481   (def number-of-gcs-before-promotion
 482       "Number of times garbage collection is done on GENERATION before
 483 automatic promotion to the next generation is triggered. Default is 1. Can be
 484 assigned to using SETF. Available on GENCGC platforms only.
 485
 486 Experimental: interface subject to change."
 487     t)
 488   (def bytes-allocated
 489       "Number of bytes allocated to GENERATION currently. Available on GENCGC
 490 platforms only.
 491
 492 Experimental: interface subject to change.")
 493   (def number-of-gcs
 494       "Number of times garbage collection has been done on GENERATION without
 495 promotion. Available on GENCGC platforms only.
 496
 497 Experimental: interface subject to change."))
 498   (defun generation-average-age (generation)
 499     "Average age of memory allocated to GENERATION: average number of times
 500 objects allocated to the generation have seen younger objects promoted to it.
 501 Available on GENCGC platforms only.
 502
 503 Experimental: interface subject to change."
 504     #!+gencgc
 505     (declare (generation-index generation))
 506     #!-gencgc (declare (ignore generation))
 507     #!-gencgc
 508     (error "~S is a GENCGC only function and unavailable in this build."
 509            'generation-average-age)
 510     #!+gencgc
 511     (alien-funcall (extern-alien "generation_average_age"
 512                                  (function double generation-index-t))
 513                    generation))