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