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 #!-gencgc
  27 (progn
  28   ;; This is called once per PROFILEd function call, so it's worth a
  29   ;; little possible space cost to reduce its time cost.
  30   #!-sb-fluid
  31   (declaim (inline current-dynamic-space-start))
  32   (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
  33
  34 #!-sb-fluid
  35 (declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
  36 #!+(or cgc gencgc)
  37 (def-c-var-frob dynamic-usage "bytes_allocated")
  38 #!-(or cgc gencgc)
  39 (defun dynamic-usage ()
  40   (the (unsigned-byte 32)
  41        (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
  42           (current-dynamic-space-start))))
  43
  44 (defun static-space-usage ()
  45   (- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
  46      sb!vm:static-space-start))
  47
  48 (defun read-only-space-usage ()
  49   (- (* sb!vm::*read-only-space-free-pointer* sb!vm:word-bytes)
  50      sb!vm:read-only-space-start))
  51
  52 (defun control-stack-usage ()
  53   #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
  54             sb!vm:control-stack-start)
  55   #!+x86 (- sb!vm:control-stack-end
  56             (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
  57
  58 (defun binding-stack-usage ()
  59   (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
  60      sb!vm:binding-stack-start))
  61 \f
  62 ;;;; ROOM
  63
  64 (defun room-minimal-info ()
  65   (format t "Dynamic space usage is:   ~10:D bytes.~%" (dynamic-usage))
  66   (format t "Read-only space usage is: ~10:D bytes.~%" (read-only-space-usage))
  67   (format t "Static space usage is:    ~10:D bytes.~%" (static-space-usage))
  68   (format t "Control stack usage is:   ~10:D bytes.~%" (control-stack-usage))
  69   (format t "Binding stack usage is:   ~10:D bytes.~%" (binding-stack-usage))
  70   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
  71           *gc-inhibit*))
  72
  73 (defun room-intermediate-info ()
  74   (room-minimal-info)
  75   (sb!vm:memory-usage :count-spaces '(:dynamic)
  76                       :print-spaces t
  77                       :cutoff 0.05s0
  78                       :print-summary nil))
  79
  80 (defun room-maximal-info ()
  81   (room-minimal-info)
  82   (sb!vm:memory-usage :count-spaces '(:static :dynamic))
  83   (sb!vm:instance-usage :dynamic :top-n 10)
  84   (sb!vm:instance-usage :static :top-n 10))
  85
  86 (defun room (&optional (verbosity :default))
  87   #!+sb-doc
  88   "Print to *STANDARD-OUTPUT* information about the state of internal
  89   storage and its management. The optional argument controls the
  90   verbosity of output. If it is T, ROOM prints out a maximal amount of
  91   information. If it is NIL, ROOM prints out a minimal amount of
  92   information. If it is :DEFAULT or it is not supplied, ROOM prints out
  93   an intermediate amount of information."
  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 ;;; the total number of bytes freed so far (including any freeing
 107 ;;; which goes on in PURIFY)
 108 ;;;
 109 ;;; (We save this so that we can calculate the total number of bytes
 110 ;;; ever allocated by adding this to the number of bytes currently
 111 ;;; allocated and never freed.)
 112 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
 113 (defvar *n-bytes-freed-or-purified* 0)
 114 (push (lambda ()
 115         (setf *n-bytes-freed-or-purified* 0))
 116       ;; KLUDGE: It's probably not quite safely right either to do
 117       ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
 118       ;; worse, something which depended on (GET-BYTES-CONSED), might
 119       ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
 120       ;; it's probably not a big problem, and there seems to be no
 121       ;; other obvious time to do it. -- WHN 2001-07-30
 122       *after-save-initializations*)
 123
 124 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 125 (defun get-bytes-consed ()
 126   #!+sb-doc
 127   "Return the number of bytes consed since the program began. Typically
 128 this result will be a consed bignum, so if you have an application (e.g.
 129 profiling) which can't tolerate the overhead of consing bignums, you'll
 130 probably want either to hack in at a lower level (as the code in the
 131 SB-PROFILE package does), or to design a more microefficient interface
 132 and submit it as a patch."
 133   (+ (dynamic-usage)
 134      *n-bytes-freed-or-purified*))
 135 \f
 136 ;;;; variables and constants
 137
 138 ;;; the minimum amount of dynamic space which must be consed before a
 139 ;;; GC will be triggered
 140 ;;;
 141 ;;; Unlike CMU CL, we don't export this variable. (There's no need to,
 142 ;;; since our BYTES-CONSED-BETWEEN-GCS function is SETFable.)
 143 (defvar *bytes-consed-between-gcs* (* 4 (expt 10 6)))
 144 (declaim (type index *bytes-consed-between-gcs*))
 145
 146 ;;;; GC hooks
 147
 148 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 149   #!+sb-doc
 150   "A list of functions that are called before garbage collection occurs.
 151   The functions should take no arguments.")
 152
 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 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
 159   #!+sb-doc
 160   "When non-NIL, this must be a STREAM; and the functions bound to
 161   *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
 162   STREAM value before and after a garbage collection occurs
 163   respectively.")
 164
 165 (defvar *gc-run-time* 0
 166   #!+sb-doc
 167   "the total CPU time spent doing garbage collection (as reported by
 168    GET-INTERNAL-RUN-TIME)")
 169 (declaim (type index *gc-run-time*))
 170
 171 ;;; a limit to help catch programs which allocate too much memory,
 172 ;;; since a hard heap overflow is so hard to recover from
 173 (declaim (type (or unsigned-byte null) *soft-heap-limit*))
 174 (defvar *soft-heap-limit* nil)
 175
 176 ;;; When the dynamic usage increases beyond this amount, the system
 177 ;;; notes that a garbage collection needs to occur by setting
 178 ;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 179 ;;; nobody has figured out what it should be yet.
 180 (defvar *gc-trigger* nil)
 181
 182 (declaim (type (or index null) *gc-trigger*))
 183
 184 ;;; On the X86, we store the GC trigger in a ``static'' symbol instead
 185 ;;; of letting magic C code handle it. It gets initialized by the
 186 ;;; startup code.
 187 #!+x86
 188 (defvar sb!vm::*internal-gc-trigger*)
 189
 190 ;;;; The following specials are used to control when garbage collection
 191 ;;;; occurs.
 192
 193 ;;; When non-NIL, inhibits garbage collection.
 194 (defvar *gc-inhibit*) ; initialized in cold init
 195
 196 ;;; This flag is used to prevent recursive entry into the garbage
 197 ;;; collector.
 198 (defvar *already-maybe-gcing*) ; initialized in cold init
 199
 200 ;;; When T, indicates that the dynamic usage has exceeded the value
 201 ;;; *GC-TRIGGER*.
 202 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 203 \f
 204 (defun default-gc-notify-before (notify-stream bytes-in-use)
 205   (declare (type stream notify-stream))
 206   (format notify-stream
 207           "~&; GC is beginning with ~:D bytes in use at internal runtime ~:D.~%"
 208           bytes-in-use
 209           (get-internal-run-time))
 210   (finish-output notify-stream))
 211 (defparameter *gc-notify-before* #'default-gc-notify-before
 212   #!+sb-doc
 213   "This function bound to this variable is invoked before GC'ing (unless
 214   *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
 215   current amount of dynamic usage (in bytes). It should notify the
 216   user that the system is going to GC.")
 217
 218 (defun default-gc-notify-after (notify-stream
 219                                 bytes-retained
 220                                 bytes-freed
 221                                 new-trigger)
 222   (declare (type stream notify-stream))
 223   (format notify-stream
 224           "~&; GC has finished with ~:D bytes in use (~:D bytes freed)~@
 225            ; at internal runtime ~:D. The new GC trigger is ~:D bytes.~%"
 226           bytes-retained
 227           bytes-freed
 228           (get-internal-run-time)
 229           new-trigger)
 230   (finish-output notify-stream))
 231 (defparameter *gc-notify-after* #'default-gc-notify-after
 232   #!+sb-doc
 233   "The function bound to this variable is invoked after GC'ing with
 234 the value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in
 235 bytes) now free, the number of bytes freed by the GC, and the new GC
 236 trigger threshold. The function should notify the user that the system
 237 has finished GC'ing.")
 238 \f
 239 ;;;; internal GC
 240
 241 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
 242   #!+gencgc (last-gen sb!c-call:int))
 243
 244 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
 245   (dynamic-usage sb!c-call:unsigned-long))
 246
 247 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
 248
 249 ;;; This variable contains the function that does the real GC. This is
 250 ;;; for low-level GC experimentation. Do not touch it if you do not
 251 ;;; know what you are doing.
 252 (defvar *internal-gc* #'collect-garbage)
 253 \f
 254 ;;;; SUB-GC
 255
 256 ;;; Used to carefully invoke hooks.
 257 (eval-when (:compile-toplevel :execute)
 258   (sb!xc:defmacro carefully-funcall (function &rest args)
 259     `(handler-case (funcall ,function ,@args)
 260        (error (cond)
 261               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 262               nil))))
 263
 264 ;;; SUB-GC decides when and if to do a garbage collection. The FORCE-P
 265 ;;; flags controls whether a GC should occur even if the dynamic usage
 266 ;;; is not greater than *GC-TRIGGER*.
 267 ;;;
 268 ;;; For GENCGC all generations < GEN will be GC'ed.
 269 (defun sub-gc (&key force-p (gen 0))
 270   (/show0 "entering SUB-GC")
 271   (unless *already-maybe-gcing*
 272     (let* ((*already-maybe-gcing* t)
 273            (start-time (get-internal-run-time))
 274            (pre-gc-dynamic-usage (dynamic-usage))
 275            ;; Currently we only check *SOFT-HEAP-LIMIT* at GC time,
 276            ;; not for every allocation. That makes it cheap to do,
 277            ;; even if it is a little ugly.
 278            (soft-heap-limit-exceeded? (and *soft-heap-limit*
 279                                            (> pre-gc-dynamic-usage
 280                                               *soft-heap-limit*)))
 281            (*soft-heap-limit* (if soft-heap-limit-exceeded?
 282                                   (+ pre-gc-dynamic-usage
 283                                      *bytes-consed-between-gcs*)
 284                                   *soft-heap-limit*)))
 285       (when soft-heap-limit-exceeded?
 286         (cerror "Continue with GC."
 287                 "soft heap limit exceeded (temporary new limit=~D)"
 288                 *soft-heap-limit*))
 289       (when (and *gc-trigger* (> pre-gc-dynamic-usage *gc-trigger*))
 290         (setf *need-to-collect-garbage* t))
 291       (when (or force-p
 292                 (and *need-to-collect-garbage* (not *gc-inhibit*)))
 293         ;; KLUDGE: Wow, we really mask interrupts all the time we're
 294         ;; collecting garbage? That seems like a long time.. -- WHN 19991129
 295         (without-interrupts
 296          ;; FIXME: We probably shouldn't do this evil thing to
 297          ;; *STANDARD-OUTPUT* in a binding which is wrapped around
 298          ;; calls to user-settable GC hook functions.
 299           (let ((*standard-output* *terminal-io*))
 300             (when *gc-notify-stream*
 301               (if (streamp *gc-notify-stream*)
 302                   (carefully-funcall *gc-notify-before*
 303                                      *gc-notify-stream*
 304                                      pre-gc-dynamic-usage)
 305                   (warn
 306                    "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
 307             (dolist (hook *before-gc-hooks*)
 308               (carefully-funcall hook))
 309             (when *gc-trigger*
 310               (clear-auto-gc-trigger))
 311             (let* (;; We do DYNAMIC-USAGE once more here in order to
 312                    ;; get a more accurate measurement of the space
 313                    ;; actually freed, since the messing around, e.g.
 314                    ;; GC-notify stuff, since the DYNAMIC-USAGE which
 315                    ;; triggered GC could've done a fair amount of
 316                    ;; consing.)
 317                    (pre-internal-gc-dynamic-usage (dynamic-usage))
 318                    (ignore-me
 319                     #!-gencgc (funcall *internal-gc*)
 320                     ;; FIXME: This EQ test is pretty gross. Among its other
 321                     ;; nastinesses, it looks as though it could break if we
 322                     ;; recompile COLLECT-GARBAGE. We should probably just
 323                     ;; straighten out the interface so that all *INTERNAL-GC*
 324                     ;; functions accept a GEN argument (and then the
 325                     ;; non-generational ones just ignore it).
 326                     #!+gencgc (if (eq *internal-gc* #'collect-garbage)
 327                                   (funcall *internal-gc* gen)
 328                                   (funcall *internal-gc*)))
 329                    (post-gc-dynamic-usage (dynamic-usage))
 330                    (n-bytes-freed (- pre-internal-gc-dynamic-usage
 331                                      post-gc-dynamic-usage))
 332                    ;; In sbcl-0.6.12.39, the raw N-BYTES-FREED from
 333                    ;; GENCGC could sometimes be substantially negative
 334                    ;; (e.g. -5872). I haven't looked into what causes
 335                    ;; that, but I suspect it has to do with
 336                    ;; fluctuating inefficiency in the way that the
 337                    ;; GENCGC packs things into page boundaries.
 338                    ;; Bumping the raw result up to 0 is a little ugly,
 339                    ;; but shouldn't be a problem, and it's even
 340                    ;; possible to sort of justify it: the packing
 341                    ;; inefficiency which has caused (DYNAMIC-USAGE) to
 342                    ;; grow is effectively consing, or at least
 343                    ;; overhead of consing, so it's sort of correct to
 344                    ;; add it to the running total of consing. ("Man
 345                    ;; isn't a rational animal, he's a rationalizing
 346                    ;; animal.":-) -- WHN 2001-06-23
 347                    (eff-n-bytes-freed (max 0 n-bytes-freed)))
 348               (declare (ignore ignore-me))
 349               (/show0 "got (DYNAMIC-USAGE) and EFF-N-BYTES-FREED")
 350               (incf *n-bytes-freed-or-purified*
 351                     eff-n-bytes-freed)
 352               (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
 353               (setf *need-to-collect-garbage* nil)
 354               (/show0 "calculating NEW-GC-TRIGGER")
 355               (let ((new-gc-trigger (+ post-gc-dynamic-usage
 356                                        *bytes-consed-between-gcs*)))
 357                 (/show0 "setting *GC-TRIGGER*")
 358                 (setf *gc-trigger* new-gc-trigger))
 359               (/show0 "calling SET-AUTO-GC-TRIGGER")
 360               (set-auto-gc-trigger *gc-trigger*)
 361               (dolist (hook *after-gc-hooks*)
 362                 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
 363                 ;; FIXME: This hook should be called with the same
 364                 ;; kind of information as *GC-NOTIFY-AFTER*. In
 365                 ;; particular, it would be nice for the hook function
 366                 ;; to be able to adjust *GC-TRIGGER* intelligently to
 367                 ;; e.g. 108% of total memory usage.
 368                 (carefully-funcall hook))
 369               (when *gc-notify-stream*
 370                 (if (streamp *gc-notify-stream*)
 371                     (carefully-funcall *gc-notify-after*
 372                                        *gc-notify-stream*
 373                                        post-gc-dynamic-usage
 374                                        eff-n-bytes-freed
 375                                        *gc-trigger*)
 376                     (warn
 377                      "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
 378           (scrub-control-stack)))       ;XXX again?  we did this from C ...
 379       (incf *gc-run-time* (- (get-internal-run-time)
 380                              start-time))))
 381   ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
 382   nil)
 383
 384 ;;; This routine is called by the allocation miscops to decide whether
 385 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
 386 ;;; object which must be returned to the caller.
 387 (defun maybe-gc (&optional object)
 388   (sub-gc)
 389   object)
 390
 391 ;;; This is the user-advertised garbage collection function.
 392 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 393   #!+(and sb-doc gencgc)
 394   "Initiate a garbage collection. GEN controls the number of generations
 395   to garbage collect."
 396   #!+(and sb-doc (not gencgc))
 397   "Initiate a garbage collection. GEN may be provided for compatibility with
 398   generational garbage collectors, but is ignored in this implementation."
 399   (sub-gc :force-p t :gen (if full 6 gen)))
 400
 401 \f
 402 ;;;; auxiliary functions
 403
 404 (defun bytes-consed-between-gcs ()
 405   #!+sb-doc
 406   "Return the amount of memory that will be allocated before the next garbage
 407    collection is initiated. This can be set with SETF."
 408   *bytes-consed-between-gcs*)
 409 (defun (setf bytes-consed-between-gcs) (val)
 410   ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
 411   ;; be for a strictly positive number type, e.g.
 412   ;; (AND (INTEGER 1) FIXNUM)?
 413   (declare (type index val))
 414   (let ((old *bytes-consed-between-gcs*))
 415     (setf *bytes-consed-between-gcs* val)
 416     (when *gc-trigger*
 417       (setf *gc-trigger* (+ *gc-trigger* (- val old)))
 418       (cond ((<= (dynamic-usage) *gc-trigger*)
 419              (clear-auto-gc-trigger)
 420              (set-auto-gc-trigger *gc-trigger*))
 421             (t
 422              ;; FIXME: If SCRUB-CONTROL-STACK is required here, why
 423              ;; isn't it built into SUB-GC? And *is* it required here?
 424              (sb!sys:scrub-control-stack)
 425              (sub-gc)))))
 426   val)
 427
 428 (defun gc-on ()
 429   #!+sb-doc
 430   "Enable the garbage collector."
 431   (setq *gc-inhibit* nil)
 432   (when *need-to-collect-garbage*
 433     (sub-gc))
 434   nil)
 435
 436 (defun gc-off ()
 437   #!+sb-doc
 438   "Disable the garbage collector."
 439   (setq *gc-inhibit* t)
 440   nil)
 441 \f
 442 ;;;; initialization stuff
 443
 444 (defun gc-reinit ()
 445   (when *gc-trigger*
 446     (if (< *gc-trigger* (dynamic-usage))
 447         (sub-gc)
 448         (set-auto-gc-trigger *gc-trigger*))))