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