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