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   (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)
  40      sb!vm:static-space-start))
  41
  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))
  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            (let ((sb!impl::*in-without-gcing* t)
 240                  (sb!impl::*deadline* nil)
 241                  (sb!impl::*deadline-seconds* nil))
 242              (sb!thread:with-mutex (*already-in-gc*)
 243                (let ((*gc-inhibit* t))
 244                  (let ((old-usage (dynamic-usage))
 245                        (new-usage 0))
 246                    (unsafe-clear-roots gen)
 247                    (gc-stop-the-world)
 248                    (let ((start-time (get-internal-run-time)))
 249                      (collect-garbage gen)
 250                      (setf *gc-epoch* (cons nil nil))
 251                      (let ((run-time (- (get-internal-run-time) start-time)))
 252                        ;; KLUDGE: Sometimes we see the second getrusage() call
 253                        ;; return a smaller value than the first, which can
 254                        ;; lead to *GC-RUN-TIME* to going negative, which in
 255                        ;; turn is a type-error.
 256                        (when (plusp run-time)
 257                          (incf *gc-run-time* run-time))))
 258                    (setf *gc-pending* nil
 259                          new-usage (dynamic-usage))
 260                    #!+sb-thread
 261                    (assert (not *stop-for-gc-pending*))
 262                    (gc-start-the-world)
 263                    ;; In a multithreaded environment the other threads
 264                    ;; will see *n-b-f-o-p* change a little late, but
 265                    ;; that's OK.
 266                    (let ((freed (- old-usage new-usage)))
 267                      ;; GENCGC occasionally reports negative here, but
 268                      ;; the current belief is that it is part of the
 269                      ;; normal order of things and not a bug.
 270                      (when (plusp freed)
 271                        (incf *n-bytes-freed-or-purified* freed)))))))
 272            ;; While holding the mutex we were protected from
 273            ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to
 274            ;; preserve the invariant (*GC-PENDING* ->
 275            ;; pseudo-atomic-interrupted or *GC-INHIBIT*), let's check
 276            ;; explicitly for a pending gc before interrupts are
 277            ;; enabled again.
 278            (maybe-handle-pending-gc))
 279          t)))
 280
 281 (defun post-gc ()
 282   ;; Outside the mutex, interrupts may be enabled: these may cause
 283   ;; another GC. FIXME: it can potentially exceed maximum interrupt
 284   ;; nesting by triggering GCs.
 285   ;;
 286   ;; Can that be avoided by having the finalizers and hooks run only
 287   ;; from the outermost SUB-GC? If the nested GCs happen in interrupt
 288   ;; handlers that's not enough.
 289   ;;
 290   ;; KLUDGE: Don't run the hooks in GC's if:
 291   ;;
 292   ;; A) this thread is dying, so that user-code never runs with
 293   ;;    (thread-alive-p *current-thread*) => nil
 294   ;;
 295   ;; B) interrupts are disabled somewhere up the call chain since we
 296   ;;    don't want to run user code in such a case.
 297   ;;
 298   ;; The long-term solution will be to keep a separate thread for
 299   ;; finalizers and after-gc hooks.
 300   (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
 301     (when *allow-with-interrupts*
 302       (with-interrupts
 303         (run-pending-finalizers)
 304         (call-hooks "after-GC" *after-gc-hooks* :on-error :warn)))))
 305
 306 ;;; This is the user-advertised garbage collection function.
 307 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 308   #!+(and sb-doc gencgc)
 309   "Initiate a garbage collection. GEN controls the number of generations
 310   to garbage collect."
 311   #!+(and sb-doc (not gencgc))
 312   "Initiate a garbage collection. GEN may be provided for compatibility with
 313   generational garbage collectors, but is ignored in this implementation."
 314   (when (sub-gc :gen (if full 6 gen))
 315     (post-gc)))
 316
 317 (define-alien-routine scrub-control-stack sb!alien:void)
 318
 319 (defun unsafe-clear-roots (gen)
 320   #!-gencgc (declare (ignore gen))
 321   ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
 322   ;; as having these cons more then we have space left leads to huge
 323   ;; badness.
 324   (scrub-control-stack)
 325   ;; Power cache of the bignum printer: drops overly large bignums and
 326   ;; removes duplicate entries.
 327   (scrub-power-cache)
 328   ;; Clear caches depending on the generation being collected.
 329   #!+gencgc
 330   (cond ((eql 0 gen))
 331         ((eql 1 gen)
 332          (ctype-of-cache-clear))
 333         (t
 334          (drop-all-hash-caches)))
 335   #!-gencgc
 336   (drop-all-hash-caches))
 337 \f
 338 ;;;; auxiliary functions
 339
 340 (defun bytes-consed-between-gcs ()
 341   #!+sb-doc
 342   "The amount of memory that will be allocated before the next garbage
 343 collection is initiated. This can be set with SETF."
 344   (sb!alien:extern-alien "bytes_consed_between_gcs"
 345                          (sb!alien:unsigned 32)))
 346
 347 (defun (setf bytes-consed-between-gcs) (val)
 348   (declare (type index val))
 349   (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
 350                                (sb!alien:unsigned 32))
 351         val))
 352
 353 (declaim (inline maybe-handle-pending-gc))
 354 (defun maybe-handle-pending-gc ()
 355   (when (and (not *gc-inhibit*)
 356              (or #!+sb-thread *stop-for-gc-pending*
 357                  *gc-pending*))
 358     (sb!unix::receive-pending-interrupt)))
 359
 360 ;;;; GENCGC specifics
 361 ;;;;
 362 ;;;; For documentation convenience, these have stubs on non-GENCGC platforms
 363 ;;;; as well.
 364 #!+gencgc
 365 (deftype generation-index ()
 366   '(integer 0 #.sb!vm:+pseudo-static-generation+))
 367
 368 ;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
 369 ;;; defined in Lisp, and written to header files by genesis, instead of this
 370 ;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
 371 #!+gencgc
 372 (define-alien-type generation
 373     (struct generation
 374             (alloc-start-page page-index-t)
 375             (alloc-unboxed-start-page page-index-t)
 376             (alloc-large-start-page page-index-t)
 377             (alloc-large-unboxed-start-page page-index-t)
 378             (bytes-allocated unsigned-long)
 379             (gc-trigger unsigned-long)
 380             (bytes-consed-between-gcs unsigned-long)
 381             (number-of-gcs int)
 382             (number-of-gcs-before-promotion int)
 383             (cum-sum-bytes-allocated unsigned-long)
 384             (minimum-age-before-gc double)
 385             ;; `struct lutex *' or `void *', depending.
 386             (lutexes (* char))))
 387
 388 #!+gencgc
 389 (define-alien-variable generations
 390     (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
 391
 392 (macrolet ((def (slot doc &optional setfp)
 393              (declare (ignorable doc))
 394              `(progn
 395                 (defun ,(symbolicate "GENERATION-" slot) (generation)
 396                   #!+sb-doc
 397                   ,doc
 398                   #!+gencgc
 399                   (declare (generation-index generation))
 400                   #!-gencgc
 401                   (declare (ignore generation))
 402                   #!-gencgc
 403                   (error "~S is a GENCGC only function and unavailable in this build"
 404                          ',slot)
 405                   #!+gencgc
 406                   (slot (deref generations generation) ',slot))
 407                 ,@(when setfp
 408                         `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
 409                             #!+gencgc
 410                             (declare (generation-index generation))
 411                             #!-gencgc
 412                             (declare (ignore value generation))
 413                             #!-gencgc
 414                             (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
 415                                    ',slot)
 416                             #!+gencgc
 417                             (setf (slot (deref generations generation) ',slot) value)))))))
 418   (def bytes-consed-between-gcs
 419       "Number of bytes that can be allocated to GENERATION before that
 420 generation is considered for garbage collection. This value is meaningless for
 421 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
 422 20Mb. Can be assigned to using SETF. Available on GENCGC platforms only.
 423
 424 Experimental: interface subject to change."
 425     t)
 426   (def minimum-age-before-gc
 427       "Minimum average age of objects allocated to GENERATION before that
 428 generation is may be garbage collected. Default is 0.75. See also
 429 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
 430 platforms only.
 431
 432 Experimental: interface subject to change."
 433     t)
 434   (def number-of-gcs-before-promotion
 435       "Number of times garbage collection is done on GENERATION before
 436 automatic promotion to the next generation is triggered. Can be assigned to
 437 using SETF. Available on GENCGC platforms only.
 438
 439 Experimental: interface subject to change."
 440     t)
 441   (def bytes-allocated
 442       "Number of bytes allocated to GENERATION currently. Available on GENCGC
 443 platforms only.
 444
 445 Experimental: interface subject to change.")
 446   (def number-of-gcs
 447       "Number of times garbage collection has been done on GENERATION without
 448 promotion. Available on GENCGC platforms only.
 449
 450 Experimental: interface subject to change."))
 451   (defun generation-average-age (generation)
 452     "Average age of memory allocated to GENERATION: average number of times
 453 objects allocated to the generation have seen younger objects promoted to it.
 454 Available on GENCGC platforms only.
 455
 456 Experimental: interface subject to change."
 457     #!+gencgc
 458     (declare (generation-index generation))
 459     #!-gencgc (declare (ignore generation))
 460     #!-gencgc
 461     (error "~S is a GENCGC only function and unavailable in this build."
 462            'generation-average-age)
 463     #!+gencgc
 464     (alien-funcall (extern-alien "generation_average_age"
 465                                  (function double generation-index-t))
 466                    generation))