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