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