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