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
  14 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; DYNAMIC-USAGE and friends
  18
  19 (declaim (special sb!vm:*read-only-space-free-pointer*
  20                   sb!vm:*static-space-free-pointer*))
  21
  22 (eval-when (:compile-toplevel :execute)
  23   (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
  24     `(progn
  25        #!-sb-fluid (declaim (inline ,lisp-fun))
  26        (defun ,lisp-fun ()
  27          (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
  28
  29 (def-c-var-frob sb!vm:control-stack-start           "control_stack")
  30 #!+x86 (def-c-var-frob control-stack-end            "control_stack_end")
  31 (def-c-var-frob sb!vm:binding-stack-start           "binding_stack")
  32 (def-c-var-frob sb!vm:current-dynamic-space-start "current_dynamic_space")
  33
  34 #!-sb-fluid (declaim (inline dynamic-usage))
  35 #!-(or cgc gencgc)
  36 (defun dynamic-usage ()
  37   (the (unsigned-byte 32)
  38        (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
  39           (sb!vm:current-dynamic-space-start))))
  40 #!+(or cgc gencgc)
  41 (def-c-var-frob dynamic-usage "bytes_allocated")
  42
  43 (defun static-space-usage ()
  44   (- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
  45      sb!vm:*static-space-start*))
  46
  47 (defun read-only-space-usage ()
  48   (- (* sb!vm::*read-only-space-free-pointer* sb!vm:word-bytes)
  49      sb!vm:*read-only-space-start*))
  50
  51 (defun control-stack-usage ()
  52   #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
  53             (control-stack-start))
  54   #!+x86 (- (control-stack-end)
  55             (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
  56
  57 (defun binding-stack-usage ()
  58   (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
  59      (sb!vm:binding-stack-start)))
  60 \f
  61 ;;;; ROOM
  62
  63 (defun room-minimal-info ()
  64   (format t "Dynamic space usage is:   ~10:D bytes.~%" (dynamic-usage))
  65   (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
  66   (format t "Static space usage is:    ~10:D bytes.~%" (static-space-usage))
  67   (format t "Control stack usage is:   ~10:D bytes.~%" (control-stack-usage))
  68   (format t "Binding stack usage is:   ~10:D bytes.~%" (binding-stack-usage))
  69   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
  70           *gc-inhibit*))
  71
  72 (defun room-intermediate-info ()
  73   (room-minimal-info)
  74   (sb!vm:memory-usage :count-spaces '(:dynamic)
  75                       :print-spaces t
  76                       :cutoff 0.05s0
  77                       :print-summary nil))
  78
  79 (defun room-maximal-info ()
  80   (room-minimal-info)
  81   (sb!vm:memory-usage :count-spaces '(:static :dynamic))
  82   (sb!vm:instance-usage :dynamic :top-n 10)
  83   (sb!vm:instance-usage :static :top-n 10))
  84
  85 (defun room (&optional (verbosity :default))
  86   #!+sb-doc
  87   "Prints to *STANDARD-OUTPUT* information about the state of internal
  88   storage and its management. The optional argument controls the
  89   verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
  90   information. If it is NIL, ROOM prints out a minimal amount of
  91   information. If it is :DEFAULT or it is not supplied, ROOM prints out
  92   an intermediate amount of information. See also VM:MEMORY-USAGE and
  93   VM:INSTANCE-USAGE for finer report control."
  94   (fresh-line)
  95   (ecase verbosity
  96     ((t)
  97      (room-maximal-info))
  98     ((nil)
  99      (room-minimal-info))
 100     (:default
 101      (room-intermediate-info)))
 102   (values))
 103 \f
 104 ;;;; GET-BYTES-CONSED
 105
 106 ;;; internal state
 107 (defvar *last-bytes-in-use* nil)
 108 (defvar *total-bytes-consed* 0)
 109 (declaim (type (or index null) *last-bytes-in-use*))
 110 (declaim (type integer *total-bytes-consed*))
 111
 112 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 113 (defun get-bytes-consed ()
 114   #!+sb-doc
 115   "Returns the number of bytes consed since the first time this function
 116   was called. The first time it is called, it returns zero."
 117   (declare (optimize (speed 3) (safety 0)))
 118   (cond ((null *last-bytes-in-use*)
 119          (setq *last-bytes-in-use* (dynamic-usage))
 120          (setq *total-bytes-consed* 0))
 121         (t
 122          (let ((bytes (dynamic-usage)))
 123            (incf *total-bytes-consed*
 124                  (the index (- bytes *last-bytes-in-use*)))
 125            (setq *last-bytes-in-use* bytes))))
 126   *total-bytes-consed*)
 127 \f
 128 ;;;; variables and constants
 129
 130 ;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
 131 (defconstant default-bytes-consed-between-gcs 2000000)
 132
 133 ;;; This variable is the user-settable variable that specifies the
 134 ;;; minimum amount of dynamic space which must be consed before a GC
 135 ;;; will be triggered.
 136 ;;;
 137 ;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
 138 ;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
 139 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
 140   #!+sb-doc
 141   "This number specifies the minimum number of bytes of dynamic space
 142    that must be consed before the next GC will occur.")
 143 (declaim (type index *bytes-consed-between-gcs*))
 144
 145 ;;;; GC hooks
 146
 147 ;;; These variables are a list of functions which are run before and
 148 ;;; after garbage collection occurs.
 149 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 150   #!+sb-doc
 151   "A list of functions that are called before garbage collection occurs.
 152   The functions should take no arguments.")
 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 should take no arguments.")
 157
 158 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
 159 ;;; was explicitly forced by calling SB!EXT:GC). If the hook function
 160 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
 161 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
 162 ;;; Presumably someone will call GC-ON later to collect the garbage.
 163 (defvar *gc-inhibit-hook* nil
 164   #!+sb-doc
 165   "Should be bound to a function or NIL. If it is a function, this
 166   function should take one argument, the current amount of dynamic
 167   usage. The function should return NIL if garbage collection should
 168   continue and non-NIL if it should be inhibited. Use with caution.")
 169
 170 (defvar *gc-verbose* nil ; (actually initialized in cold init)
 171   #!+sb-doc
 172   "Should low-level GC functions produce verbose diagnostic output?")
 173
 174 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
 175   #!+sb-doc
 176   "When non-NIL, this must be a STREAM; and the functions bound to
 177   *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
 178   STREAM value before and after a garbage collection occurs
 179   respectively.")
 180
 181 (defvar *gc-run-time* 0
 182   #!+sb-doc
 183   "The total CPU time spent doing garbage collection (as reported by
 184    GET-INTERNAL-RUN-TIME.)")
 185
 186 (declaim (type index *gc-run-time*))
 187
 188 ;;; Internal trigger. When the dynamic usage increases beyond this
 189 ;;; amount, the system notes that a garbage collection needs to occur by
 190 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 191 ;;; nobody has figured out what it should be yet.
 192 (defvar *gc-trigger* nil)
 193
 194 (declaim (type (or index null) *gc-trigger*))
 195
 196 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
 197 ;;; letting magic C code handle it. It gets initialized by the startup
 198 ;;; code. The X86 port defines this here because it uses the `ibmrt'
 199 ;;; feature in the C code for allocation and binding stack access and
 200 ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
 201 #!+(or ibmrt x86)
 202 (defvar sb!vm::*internal-gc-trigger*)
 203
 204 ;;;; The following specials are used to control when garbage collection
 205 ;;;; occurs.
 206
 207 ;;; When non-NIL, inhibits garbage collection.
 208 (defvar *gc-inhibit*) ; initialized in cold init
 209
 210 ;;; This flag is used to prevent recursive entry into the garbage
 211 ;;; collector.
 212 (defvar *already-maybe-gcing*) ; initialized in cold init
 213
 214 ;;; When T, indicates that the dynamic usage has exceeded the value
 215 ;;; *GC-TRIGGER*.
 216 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 217 \f
 218 (defun default-gc-notify-before (notify-stream bytes-in-use)
 219   (declare (type stream notify-stream))
 220   (format notify-stream
 221           "~&; GC is beginning with ~:D bytes in use.~%"
 222           bytes-in-use)
 223   (finish-output notify-stream))
 224 (defparameter *gc-notify-before* #'default-gc-notify-before
 225   #!+sb-doc
 226   "This function bound to this variable is invoked before GC'ing (unless
 227   *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
 228   current amount of dynamic usage (in bytes). It should notify the
 229   user that the system is going to GC.")
 230
 231 (defun default-gc-notify-after (notify-stream
 232                                 bytes-retained
 233                                 bytes-freed
 234                                 new-trigger)
 235   (declare (type stream notify-stream))
 236   (format notify-stream
 237           "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
 238           bytes-retained
 239           bytes-freed)
 240   (format notify-stream
 241           "~&; The new GC trigger is ~:D bytes.~%"
 242           new-trigger)
 243   (finish-output notify-stream))
 244 (defparameter *gc-notify-after* #'default-gc-notify-after
 245   #!+sb-doc
 246   "The function bound to this variable is invoked after GC'ing (unless
 247   *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
 248   the amount of dynamic usage (in bytes) now free, the number of
 249   bytes freed by the GC, and the new GC trigger threshold. The function
 250   should notify the user that the system has finished GC'ing.")
 251 \f
 252 ;;;; internal GC
 253
 254 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
 255   #!+gencgc (last-gen sb!c-call:int))
 256
 257 #!-ibmrt
 258 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
 259   (dynamic-usage sb!c-call:unsigned-long))
 260
 261 #!+ibmrt
 262 (defun set-auto-gc-trigger (bytes)
 263   (let ((words (ash (+ (sb!vm:current-dynamic-space-start) bytes) -2)))
 264     (unless (and (fixnump words) (plusp words))
 265       (clear-auto-gc-trigger)
 266       (warn "attempt to set GC trigger to something bogus: ~S" bytes))
 267     (setf %rt::*internal-gc-trigger* words)))
 268
 269 #!-ibmrt
 270 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
 271
 272 #!+ibmrt
 273 (defun clear-auto-gc-trigger ()
 274   (setf %rt::*internal-gc-trigger* -1))
 275
 276 ;;; This variable contains the function that does the real GC. This is
 277 ;;; for low-level GC experimentation. Do not touch it if you do not
 278 ;;; know what you are doing.
 279 (defvar *internal-gc* #'collect-garbage)
 280 \f
 281 ;;;; SUB-GC
 282
 283 ;;; Used to carefully invoke hooks.
 284 (eval-when (:compile-toplevel :execute)
 285   (sb!xc:defmacro carefully-funcall (function &rest args)
 286     `(handler-case (funcall ,function ,@args)
 287        (error (cond)
 288               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 289               nil))))
 290
 291 ;;; SUB-GC decides when and if to do a garbage collection. The
 292 ;;; VERBOSE-P flag controls whether or not the notify functions are
 293 ;;; called. The FORCE-P flags controls if a GC should occur even if
 294 ;;; the dynamic usage is not greater than *GC-TRIGGER*.
 295 ;;;
 296 ;;; For GENCGC all generations < GEN will be GC'ed.
 297 ;;;
 298 ;;; FIXME: The VERBOSE-P stuff is no longer used.
 299 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0))
 300   (/show0 "entering SUB-GC")
 301   (unless *already-maybe-gcing*
 302     (/show0 "not *ALREADY-MAYBE-GCING*")
 303     (let* ((*already-maybe-gcing* t)
 304            (start-time (get-internal-run-time))
 305            (pre-gc-dyn-usage (dynamic-usage)))
 306       (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
 307         ;; The noise w/ symbol-value above is to keep the compiler
 308         ;; from optimizing the test away because of the type declaim
 309         ;; for *bytes-consed-between-gcs*.
 310         ;;
 311         ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
 312         ;; trust it, instead of doing this weird hack. It's not
 313         ;; particularly trustable, since (SETF
 314         ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
 315         ;; very nice to have the type of the variable specified in two
 316         ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
 317         ;; INDEX) drift apart. So perhaps we should just add a note to
 318         ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
 319         ;; that it must be an INDEX, and remove the DECLAIM. Or we
 320         ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
 321         ;; and enforce the typing that way. And in fact the SETFable
 322         ;; function already exists, so all we need do is make the
 323         ;; variable private, and then we can trust the DECLAIM.
 324         (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
 325                integer. Resetting it to ~D."
 326               *bytes-consed-between-gcs*
 327                default-bytes-consed-between-gcs)
 328         (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
 329       (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
 330         (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
 331         (setf *need-to-collect-garbage* t))
 332       (when (or force-p
 333                 (and *need-to-collect-garbage* (not *gc-inhibit*)))
 334         (/show0 "Evidently we ought to collect garbage..")
 335         (when (and (not force-p)
 336                    *gc-inhibit-hook*
 337                    (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
 338           (/show0 "..but we're inhibited.")
 339           (setf *gc-inhibit* t)
 340           (return-from sub-gc nil))
 341         ;; KLUDGE: Wow, we really mask interrupts all the time we're
 342         ;; collecting garbage? That seems like a long time.. -- WHN 19991129
 343         (without-interrupts
 344          ;; FIXME: We probably shouldn't do this evil thing to
 345          ;; *STANDARD-OUTPUT* in a binding which is wrapped around
 346          ;; calls to user-settable GC hook functions.
 347           (let ((*standard-output* *terminal-io*))
 348             (when *gc-notify-stream*
 349               (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
 350               (if (streamp *gc-notify-stream*)
 351                   (carefully-funcall *gc-notify-before*
 352                                      *gc-notify-stream*
 353                                      pre-gc-dyn-usage)
 354                   (warn
 355                    "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
 356             (dolist (hook *before-gc-hooks*)
 357               (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
 358               (carefully-funcall hook))
 359             (when *gc-trigger*
 360               (clear-auto-gc-trigger))
 361             (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
 362             #!-gencgc (funcall *internal-gc*)
 363             ;; FIXME: This EQ test is pretty gross. Among its other
 364             ;; nastinesses, it looks as though it could break if we
 365             ;; recompile COLLECT-GARBAGE.
 366             #!+gencgc (if (eq *internal-gc* #'collect-garbage)
 367                           (funcall *internal-gc* gen)
 368                           (funcall *internal-gc*))
 369             (/show0 "back from FUNCALL to *INTERNAL-GC*")
 370             (let* ((post-gc-dyn-usage (dynamic-usage))
 371                    (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
 372               (when *last-bytes-in-use*
 373                 (incf *total-bytes-consed*
 374                       (- pre-gc-dyn-usage *last-bytes-in-use*))
 375                 (setq *last-bytes-in-use* post-gc-dyn-usage))
 376               (setf *need-to-collect-garbage* nil)
 377               (let ((new-gc-trigger (+ post-gc-dyn-usage
 378                                        *bytes-consed-between-gcs*)))
 379                 (setf *gc-trigger* new-gc-trigger))
 380               (set-auto-gc-trigger *gc-trigger*)
 381               (dolist (hook *after-gc-hooks*)
 382                 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
 383                 ;; FIXME: This hook should be called with the
 384                 ;; same kind of information as *GC-NOTIFY-AFTER*.
 385                 ;; In particular, it would be nice for the
 386                 ;; hook function to be able to adjust *GC-TRIGGER*
 387                 ;; intelligently to e.g. 108% of total memory usage.
 388                 (carefully-funcall hook))
 389               (when *gc-notify-stream*
 390                 (/show0 "doing the *GC-NOTIFY-AFTER* thing")
 391                 (if (streamp *gc-notify-stream*)
 392                     (carefully-funcall *gc-notify-after*
 393                                        *gc-notify-stream*
 394                                        post-gc-dyn-usage
 395                                        bytes-freed
 396                                        *gc-trigger*)
 397                     (warn
 398                      "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
 399           (/show0 "scrubbing control stack")
 400           (scrub-control-stack)))
 401       (/show0 "updating *GC-RUN-TIME*")
 402       (incf *gc-run-time* (- (get-internal-run-time)
 403                              start-time))))
 404   ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
 405   (/show "returning from tail of SUB-GC")
 406   nil)
 407
 408 ;;; This routine is called by the allocation miscops to decide whether
 409 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
 410 ;;; object which must be returned to the caller.
 411 (defun maybe-gc (&optional object)
 412   (sub-gc)
 413   object)
 414
 415 ;;; This is the user-advertised garbage collection function.
 416 ;;;
 417 ;;; KLUDGE: GC shouldn't have different parameters depending on what
 418 ;;; garbage collector we use. -- WHN 19991020
 419 #!-gencgc
 420 (defun gc (&optional (verbose-p *gc-verbose*))
 421   #!+sb-doc
 422   "Initiates a garbage collection. VERBOSE-P controls
 423   whether or not GC statistics are printed."
 424   (sub-gc :verbose-p verbose-p :force-p t))
 425 #!+gencgc
 426 (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
 427   #!+sb-doc
 428   "Initiates a garbage collection. VERBOSE controls whether or not GC
 429   statistics are printed. GEN controls the number of generations to garbage
 430   collect."
 431   ;; FIXME: The bare 6 here (corresponding to a bare 6 in
 432   ;; the gencgc.c sources) is nasty.
 433   (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
 434 \f
 435 ;;;; auxiliary functions
 436
 437 (defun bytes-consed-between-gcs ()
 438   #!+sb-doc
 439   "Return the amount of memory that will be allocated before the next garbage
 440    collection is initiated. This can be set with SETF."
 441   *bytes-consed-between-gcs*)
 442 (defun (setf bytes-consed-between-gcs) (val)
 443   ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
 444   ;; be for a strictly positive number type, e.g.
 445   ;; (AND (INTEGER 1) FIXNUM)?
 446   (declare (type index val))
 447   (let ((old *bytes-consed-between-gcs*))
 448     (setf *bytes-consed-between-gcs* val)
 449     (when *gc-trigger*
 450       (setf *gc-trigger* (+ *gc-trigger* (- val old)))
 451       (cond ((<= (dynamic-usage) *gc-trigger*)
 452              (clear-auto-gc-trigger)
 453              (set-auto-gc-trigger *gc-trigger*))
 454             (t
 455              (sb!sys:scrub-control-stack)
 456              (sub-gc)))))
 457   val)
 458
 459 (defun gc-on ()
 460   #!+sb-doc
 461   "Enables the garbage collector."
 462   (setq *gc-inhibit* nil)
 463   (when *need-to-collect-garbage*
 464     (sub-gc))
 465   nil)
 466
 467 (defun gc-off ()
 468   #!+sb-doc
 469   "Disables the garbage collector."
 470   (setq *gc-inhibit* t)
 471   nil)
 472 \f
 473 ;;;; initialization stuff
 474
 475 (defun gc-cold-init-or-reinit ()
 476   (when *gc-trigger*
 477     (if (< *gc-trigger* (dynamic-usage))
 478         (sub-gc)
 479         (set-auto-gc-trigger *gc-trigger*))))