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 (declaim (special sb!vm:*read-only-space-free-pointer*
  17                   sb!vm:*static-space-free-pointer*))
  18
  19 (eval-when (:compile-toplevel :execute)
  20   (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
  21     `(progn
  22        #!-sb-fluid (declaim (inline ,lisp-fun))
  23        (defun ,lisp-fun ()
  24          (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
  25
  26 #!-gencgc
  27 (progn
  28   ;; This is called once per PROFILEd function call, so it's worth a
  29   ;; little possible space cost to reduce its time cost.
  30   #!-sb-fluid
  31   (declaim (inline current-dynamic-space-start))
  32   (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
  33
  34 #!-sb-fluid
  35 (declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
  36 #!+gencgc
  37 (def-c-var-frob dynamic-usage "bytes_allocated")
  38 #!-gencgc
  39 (defun dynamic-usage ()
  40   (the (unsigned-byte 32)
  41        (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
  42           (current-dynamic-space-start))))
  43
  44 (defun static-space-usage ()
  45   (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)
  46      sb!vm:static-space-start))
  47
  48 (defun read-only-space-usage ()
  49   (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes)
  50      sb!vm:read-only-space-start))
  51
  52 (defun control-stack-usage ()
  53   #!-stack-grows-downward-not-upward
  54   (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
  55      (sb!vm:fixnumize sb!vm:*control-stack-start*))
  56   #!+stack-grows-downward-not-upward
  57   (- (sb!vm:fixnumize sb!vm:*control-stack-end*)
  58      (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
  59
  60 (defun binding-stack-usage ()
  61   (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
  62      (sb!vm:fixnumize sb!vm:*binding-stack-start*)))
  63 \f
  64 ;;;; ROOM
  65
  66 (defun room-minimal-info ()
  67   (format t "Dynamic space usage is:   ~10:D bytes.~%" (dynamic-usage))
  68   (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
  69   (format t "Static space usage is:    ~10:D bytes.~%" (static-space-usage))
  70   (format t "Control stack usage is:   ~10:D bytes.~%" (control-stack-usage))
  71   (format t "Binding stack usage is:   ~10:D bytes.~%" (binding-stack-usage))
  72   #!+sb-thread
  73   (format t
  74           "Control and binding stack usage is for the current thread only.~%")
  75   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
  76           (> *gc-inhibit* 0)))
  77
  78 (defun room-intermediate-info ()
  79   (room-minimal-info)
  80   (sb!vm:memory-usage :count-spaces '(:dynamic)
  81                       :print-spaces t
  82                       :cutoff 0.05f0
  83                       :print-summary nil))
  84
  85 (defun room-maximal-info ()
  86   (room-minimal-info)
  87   (sb!vm:memory-usage :count-spaces '(:static :dynamic))
  88   (sb!vm:instance-usage :dynamic :top-n 10)
  89   (sb!vm:instance-usage :static :top-n 10))
  90
  91 (defun room (&optional (verbosity :default))
  92   #!+sb-doc
  93   "Print to *STANDARD-OUTPUT* information about the state of internal
  94   storage and its management. The optional argument controls the
  95   verbosity of output. If it is T, ROOM prints out a maximal amount of
  96   information. If it is NIL, ROOM prints out a minimal amount of
  97   information. If it is :DEFAULT or it is not supplied, ROOM prints out
  98   an intermediate amount of information."
  99   (fresh-line)
 100   (ecase verbosity
 101     ((t)
 102      (room-maximal-info))
 103     ((nil)
 104      (room-minimal-info))
 105     (:default
 106      (room-intermediate-info)))
 107   (values))
 108 \f
 109 ;;;; GET-BYTES-CONSED
 110
 111 ;;; the total number of bytes freed so far (including any freeing
 112 ;;; which goes on in PURIFY)
 113 ;;;
 114 ;;; (We save this so that we can calculate the total number of bytes
 115 ;;; ever allocated by adding this to the number of bytes currently
 116 ;;; allocated and never freed.)
 117 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
 118 (defvar *n-bytes-freed-or-purified* 0)
 119 (push (lambda ()
 120         (setf *n-bytes-freed-or-purified* 0))
 121       ;; KLUDGE: It's probably not quite safely right either to do
 122       ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
 123       ;; worse, something which depended on (GET-BYTES-CONSED), might
 124       ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
 125       ;; it's probably not a big problem, and there seems to be no
 126       ;; other obvious time to do it. -- WHN 2001-07-30
 127       *after-save-initializations*)
 128
 129 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 130 (defun get-bytes-consed ()
 131   #!+sb-doc
 132   "Return the number of bytes consed since the program began. Typically
 133 this result will be a consed bignum, so if you have an application (e.g.
 134 profiling) which can't tolerate the overhead of consing bignums, you'll
 135 probably want either to hack in at a lower level (as the code in the
 136 SB-PROFILE package does), or to design a more microefficient interface
 137 and submit it as a patch."
 138   (+ (dynamic-usage)
 139      *n-bytes-freed-or-purified*))
 140 \f
 141 ;;;; GC hooks
 142
 143 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 144   #!+sb-doc
 145   "A list of functions that are called before garbage collection occurs.
 146   The functions are run with interrupts disabled and all other threads
 147   paused.  They should take no arguments.")
 148
 149 (defvar *after-gc-hooks* nil ; actually initialized in cold init
 150   #!+sb-doc
 151   "A list of functions that are called after garbage collection occurs.
 152   The functions are run with interrupts disabled and all other threads
 153   paused.  They should take no arguments.")
 154
 155 ;;;; The following specials are used to control when garbage
 156 ;;;; collection occurs.
 157
 158 ;;; When the dynamic usage increases beyond this amount, the system
 159 ;;; notes that a garbage collection needs to occur by setting
 160 ;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 161 ;;; nobody has figured out what it should be yet.
 162 ;;;
 163 ;;; FIXME: *GC-TRIGGER* seems to be denominated in bytes, not words.
 164 ;;; And limiting it to INDEX is fairly reasonable in order to avoid
 165 ;;; bignum arithmetic on every allocation, and to minimize the need
 166 ;;; for thought about weird gotchas of the GC-control mechanism itself
 167 ;;; consing as it operates. But as of sbcl-0.7.5, 512Mbytes of memory
 168 ;;; costs $54.95 at Fry's in Dallas but cheap consumer 64-bit machines
 169 ;;; are still over the horizon, so gratuitously limiting our heap size
 170 ;;; to FIXNUM bytes seems fairly stupid. It'd be reasonable to
 171 ;;; (1) allow arbitrary UNSIGNED-BYTE values of *GC-TRIGGER*, or
 172 ;;; (2) redenominate this variable in words instead of bytes, postponing
 173 ;;;     the problem to heaps which exceed 50% of the machine's address
 174 ;;;     space, or even
 175 ;;; (3) redemoninate this variable in CONS-sized two-word units,
 176 ;;;     allowing it to cover the entire memory space at the price of
 177 ;;;     possible loss of clarity.
 178 ;;; (And whatever is done, it'd also be good to rename the variable so
 179 ;;; that it's clear what unit it's denominated in.)
 180 (declaim (type (or index null) *gc-trigger*))
 181 (defvar *gc-trigger* nil)
 182
 183 ;;; When T, indicates that a GC should have happened but did not due to
 184 ;;; *GC-INHIBIT*.
 185 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 186 \f
 187 ;;;; internal GC
 188
 189 (sb!alien:define-alien-routine collect-garbage sb!alien:int
 190   (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
 191
 192 #!+sb-thread
 193 (progn
 194   (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
 195   (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
 196 #!-sb-thread
 197 (progn
 198   (defun gc-stop-the-world ())
 199   (defun gc-start-the-world ()))
 200
 201 \f
 202 ;;;; SUB-GC
 203
 204 ;;; This is used to carefully invoke hooks.
 205 (eval-when (:compile-toplevel :execute)
 206   (sb!xc:defmacro carefully-funcall (function &rest args)
 207     `(handler-case (funcall ,function ,@args)
 208        (error (cond)
 209               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 210               nil))))
 211
 212 ;;; SUB-GC does a garbage collection.  This is called from three places:
 213 ;;; (1) The C runtime will call here when it detects that we've consed
 214 ;;;     enough to exceed the gc trigger threshold.  This is done in
 215 ;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
 216 ;;; (2) The user may request a collection using GC, below
 217 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
 218 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
 219 ;;;
 220 ;;; This is different from the behaviour in 0.7 and earlier: it no
 221 ;;; longer decides whether to GC based on thresholds.  If you call
 222 ;;; SUB-GC you will definitely get a GC either now or when the
 223 ;;; WITHOUT-GCING is over
 224
 225 ;;; For GENCGC all generations < GEN will be GC'ed.
 226
 227 (defvar *already-in-gc*
 228   (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
 229
 230 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
 231   (let ((me (sb!thread:current-thread-id)))
 232     (when (eql (sb!thread::mutex-value *already-in-gc*) me)
 233       (return-from sub-gc nil))
 234     (setf *need-to-collect-garbage* t)
 235     (when (zerop *gc-inhibit*)
 236       (loop
 237        (sb!thread:with-mutex (*already-in-gc*)
 238          (unless *need-to-collect-garbage* (return-from sub-gc nil))
 239          (without-interrupts
 240           (gc-stop-the-world)
 241           (collect-garbage gen)
 242           (incf *n-bytes-freed-or-purified*
 243                 (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
 244           (scrub-control-stack)
 245           (setf *need-to-collect-garbage* nil)
 246           (dolist (h *after-gc-hooks*) (carefully-funcall h))
 247           (gc-start-the-world))
 248          (sb!thread::reap-dead-threads))))))
 249
 250 ;;; This is the user-advertised garbage collection function.
 251 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 252   #!+(and sb-doc gencgc)
 253   "Initiate a garbage collection. GEN controls the number of generations
 254   to garbage collect."
 255   #!+(and sb-doc (not gencgc))
 256   "Initiate a garbage collection. GEN may be provided for compatibility with
 257   generational garbage collectors, but is ignored in this implementation."
 258   (sub-gc :gen (if full 6 gen)))
 259
 260 \f
 261 ;;;; auxiliary functions
 262
 263 (defun bytes-consed-between-gcs ()
 264   #!+sb-doc
 265   "Return the amount of memory that will be allocated before the next garbage
 266    collection is initiated. This can be set with SETF."
 267   (sb!alien:extern-alien "bytes_consed_between_gcs"
 268                          (sb!alien:unsigned 32)))
 269
 270 (defun (setf bytes-consed-between-gcs) (val)
 271   (declare (type index val))
 272   (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
 273                                (sb!alien:unsigned 32))
 274         val))
 275
 276 (defun gc-on ()
 277   #!+sb-doc
 278   "Enable the garbage collector."
 279   (setq *gc-inhibit* 0)
 280   (when *need-to-collect-garbage*
 281     (sub-gc))
 282   nil)
 283
 284 (defun gc-off ()
 285   #!+sb-doc
 286   "Disable the garbage collector."
 287   (setq *gc-inhibit* 1)
 288   nil)
 289