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 >0, inhibits garbage collection.
 190 (defvar *gc-inhibit*) ; initialized in cold init
 191
 192 ;;; When T, indicates that a GC should have happened but did not due to
 193 ;;; *GC-INHIBIT*.
 194 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 195 \f
 196 ;;;; internal GC
 197
 198 (sb!alien:define-alien-routine collect-garbage sb!alien:int
 199   (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
 200
 201 #!+sb-thread
 202 (progn
 203   (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
 204   (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
 205 #!-sb-thread
 206 (progn
 207   (defun gc-stop-the-world ())
 208   (defun gc-start-the-world ()))
 209
 210 \f
 211 ;;;; SUB-GC
 212
 213 ;;; This is used to carefully invoke hooks.
 214 (eval-when (:compile-toplevel :execute)
 215   (sb!xc:defmacro carefully-funcall (function &rest args)
 216     `(handler-case (funcall ,function ,@args)
 217        (error (cond)
 218               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 219               nil))))
 220
 221 ;;; SUB-GC does a garbage collection.  This is called from three places:
 222 ;;; (1) The C runtime will call here when it detects that we've consed
 223 ;;;     enough to exceed the gc trigger threshold.  This is done in
 224 ;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
 225 ;;; (2) The user may request a collection using GC, below
 226 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
 227 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
 228 ;;;
 229 ;;; This is different from the behaviour in 0.7 and earlier: it no
 230 ;;; longer decides whether to GC based on thresholds.  If you call
 231 ;;; SUB-GC you will definitely get a GC either now or when the
 232 ;;; WITHOUT-GCING is over
 233
 234 ;;; For GENCGC all generations < GEN will be GC'ed.
 235
 236 (defvar *already-in-gc* nil "System is running SUB-GC")
 237 (defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
 238
 239 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
 240   (when *already-in-gc* (return-from sub-gc nil))
 241   (setf *need-to-collect-garbage* t)
 242   (when (zerop *gc-inhibit*)
 243     (sb!thread:with-recursive-lock (*gc-mutex*)
 244       (let ((*already-in-gc* t))
 245         (without-interrupts
 246          (gc-stop-the-world)
 247          #+nil
 248          (dolist (h *before-gc-hooks*)
 249            (carefully-funcall h))
 250          (collect-garbage gen)
 251          (incf *n-bytes-freed-or-purified*
 252                (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
 253          (setf *need-to-collect-garbage* nil)
 254
 255          (gc-start-the-world)))
 256       (scrub-control-stack))
 257     (dolist (h *after-gc-hooks*)
 258       (carefully-funcall h)))
 259   (values))
 260
 261
 262
 263 ;;; This is the user-advertised garbage collection function.
 264 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 265   #!+(and sb-doc gencgc)
 266   "Initiate a garbage collection. GEN controls the number of generations
 267   to garbage collect."
 268   #!+(and sb-doc (not gencgc))
 269   "Initiate a garbage collection. GEN may be provided for compatibility with
 270   generational garbage collectors, but is ignored in this implementation."
 271   (sub-gc :gen (if full 6 gen)))
 272
 273 \f
 274 ;;;; auxiliary functions
 275
 276 (defun bytes-consed-between-gcs ()
 277   #!+sb-doc
 278   "Return the amount of memory that will be allocated before the next garbage
 279    collection is initiated. This can be set with SETF."
 280   (sb!alien:extern-alien "bytes_consed_between_gcs"
 281                          (sb!alien:unsigned 32)))
 282
 283 (defun (setf bytes-consed-between-gcs) (val)
 284   (declare (type index val))
 285   (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
 286                                (sb!alien:unsigned 32))
 287         val))
 288
 289 (defun gc-on ()
 290   #!+sb-doc
 291   "Enable the garbage collector."
 292   (setq *gc-inhibit* 0)
 293   (when *need-to-collect-garbage*
 294     (sub-gc))
 295   nil)
 296
 297 (defun gc-off ()
 298   #!+sb-doc
 299   "Disable the garbage collector."
 300   (setq *gc-inhibit* 1)
 301   nil)
 302