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 unsigned-byte *total-bytes-consed*))
 108
 109 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 110 (defun get-bytes-consed ()
 111   #!+sb-doc
 112   "Return 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   ;; FIXME: We should really use something like PCOUNTER to make this
 124   ;; hold reliably.
 125   (aver (not (minusp *total-bytes-consed*)))
 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 ;;; the minimum amount of dynamic space which must be consed before a
 134 ;;; GC will be triggered
 135 ;;;
 136 ;;; Unlike CMU CL, we don't export this variable. (There's no need to,
 137 ;;; since the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
 138 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs)
 139 (declaim (type index *bytes-consed-between-gcs*))
 140
 141 ;;;; GC hooks
 142
 143 ;;; These variables are a list of functions which are run before and
 144 ;;; after garbage collection occurs.
 145 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 146   #!+sb-doc
 147   "A list of functions that are called before garbage collection occurs.
 148   The functions should take no arguments.")
 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 should take no arguments.")
 153
 154 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
 155 ;;; was explicitly forced by calling SB!EXT:GC). If the hook function
 156 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
 157 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
 158 ;;; Presumably someone will call GC-ON later to collect the garbage.
 159 (defvar *gc-inhibit-hook* nil
 160   #!+sb-doc
 161   "Should be bound to a function or NIL. If it is a function, this
 162   function should take one argument, the current amount of dynamic
 163   usage. The function should return NIL if garbage collection should
 164   continue and non-NIL if it should be inhibited. Use with caution.")
 165
 166 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
 167   #!+sb-doc
 168   "When non-NIL, this must be a STREAM; and the functions bound to
 169   *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
 170   STREAM value before and after a garbage collection occurs
 171   respectively.")
 172
 173 (defvar *gc-run-time* 0
 174   #!+sb-doc
 175   "The total CPU time spent doing garbage collection (as reported by
 176    GET-INTERNAL-RUN-TIME.)")
 177 (declaim (type index *gc-run-time*))
 178
 179 ;;; a limit to help catch programs which allocate too much memory,
 180 ;;; since a hard heap overflow is so hard to recover from.
 181 (declaim (type (or unsigned-byte null) *soft-heap-limit*))
 182 (defvar *soft-heap-limit* nil)
 183
 184 ;;; Internal trigger. When the dynamic usage increases beyond this
 185 ;;; amount, the system notes that a garbage collection needs to occur by
 186 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 187 ;;; nobody has figured out what it should be yet.
 188 (defvar *gc-trigger* nil)
 189
 190 (declaim (type (or index null) *gc-trigger*))
 191
 192 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
 193 ;;; letting magic C code handle it. It gets initialized by the startup
 194 ;;; code. The X86 port defines this here because it uses the `ibmrt'
 195 ;;; feature in the C code for allocation and binding stack access and
 196 ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
 197 #!+(or ibmrt x86)
 198 (defvar sb!vm::*internal-gc-trigger*)
 199
 200 ;;;; The following specials are used to control when garbage collection
 201 ;;;; occurs.
 202
 203 ;;; When non-NIL, inhibits garbage collection.
 204 (defvar *gc-inhibit*) ; initialized in cold init
 205
 206 ;;; This flag is used to prevent recursive entry into the garbage
 207 ;;; collector.
 208 (defvar *already-maybe-gcing*) ; initialized in cold init
 209
 210 ;;; When T, indicates that the dynamic usage has exceeded the value
 211 ;;; *GC-TRIGGER*.
 212 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 213 \f
 214 (defun default-gc-notify-before (notify-stream bytes-in-use)
 215   (declare (type stream notify-stream))
 216   (format notify-stream
 217           "~&; GC is beginning with ~:D bytes in use.~%"
 218           bytes-in-use)
 219   (finish-output notify-stream))
 220 (defparameter *gc-notify-before* #'default-gc-notify-before
 221   #!+sb-doc
 222   "This function bound to this variable is invoked before GC'ing (unless
 223   *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
 224   current amount of dynamic usage (in bytes). It should notify the
 225   user that the system is going to GC.")
 226
 227 (defun default-gc-notify-after (notify-stream
 228                                 bytes-retained
 229                                 bytes-freed
 230                                 new-trigger)
 231   (declare (type stream notify-stream))
 232   (format notify-stream
 233           "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
 234           bytes-retained
 235           bytes-freed)
 236   (format notify-stream
 237           "~&; The new GC trigger is ~:D bytes.~%"
 238           new-trigger)
 239   (finish-output notify-stream))
 240 (defparameter *gc-notify-after* #'default-gc-notify-after
 241   #!+sb-doc
 242   "The function bound to this variable is invoked after GC'ing with
 243 the value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in
 244 bytes) now free, the number of bytes freed by the GC, and the new GC
 245 trigger threshold. The function should notify the user that the system
 246 has finished GC'ing.")
 247 \f
 248 ;;;; internal GC
 249
 250 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
 251   #!+gencgc (last-gen sb!c-call:int))
 252
 253
 254 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
 255   (dynamic-usage sb!c-call:unsigned-long))
 256
 257 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
 258
 259 ;;; This variable contains the function that does the real GC. This is
 260 ;;; for low-level GC experimentation. Do not touch it if you do not
 261 ;;; know what you are doing.
 262 (defvar *internal-gc* #'collect-garbage)
 263 \f
 264 ;;;; SUB-GC
 265
 266 ;;; Used to carefully invoke hooks.
 267 (eval-when (:compile-toplevel :execute)
 268   (sb!xc:defmacro carefully-funcall (function &rest args)
 269     `(handler-case (funcall ,function ,@args)
 270        (error (cond)
 271               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 272               nil))))
 273
 274 ;;; SUB-GC decides when and if to do a garbage collection.
 275 ;;; The FORCE-P flags controls if a GC should occur even if
 276 ;;; the dynamic usage is not greater than *GC-TRIGGER*.
 277 ;;;
 278 ;;; For GENCGC all generations < GEN will be GC'ed.
 279 (defun sub-gc (&key  force-p (gen 0))
 280   (/show0 "entering SUB-GC")
 281   (unless *already-maybe-gcing*
 282     (let* ((*already-maybe-gcing* t)
 283            (start-time (get-internal-run-time))
 284            (pre-gc-dyn-usage (dynamic-usage))
 285            ;; Currently we only check *SOFT-HEAP-LIMIT* at GC time,
 286            ;; not for every allocation. That makes it cheap to do,
 287            ;; even if it is a little ugly.
 288            (soft-heap-limit-exceeded? (and *soft-heap-limit*
 289                                            (> pre-gc-dyn-usage
 290                                               *soft-heap-limit*)))
 291            (*soft-heap-limit* (if soft-heap-limit-exceeded?
 292                                   (+ pre-gc-dyn-usage
 293                                      *bytes-consed-between-gcs*)
 294                                   *soft-heap-limit*)))
 295       (when soft-heap-limit-exceeded?
 296         (cerror "Continue with GC."
 297                 "soft heap limit exceeded (temporary new limit=~D)"
 298                 *soft-heap-limit*))
 299       (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
 300         ;; The noise w/ symbol-value above is to keep the compiler
 301         ;; from optimizing the test away because of the type declaim
 302         ;; for *bytes-consed-between-gcs*.
 303         ;;
 304         ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
 305         ;; trust it, instead of doing this weird hack. It's not
 306         ;; particularly trustable, since (SETF
 307         ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
 308         ;; very nice to have the type of the variable specified in two
 309         ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
 310         ;; INDEX) drift apart. So perhaps we should just add a note to
 311         ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
 312         ;; that it must be an INDEX, and remove the DECLAIM. Or we
 313         ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
 314         ;; and enforce the typing that way. And in fact the SETFable
 315         ;; function already exists, so all we need do is make the
 316         ;; variable private, and then we can trust the DECLAIM.
 317         (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
 318                integer. Resetting it to ~D."
 319               *bytes-consed-between-gcs*
 320                default-bytes-consed-between-gcs)
 321         (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
 322       (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
 323         (setf *need-to-collect-garbage* t))
 324       (when (or force-p
 325                 (and *need-to-collect-garbage* (not *gc-inhibit*)))
 326         (when (and (not force-p)
 327                    *gc-inhibit-hook*
 328                    (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
 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               (if (streamp *gc-notify-stream*)
 340                   (carefully-funcall *gc-notify-before*
 341                                      *gc-notify-stream*
 342                                      pre-gc-dyn-usage)
 343                   (warn
 344                    "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
 345             (dolist (hook *before-gc-hooks*)
 346               (carefully-funcall hook))
 347             (when *gc-trigger*
 348               (clear-auto-gc-trigger))
 349             #!-gencgc (funcall *internal-gc*)
 350             ;; FIXME: This EQ test is pretty gross. Among its other
 351             ;; nastinesses, it looks as though it could break if we
 352             ;; recompile COLLECT-GARBAGE.
 353             #!+gencgc (if (eq *internal-gc* #'collect-garbage)
 354                           (funcall *internal-gc* gen)
 355                           (funcall *internal-gc*))
 356             (let* ((post-gc-dyn-usage (dynamic-usage))
 357                    (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
 358               (/show0 "got (DYNAMIC-USAGE) and BYTES-FREED")
 359               (when *last-bytes-in-use*
 360                 (/show0 "doing *LAST-BYTES-IN-USE* thing")
 361                 (incf *total-bytes-consed*
 362                       (- pre-gc-dyn-usage *last-bytes-in-use*))
 363                 (/show0 "setting *LAST-BYTES-IN-USE*")
 364                 (setq *last-bytes-in-use* post-gc-dyn-usage))
 365               (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
 366               (setf *need-to-collect-garbage* nil)
 367               (/show0 "calculating NEW-GC-TRIGGER")
 368               (let ((new-gc-trigger (+ post-gc-dyn-usage
 369                                        *bytes-consed-between-gcs*)))
 370                 (/show0 "setting *GC-TRIGGER*")
 371                 (setf *gc-trigger* new-gc-trigger))
 372               (/show0 "calling SET-AUTO-GC-TRIGGER")
 373               (set-auto-gc-trigger *gc-trigger*)
 374               (dolist (hook *after-gc-hooks*)
 375                 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
 376                 ;; FIXME: This hook should be called with the same
 377                 ;; kind of information as *GC-NOTIFY-AFTER*. In
 378                 ;; particular, it would be nice for the hook function
 379                 ;; to be able to adjust *GC-TRIGGER* intelligently to
 380                 ;; e.g. 108% of total memory usage.
 381                 (carefully-funcall hook))
 382               (when *gc-notify-stream*
 383                 (if (streamp *gc-notify-stream*)
 384                     (carefully-funcall *gc-notify-after*
 385                                        *gc-notify-stream*
 386                                        post-gc-dyn-usage
 387                                        bytes-freed
 388                                        *gc-trigger*)
 389                     (warn
 390                      "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
 391           (scrub-control-stack)))       ;XXX again?  we did this from C ...
 392       (incf *gc-run-time* (- (get-internal-run-time)
 393                              start-time))))
 394   ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
 395   nil)
 396
 397 ;;; This routine is called by the allocation miscops to decide whether
 398 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
 399 ;;; object which must be returned to the caller.
 400 (defun maybe-gc (&optional object)
 401   (sub-gc)
 402   object)
 403
 404 ;;; This is the user-advertised garbage collection function.
 405
 406 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 407   #!+(and sb-doc gencgc)
 408   "Initiates a garbage collection.  GEN controls the number of generations to garbage collect"
 409   #!+(and sb-doc (not gencgc))
 410   "Initiates a garbage collection.  GEN may be provided for compatibility, but is ignored"
 411   (sub-gc :force-p t :gen (if full 6 gen)))
 412
 413 \f
 414 ;;;; auxiliary functions
 415
 416 (defun bytes-consed-between-gcs ()
 417   #!+sb-doc
 418   "Return the amount of memory that will be allocated before the next garbage
 419    collection is initiated. This can be set with SETF."
 420   *bytes-consed-between-gcs*)
 421 (defun (setf bytes-consed-between-gcs) (val)
 422   ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
 423   ;; be for a strictly positive number type, e.g.
 424   ;; (AND (INTEGER 1) FIXNUM)?
 425   (declare (type index val))
 426   (let ((old *bytes-consed-between-gcs*))
 427     (setf *bytes-consed-between-gcs* val)
 428     (when *gc-trigger*
 429       (setf *gc-trigger* (+ *gc-trigger* (- val old)))
 430       (cond ((<= (dynamic-usage) *gc-trigger*)
 431              (clear-auto-gc-trigger)
 432              (set-auto-gc-trigger *gc-trigger*))
 433             (t
 434              (sb!sys:scrub-control-stack)
 435              (sub-gc)))))
 436   val)
 437
 438 (defun gc-on ()
 439   #!+sb-doc
 440   "Enables the garbage collector."
 441   (setq *gc-inhibit* nil)
 442   (when *need-to-collect-garbage*
 443     (sub-gc))
 444   nil)
 445
 446 (defun gc-off ()
 447   #!+sb-doc
 448   "Disables the garbage collector."
 449   (setq *gc-inhibit* t)
 450   nil)
 451 \f
 452 ;;;; initialization stuff
 453
 454 (defun gc-cold-init-or-reinit ()
 455   (when *gc-trigger*
 456     (if (< *gc-trigger* (dynamic-usage))
 457         (sub-gc)
 458         (set-auto-gc-trigger *gc-trigger*))))