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