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