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   "Print to *STANDARD-OUTPUT* information about the state of internal
  85   storage and its management. The optional argument controls the
  86   verbosity of output. 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."
  90   (fresh-line)
  91   (ecase verbosity
  92     ((t)
  93      (room-maximal-info))
  94     ((nil)
  95      (room-minimal-info))
  96     (:default
  97      (room-intermediate-info)))
  98   (values))
  99 \f
 100 ;;;; GET-BYTES-CONSED
 101
 102 ;;; internal state
 103 (defvar *last-bytes-in-use* nil)
 104 (defvar *total-bytes-consed* 0)
 105 (declaim (type (or index null) *last-bytes-in-use*))
 106 (declaim (type unsigned-byte *total-bytes-consed*))
 107
 108 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 109 (defun get-bytes-consed ()
 110   #!+sb-doc
 111   "Return the number of bytes consed since the first time this function
 112   was called. The first time it is called, it returns zero."
 113   (declare (optimize (speed 3) (safety 0)))
 114   (cond ((null *last-bytes-in-use*)
 115          (setq *last-bytes-in-use* (dynamic-usage))
 116          (setq *total-bytes-consed* 0))
 117         (t
 118          (let ((bytes (dynamic-usage)))
 119            (incf *total-bytes-consed*
 120                  (the index (- bytes *last-bytes-in-use*)))
 121            (setq *last-bytes-in-use* bytes))))
 122   ;; FIXME: We should really use something like PCOUNTER to make this
 123   ;; hold reliably.
 124   (aver (not (minusp *total-bytes-consed*)))
 125   *total-bytes-consed*)
 126 \f
 127 ;;;; variables and constants
 128
 129 ;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
 130 (defconstant default-bytes-consed-between-gcs 2000000)
 131
 132 ;;; the minimum amount of dynamic space which must be consed before a
 133 ;;; GC will be triggered
 134 ;;;
 135 ;;; Unlike CMU CL, we don't export this variable. (There's no need to,
 136 ;;; since the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
 137 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs)
 138 (declaim (type index *bytes-consed-between-gcs*))
 139
 140 ;;;; GC hooks
 141
 142 ;;; These variables are a list of functions which are run before and
 143 ;;; after garbage collection occurs.
 144 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 145   #!+sb-doc
 146   "A list of functions that are called before garbage collection occurs.
 147   The functions should take no arguments.")
 148 (defvar *after-gc-hooks* nil ; actually initialized in cold init
 149   #!+sb-doc
 150   "A list of functions that are called after garbage collection occurs.
 151   The functions should take no arguments.")
 152
 153 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
 154 ;;; was explicitly forced by calling SB!EXT:GC). If the hook function
 155 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
 156 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
 157 ;;; Presumably someone will call GC-ON later to collect the garbage.
 158 (defvar *gc-inhibit-hook* nil
 159   #!+sb-doc
 160   "This should be bound to a function or NIL. If it is a function, this
 161   function should take one argument, the current amount of dynamic
 162   usage. The function should return NIL if garbage collection should
 163   continue and non-NIL if it should be inhibited. Use with caution.")
 164
 165 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
 166   #!+sb-doc
 167   "When non-NIL, this must be a STREAM; and the functions bound to
 168   *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
 169   STREAM value before and after a garbage collection occurs
 170   respectively.")
 171
 172 (defvar *gc-run-time* 0
 173   #!+sb-doc
 174   "the total CPU time spent doing garbage collection (as reported by
 175    GET-INTERNAL-RUN-TIME)")
 176 (declaim (type index *gc-run-time*))
 177
 178 ;;; a limit to help catch programs which allocate too much memory,
 179 ;;; since a hard heap overflow is so hard to recover from.
 180 (declaim (type (or unsigned-byte null) *soft-heap-limit*))
 181 (defvar *soft-heap-limit* nil)
 182
 183 ;;; Internal trigger. When the dynamic usage increases beyond this
 184 ;;; amount, the system notes that a garbage collection needs to occur by
 185 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 186 ;;; nobody has figured out what it should be yet.
 187 (defvar *gc-trigger* nil)
 188
 189 (declaim (type (or index null) *gc-trigger*))
 190
 191 ;;; On the X86, we store the GC trigger in a ``static'' symbol instead
 192 ;;; of letting magic C code handle it. It gets initialized by the
 193 ;;; startup code.
 194 #!+x86
 195 (defvar sb!vm::*internal-gc-trigger*)
 196
 197 ;;;; The following specials are used to control when garbage collection
 198 ;;;; occurs.
 199
 200 ;;; When non-NIL, inhibits garbage collection.
 201 (defvar *gc-inhibit*) ; initialized in cold init
 202
 203 ;;; This flag is used to prevent recursive entry into the garbage
 204 ;;; collector.
 205 (defvar *already-maybe-gcing*) ; initialized in cold init
 206
 207 ;;; When T, indicates that the dynamic usage has exceeded the value
 208 ;;; *GC-TRIGGER*.
 209 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 210 \f
 211 (defun default-gc-notify-before (notify-stream bytes-in-use)
 212   (declare (type stream notify-stream))
 213   (format notify-stream
 214           "~&; GC is beginning with ~:D bytes in use.~%"
 215           bytes-in-use)
 216   (finish-output notify-stream))
 217 (defparameter *gc-notify-before* #'default-gc-notify-before
 218   #!+sb-doc
 219   "This function bound to this variable is invoked before GC'ing (unless
 220   *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
 221   current amount of dynamic usage (in bytes). It should notify the
 222   user that the system is going to GC.")
 223
 224 (defun default-gc-notify-after (notify-stream
 225                                 bytes-retained
 226                                 bytes-freed
 227                                 new-trigger)
 228   (declare (type stream notify-stream))
 229   (format notify-stream
 230           "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
 231           bytes-retained
 232           bytes-freed)
 233   (format notify-stream
 234           "~&; The new GC trigger is ~:D bytes.~%"
 235           new-trigger)
 236   (finish-output notify-stream))
 237 (defparameter *gc-notify-after* #'default-gc-notify-after
 238   #!+sb-doc
 239   "The function bound to this variable is invoked after GC'ing with
 240 the value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in
 241 bytes) now free, the number of bytes freed by the GC, and the new GC
 242 trigger threshold. The function should notify the user that the system
 243 has finished GC'ing.")
 244 \f
 245 ;;;; internal GC
 246
 247 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
 248   #!+gencgc (last-gen sb!c-call:int))
 249
 250
 251 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
 252   (dynamic-usage sb!c-call:unsigned-long))
 253
 254 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
 255
 256 ;;; This variable contains the function that does the real GC. This is
 257 ;;; for low-level GC experimentation. Do not touch it if you do not
 258 ;;; know what you are doing.
 259 (defvar *internal-gc* #'collect-garbage)
 260 \f
 261 ;;;; SUB-GC
 262
 263 ;;; Used to carefully invoke hooks.
 264 (eval-when (:compile-toplevel :execute)
 265   (sb!xc:defmacro carefully-funcall (function &rest args)
 266     `(handler-case (funcall ,function ,@args)
 267        (error (cond)
 268               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 269               nil))))
 270
 271 ;;; SUB-GC decides when and if to do a garbage collection.
 272 ;;; The FORCE-P flags controls if a GC should occur even if
 273 ;;; the dynamic usage is not greater than *GC-TRIGGER*.
 274 ;;;
 275 ;;; For GENCGC all generations < GEN will be GC'ed.
 276 (defun sub-gc (&key  force-p (gen 0))
 277   (/show0 "entering SUB-GC")
 278   (unless *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         (setf *need-to-collect-garbage* t))
 321       (when (or force-p
 322                 (and *need-to-collect-garbage* (not *gc-inhibit*)))
 323         (when (and (not force-p)
 324                    *gc-inhibit-hook*
 325                    (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
 326           (setf *gc-inhibit* t)
 327           (return-from sub-gc nil))
 328         ;; KLUDGE: Wow, we really mask interrupts all the time we're
 329         ;; collecting garbage? That seems like a long time.. -- WHN 19991129
 330         (without-interrupts
 331          ;; FIXME: We probably shouldn't do this evil thing to
 332          ;; *STANDARD-OUTPUT* in a binding which is wrapped around
 333          ;; calls to user-settable GC hook functions.
 334           (let ((*standard-output* *terminal-io*))
 335             (when *gc-notify-stream*
 336               (if (streamp *gc-notify-stream*)
 337                   (carefully-funcall *gc-notify-before*
 338                                      *gc-notify-stream*
 339                                      pre-gc-dyn-usage)
 340                   (warn
 341                    "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
 342             (dolist (hook *before-gc-hooks*)
 343               (carefully-funcall hook))
 344             (when *gc-trigger*
 345               (clear-auto-gc-trigger))
 346             #!-gencgc (funcall *internal-gc*)
 347             ;; FIXME: This EQ test is pretty gross. Among its other
 348             ;; nastinesses, it looks as though it could break if we
 349             ;; recompile COLLECT-GARBAGE.
 350             #!+gencgc (if (eq *internal-gc* #'collect-garbage)
 351                           (funcall *internal-gc* gen)
 352                           (funcall *internal-gc*))
 353             (let* ((post-gc-dyn-usage (dynamic-usage))
 354                    (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
 355               (/show0 "got (DYNAMIC-USAGE) and BYTES-FREED")
 356               (when *last-bytes-in-use*
 357                 (/show0 "doing *LAST-BYTES-IN-USE* thing")
 358                 (incf *total-bytes-consed*
 359                       (- pre-gc-dyn-usage *last-bytes-in-use*))
 360                 (/show0 "setting *LAST-BYTES-IN-USE*")
 361                 (setq *last-bytes-in-use* post-gc-dyn-usage))
 362               (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
 363               (setf *need-to-collect-garbage* nil)
 364               (/show0 "calculating NEW-GC-TRIGGER")
 365               (let ((new-gc-trigger (+ post-gc-dyn-usage
 366                                        *bytes-consed-between-gcs*)))
 367                 (/show0 "setting *GC-TRIGGER*")
 368                 (setf *gc-trigger* new-gc-trigger))
 369               (/show0 "calling SET-AUTO-GC-TRIGGER")
 370               (set-auto-gc-trigger *gc-trigger*)
 371               (dolist (hook *after-gc-hooks*)
 372                 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
 373                 ;; FIXME: This hook should be called with the same
 374                 ;; kind of information as *GC-NOTIFY-AFTER*. In
 375                 ;; particular, it would be nice for the hook function
 376                 ;; to be able to adjust *GC-TRIGGER* intelligently to
 377                 ;; e.g. 108% of total memory usage.
 378                 (carefully-funcall hook))
 379               (when *gc-notify-stream*
 380                 (if (streamp *gc-notify-stream*)
 381                     (carefully-funcall *gc-notify-after*
 382                                        *gc-notify-stream*
 383                                        post-gc-dyn-usage
 384                                        bytes-freed
 385                                        *gc-trigger*)
 386                     (warn
 387                      "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
 388           (scrub-control-stack)))       ;XXX again?  we did this from C ...
 389       (incf *gc-run-time* (- (get-internal-run-time)
 390                              start-time))))
 391   ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
 392   nil)
 393
 394 ;;; This routine is called by the allocation miscops to decide whether
 395 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
 396 ;;; object which must be returned to the caller.
 397 (defun maybe-gc (&optional object)
 398   (sub-gc)
 399   object)
 400
 401 ;;; This is the user-advertised garbage collection function.
 402
 403 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 404   #!+(and sb-doc gencgc)
 405   "Initiate a garbage collection. GEN controls the number of generations
 406   to garbage collect."
 407   #!+(and sb-doc (not gencgc))
 408   "Initiate a garbage collection. GEN may be provided for compatibility, but
 409   is ignored."
 410   (sub-gc :force-p t :gen (if full 6 gen)))
 411
 412 \f
 413 ;;;; auxiliary functions
 414
 415 (defun bytes-consed-between-gcs ()
 416   #!+sb-doc
 417   "Return the amount of memory that will be allocated before the next garbage
 418    collection is initiated. This can be set with SETF."
 419   *bytes-consed-between-gcs*)
 420 (defun (setf bytes-consed-between-gcs) (val)
 421   ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
 422   ;; be for a strictly positive number type, e.g.
 423   ;; (AND (INTEGER 1) FIXNUM)?
 424   (declare (type index val))
 425   (let ((old *bytes-consed-between-gcs*))
 426     (setf *bytes-consed-between-gcs* val)
 427     (when *gc-trigger*
 428       (setf *gc-trigger* (+ *gc-trigger* (- val old)))
 429       (cond ((<= (dynamic-usage) *gc-trigger*)
 430              (clear-auto-gc-trigger)
 431              (set-auto-gc-trigger *gc-trigger*))
 432             (t
 433              (sb!sys:scrub-control-stack)
 434              (sub-gc)))))
 435   val)
 436
 437 (defun gc-on ()
 438   #!+sb-doc
 439   "Enable the garbage collector."
 440   (setq *gc-inhibit* nil)
 441   (when *need-to-collect-garbage*
 442     (sub-gc))
 443   nil)
 444
 445 (defun gc-off ()
 446   #!+sb-doc
 447   "Disable the garbage collector."
 448   (setq *gc-inhibit* t)
 449   nil)
 450 \f
 451 ;;;; initialization stuff
 452
 453 (defun gc-cold-init-or-reinit ()
 454   (when *gc-trigger*
 455     (if (< *gc-trigger* (dynamic-usage))
 456         (sub-gc)
 457         (set-auto-gc-trigger *gc-trigger*))))