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