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   ;; 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             ;; `struct lutex *' or `void *', depending.
 385             (lutexes (* char))))
 386
 387 #!+gencgc
 388 (define-alien-variable generations
 389     (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
 390
 391 (macrolet ((def (slot doc &optional setfp)
 392              (declare (ignorable doc))
 393              `(progn
 394                 (defun ,(symbolicate "GENERATION-" slot) (generation)
 395                   #!+sb-doc
 396                   ,doc
 397                   #!+gencgc
 398                   (declare (generation-index generation))
 399                   #!-gencgc
 400                   (declare (ignore generation))
 401                   #!-gencgc
 402                   (error "~S is a GENCGC only function and unavailable in this build"
 403                          ',slot)
 404                   #!+gencgc
 405                   (slot (deref generations generation) ',slot))
 406                 ,@(when setfp
 407                         `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
 408                             #!+gencgc
 409                             (declare (generation-index generation))
 410                             #!-gencgc
 411                             (declare (ignore value generation))
 412                             #!-gencgc
 413                             (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
 414                                    ',slot)
 415                             #!+gencgc
 416                             (setf (slot (deref generations generation) ',slot) value)))))))
 417   (def bytes-consed-between-gcs
 418       "Number of bytes that can be allocated to GENERATION before that
 419 generation is considered for garbage collection. This value is meaningless for
 420 generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
 421 20Mb. Can be assigned to using SETF. Available on GENCGC platforms only.
 422
 423 Experimental: interface subject to change."
 424     t)
 425   (def minimum-age-before-gc
 426       "Minimum average age of objects allocated to GENERATION before that
 427 generation is may be garbage collected. Default is 0.75. See also
 428 GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
 429 platforms only.
 430
 431 Experimental: interface subject to change."
 432     t)
 433   (def number-of-gcs-before-promotion
 434       "Number of times garbage collection is done on GENERATION before
 435 automatic promotion to the next generation is triggered. Can be assigned to
 436 using SETF. Available on GENCGC platforms only.
 437
 438 Experimental: interface subject to change."
 439     t)
 440   (def bytes-allocated
 441       "Number of bytes allocated to GENERATION currently. Available on GENCGC
 442 platforms only.
 443
 444 Experimental: interface subject to change.")
 445   (def number-of-gcs
 446       "Number of times garbage collection has been done on GENERATION without
 447 promotion. Available on GENCGC platforms only.
 448
 449 Experimental: interface subject to change."))
 450   (defun generation-average-age (generation)
 451     "Average age of memory allocated to GENERATION: average number of times
 452 objects allocated to the generation have seen younger objects promoted to it.
 453 Available on GENCGC platforms only.
 454
 455 Experimental: interface subject to change."
 456     #!+gencgc
 457     (declare (generation-index generation))
 458     #!-gencgc (declare (ignore generation))
 459     #!-gencgc
 460     (error "~S is a GENCGC only function and unavailable in this build."
 461            'generation-average-age)
 462     #!+gencgc
 463     (alien-funcall (extern-alien "generation_average_age"
 464                                  (function double generation-index-t))
 465                    generation))