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 (defvar *gc-run-time* 0
 156   #!+sb-doc
 157   "the total CPU time spent doing garbage collection (as reported by
 158    GET-INTERNAL-RUN-TIME)")
 159 (declaim (type index *gc-run-time*))
 160
 161 ;;;; The following specials are used to control when garbage
 162 ;;;; collection occurs.
 163
 164 ;;; When the dynamic usage increases beyond this amount, the system
 165 ;;; notes that a garbage collection needs to occur by setting
 166 ;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 167 ;;; nobody has figured out what it should be yet.
 168 ;;;
 169 ;;; FIXME: *GC-TRIGGER* seems to be denominated in bytes, not words.
 170 ;;; And limiting it to INDEX is fairly reasonable in order to avoid
 171 ;;; bignum arithmetic on every allocation, and to minimize the need
 172 ;;; for thought about weird gotchas of the GC-control mechanism itself
 173 ;;; consing as it operates. But as of sbcl-0.7.5, 512Mbytes of memory
 174 ;;; costs $54.95 at Fry's in Dallas but cheap consumer 64-bit machines
 175 ;;; are still over the horizon, so gratuitously limiting our heap size
 176 ;;; to FIXNUM bytes seems fairly stupid. It'd be reasonable to
 177 ;;; (1) allow arbitrary UNSIGNED-BYTE values of *GC-TRIGGER*, or
 178 ;;; (2) redenominate this variable in words instead of bytes, postponing
 179 ;;;     the problem to heaps which exceed 50% of the machine's address
 180 ;;;     space, or even
 181 ;;; (3) redemoninate this variable in CONS-sized two-word units,
 182 ;;;     allowing it to cover the entire memory space at the price of
 183 ;;;     possible loss of clarity.
 184 ;;; (And whatever is done, it'd also be good to rename the variable so
 185 ;;; that it's clear what unit it's denominated in.)
 186 (declaim (type (or index null) *gc-trigger*))
 187 (defvar *gc-trigger* nil)
 188
 189 ;;; When T, indicates that a GC should have happened but did not due to
 190 ;;; *GC-INHIBIT*.
 191 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 192 \f
 193 ;;;; internal GC
 194
 195 (sb!alien:define-alien-routine collect-garbage sb!alien:int
 196   (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
 197
 198 #!+sb-thread
 199 (progn
 200   (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
 201   (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
 202 #!-sb-thread
 203 (progn
 204   (defun gc-stop-the-world ())
 205   (defun gc-start-the-world ()))
 206
 207 \f
 208 ;;;; SUB-GC
 209
 210 ;;; This is used to carefully invoke hooks.
 211 (eval-when (:compile-toplevel :execute)
 212   (sb!xc:defmacro carefully-funcall (function &rest args)
 213     `(handler-case (funcall ,function ,@args)
 214        (error (cond)
 215               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 216               nil))))
 217
 218 ;;; SUB-GC does a garbage collection.  This is called from three places:
 219 ;;; (1) The C runtime will call here when it detects that we've consed
 220 ;;;     enough to exceed the gc trigger threshold.  This is done in
 221 ;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
 222 ;;; (2) The user may request a collection using GC, below
 223 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
 224 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
 225 ;;;
 226 ;;; This is different from the behaviour in 0.7 and earlier: it no
 227 ;;; longer decides whether to GC based on thresholds.  If you call
 228 ;;; SUB-GC you will definitely get a GC either now or when the
 229 ;;; WITHOUT-GCING is over
 230
 231 ;;; For GENCGC all generations < GEN will be GC'ed.
 232
 233 (defvar *already-in-gc* nil "System is running SUB-GC")
 234 (defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
 235
 236 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
 237   ;; catch attempts to gc recursively or during post-hooks and ignore them
 238   (when (sb!thread::mutex-value *gc-mutex*)  (return-from sub-gc nil))
 239   (sb!thread:with-mutex (*gc-mutex* :wait-p nil)
 240     (setf *need-to-collect-garbage* t)
 241     (when (zerop *gc-inhibit*)
 242       (without-interrupts
 243        (gc-stop-the-world)
 244        (collect-garbage gen)
 245        (incf *n-bytes-freed-or-purified*
 246              (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
 247        (setf *need-to-collect-garbage* nil)
 248        (gc-start-the-world))
 249       (scrub-control-stack)
 250       (setf *need-to-collect-garbage* nil)
 251       (dolist (h *after-gc-hooks*) (carefully-funcall h))))
 252   (values))
 253
 254
 255
 256 ;;; This is the user-advertised garbage collection function.
 257 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 258   #!+(and sb-doc gencgc)
 259   "Initiate a garbage collection. GEN controls the number of generations
 260   to garbage collect."
 261   #!+(and sb-doc (not gencgc))
 262   "Initiate a garbage collection. GEN may be provided for compatibility with
 263   generational garbage collectors, but is ignored in this implementation."
 264   (sub-gc :gen (if full 6 gen)))
 265
 266 \f
 267 ;;;; auxiliary functions
 268
 269 (defun bytes-consed-between-gcs ()
 270   #!+sb-doc
 271   "Return the amount of memory that will be allocated before the next garbage
 272    collection is initiated. This can be set with SETF."
 273   (sb!alien:extern-alien "bytes_consed_between_gcs"
 274                          (sb!alien:unsigned 32)))
 275
 276 (defun (setf bytes-consed-between-gcs) (val)
 277   (declare (type index val))
 278   (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
 279                                (sb!alien:unsigned 32))
 280         val))
 281
 282 (defun gc-on ()
 283   #!+sb-doc
 284   "Enable the garbage collector."
 285   (setq *gc-inhibit* 0)
 286   (when *need-to-collect-garbage*
 287     (sub-gc))
 288   nil)
 289
 290 (defun gc-off ()
 291   #!+sb-doc
 292   "Disable the garbage collector."
 293   (setq *gc-inhibit* 1)
 294   nil)
 295