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
  14 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; DYNAMIC-USAGE and friends
  18
  19 (declaim (special *read-only-space-free-pointer*
  20                   *static-space-free-pointer*))
  21
  22 (eval-when (:compile-toplevel :execute)
  23   (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
  24     `(progn
  25        #!-sb-fluid (declaim (inline ,lisp-fun))
  26        (defun ,lisp-fun ()
  27          (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
  28
  29 (def-c-var-frob read-only-space-start       "read_only_space")
  30 (def-c-var-frob static-space-start          "static_space")
  31 (def-c-var-frob dynamic-0-space-start       "dynamic_0_space")
  32 (def-c-var-frob dynamic-1-space-start       "dynamic_1_space")
  33 (def-c-var-frob control-stack-start         "control_stack")
  34 #!+x86 (def-c-var-frob control-stack-end    "control_stack_end")
  35 (def-c-var-frob binding-stack-start         "binding_stack")
  36 (def-c-var-frob current-dynamic-space-start "current_dynamic_space")
  37
  38 #!-sb-fluid (declaim (inline dynamic-usage))
  39 #!-(or cgc gencgc)
  40 (defun dynamic-usage ()
  41   (the (unsigned-byte 32)
  42        (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
  43           (current-dynamic-space-start))))
  44 #!+(or cgc gencgc)
  45 (def-c-var-frob dynamic-usage "bytes_allocated")
  46
  47 (defun static-space-usage ()
  48   (- (* sb!impl::*static-space-free-pointer* sb!vm:word-bytes)
  49      (static-space-start)))
  50
  51 (defun read-only-space-usage ()
  52   (- (* sb!impl::*read-only-space-free-pointer* sb!vm:word-bytes)
  53      (read-only-space-start)))
  54
  55 (defun control-stack-usage ()
  56   #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
  57             (control-stack-start))
  58   #!+x86 (- (control-stack-end)
  59             (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
  60
  61 (defun binding-stack-usage ()
  62   (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap)) (binding-stack-start)))
  63
  64 (defun current-dynamic-space ()
  65   (let ((start (current-dynamic-space-start)))
  66     (cond ((= start (dynamic-0-space-start))
  67            0)
  68           ((= start (dynamic-1-space-start))
  69            1)
  70           (t
  71            (error "Oh no! The current dynamic space is missing!")))))
  72 \f
  73 ;;;; ROOM
  74
  75 (defun room-minimal-info ()
  76   (format t "Dynamic Space Usage:    ~10:D bytes.~%" (dynamic-usage))
  77   (format t "Read-Only Space Usage:  ~10:D bytes.~%" (read-only-space-usage))
  78   (format t "Static Space Usage:     ~10:D bytes.~%" (static-space-usage))
  79   (format t "Control Stack Usage:    ~10:D bytes.~%" (control-stack-usage))
  80   (format t "Binding Stack Usage:    ~10:D bytes.~%" (binding-stack-usage))
  81   (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
  82   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
  83           *gc-inhibit*))
  84
  85 (defun room-intermediate-info ()
  86   (room-minimal-info)
  87   (sb!vm:memory-usage :count-spaces '(:dynamic)
  88                       :print-spaces t
  89                       :cutoff 0.05s0
  90                       :print-summary nil))
  91
  92 (defun room-maximal-info ()
  93   (room-minimal-info)
  94   (sb!vm:memory-usage :count-spaces '(:static :dynamic))
  95   (sb!vm:instance-usage :dynamic :top-n 10)
  96   (sb!vm:instance-usage :static :top-n 10))
  97
  98 (defun room (&optional (verbosity :default))
  99   #!+sb-doc
 100   "Prints to *STANDARD-OUTPUT* information about the state of internal
 101   storage and its management. The optional argument controls the
 102   verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
 103   information. If it is NIL, ROOM prints out a minimal amount of
 104   information. If it is :DEFAULT or it is not supplied, ROOM prints out
 105   an intermediate amount of information. See also VM:MEMORY-USAGE and
 106   VM:INSTANCE-USAGE for finer report control."
 107   (fresh-line)
 108   (ecase verbosity
 109     ((t)
 110      (room-maximal-info))
 111     ((nil)
 112      (room-minimal-info))
 113     (:default
 114      (room-intermediate-info)))
 115   (values))
 116 \f
 117 ;;;; GET-BYTES-CONSED
 118
 119 ;;; internal state
 120 (defvar *last-bytes-in-use* nil)
 121 (defvar *total-bytes-consed* 0)
 122 (declaim (type (or index null) *last-bytes-in-use*))
 123 (declaim (type integer *total-bytes-consed*))
 124
 125 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 126 (defun get-bytes-consed ()
 127   #!+sb-doc
 128   "Returns the number of bytes consed since the first time this function
 129   was called. The first time it is called, it returns zero."
 130   (declare (optimize (speed 3) (safety 0)))
 131   (cond ((null *last-bytes-in-use*)
 132          (setq *last-bytes-in-use* (dynamic-usage))
 133          (setq *total-bytes-consed* 0))
 134         (t
 135          (let ((bytes (dynamic-usage)))
 136            (incf *total-bytes-consed*
 137                  (the index (- bytes *last-bytes-in-use*)))
 138            (setq *last-bytes-in-use* bytes))))
 139   *total-bytes-consed*)
 140 \f
 141 ;;;; variables and constants
 142
 143 ;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
 144 (defconstant default-bytes-consed-between-gcs 2000000)
 145
 146 ;;; This variable is the user-settable variable that specifies the
 147 ;;; minimum amount of dynamic space which must be consed before a GC
 148 ;;; will be triggered.
 149 ;;;
 150 ;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
 151 ;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
 152 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
 153   #!+sb-doc
 154   "This number specifies the minimum number of bytes of dynamic space
 155    that must be consed before the next GC will occur.")
 156 (declaim (type index *bytes-consed-between-gcs*))
 157
 158 ;;;; GC hooks
 159
 160 ;;; These variables are a list of functions which are run before and
 161 ;;; after garbage collection occurs.
 162 (defvar *before-gc-hooks* nil ; actually initialized in cold init
 163   #!+sb-doc
 164   "A list of functions that are called before garbage collection occurs.
 165   The functions should take no arguments.")
 166 (defvar *after-gc-hooks* nil ; actually initialized in cold init
 167   #!+sb-doc
 168   "A list of functions that are called after garbage collection occurs.
 169   The functions should take no arguments.")
 170
 171 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
 172 ;;; was explicitly forced by calling SB!EXT:GC). If the hook function
 173 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
 174 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
 175 ;;; Presumably someone will call GC-ON later to collect the garbage.
 176 (defvar *gc-inhibit-hook* nil
 177   #!+sb-doc
 178   "Should be bound to a function or NIL. If it is a function, this
 179   function should take one argument, the current amount of dynamic
 180   usage. The function should return NIL if garbage collection should
 181   continue and non-NIL if it should be inhibited. Use with caution.")
 182
 183 (defvar *gc-verbose* nil ; (actually initialized in cold init)
 184   #!+sb-doc
 185   "Should low-level GC functions produce verbose diagnostic output?")
 186
 187 (defvar *gc-notify-stream* nil ; (actually initialized in cold init)
 188   #!+sb-doc
 189   "When non-NIL, this must be a STREAM; and the functions bound to
 190   *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
 191   STREAM value before and after a garbage collection occurs
 192   respectively.")
 193
 194 (defvar *gc-run-time* 0
 195   #!+sb-doc
 196   "The total CPU time spent doing garbage collection (as reported by
 197    GET-INTERNAL-RUN-TIME.)")
 198
 199 (declaim (type index *gc-run-time*))
 200
 201 ;;; Internal trigger. When the dynamic usage increases beyond this
 202 ;;; amount, the system notes that a garbage collection needs to occur by
 203 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
 204 ;;; nobody has figured out what it should be yet.
 205 (defvar *gc-trigger* nil)
 206
 207 (declaim (type (or index null) *gc-trigger*))
 208
 209 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
 210 ;;; letting magic C code handle it. It gets initialized by the startup
 211 ;;; code. The X86 port defines this here because it uses the `ibmrt'
 212 ;;; feature in the C code for allocation and binding stack access and
 213 ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
 214 #!+(or ibmrt x86)
 215 (defvar sb!vm::*internal-gc-trigger*)
 216
 217 ;;;; The following specials are used to control when garbage collection
 218 ;;;; occurs.
 219
 220 ;;; When non-NIL, inhibits garbage collection.
 221 (defvar *gc-inhibit*) ; initialized in cold init
 222
 223 ;;; This flag is used to prevent recursive entry into the garbage
 224 ;;; collector.
 225 (defvar *already-maybe-gcing*) ; initialized in cold init
 226
 227 ;;; When T, indicates that the dynamic usage has exceeded the value
 228 ;;; *GC-TRIGGER*.
 229 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 230 \f
 231 (defun default-gc-notify-before (notify-stream bytes-in-use)
 232   (declare (type stream notify-stream))
 233   (format notify-stream
 234           "~&; GC is beginning with ~:D bytes in use.~%"
 235           bytes-in-use)
 236   (finish-output notify-stream))
 237 (defparameter *gc-notify-before* #'default-gc-notify-before
 238   #!+sb-doc
 239   "This function bound to this variable is invoked before GC'ing (unless
 240   *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
 241   current amount of dynamic usage (in bytes). It should notify the
 242   user that the system is going to GC.")
 243
 244 (defun default-gc-notify-after (notify-stream
 245                                 bytes-retained
 246                                 bytes-freed
 247                                 new-trigger)
 248   (declare (type stream notify-stream))
 249   (format notify-stream
 250           "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
 251           bytes-retained
 252           bytes-freed)
 253   (format notify-stream
 254           "~&; The new GC trigger is ~:D bytes.~%"
 255           new-trigger)
 256   (finish-output notify-stream))
 257 (defparameter *gc-notify-after* #'default-gc-notify-after
 258   #!+sb-doc
 259   "The function bound to this variable is invoked after GC'ing (unless
 260   *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
 261   the amount of dynamic usage (in bytes) now free, the number of
 262   bytes freed by the GC, and the new GC trigger threshold. The function
 263   should notify the user that the system has finished GC'ing.")
 264 \f
 265 ;;;; internal GC
 266
 267 (sb!alien:def-alien-routine collect-garbage sb!c-call:int
 268   #!+gencgc (last-gen sb!c-call:int))
 269
 270 #!-ibmrt
 271 (sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
 272   (dynamic-usage sb!c-call:unsigned-long))
 273
 274 #!+ibmrt
 275 (defun set-auto-gc-trigger (bytes)
 276   (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
 277     (unless (and (fixnump words) (plusp words))
 278       (clear-auto-gc-trigger)
 279       (warn "attempt to set GC trigger to something bogus: ~S" bytes))
 280     (setf %rt::*internal-gc-trigger* words)))
 281
 282 #!-ibmrt
 283 (sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
 284
 285 #!+ibmrt
 286 (defun clear-auto-gc-trigger ()
 287   (setf %rt::*internal-gc-trigger* -1))
 288
 289 ;;; This variable contains the function that does the real GC. This is
 290 ;;; for low-level GC experimentation. Do not touch it if you do not
 291 ;;; know what you are doing.
 292 (defvar *internal-gc* #'collect-garbage)
 293 \f
 294 ;;;; SUB-GC
 295
 296 ;;; Used to carefully invoke hooks.
 297 (eval-when (:compile-toplevel :execute)
 298   (sb!xc:defmacro carefully-funcall (function &rest args)
 299     `(handler-case (funcall ,function ,@args)
 300        (error (cond)
 301               (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
 302               nil))))
 303
 304 ;;; SUB-GC decides when and if to do a garbage collection. The
 305 ;;; VERBOSE-P flag controls whether or not the notify functions are
 306 ;;; called. The FORCE-P flags controls if a GC should occur even if
 307 ;;; the dynamic usage is not greater than *GC-TRIGGER*.
 308 ;;;
 309 ;;; For GENCGC all generations < GEN will be GC'ed.
 310 ;;;
 311 ;;; FIXME: The VERBOSE-P stuff is no longer used.
 312 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0))
 313   (/show0 "entering SUB-GC")
 314   (unless *already-maybe-gcing*
 315     (/show0 "not *ALREADY-MAYBE-GCING*")
 316     (let* ((*already-maybe-gcing* t)
 317            (start-time (get-internal-run-time))
 318            (pre-gc-dyn-usage (dynamic-usage)))
 319       (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
 320         ;; The noise w/ symbol-value above is to keep the compiler
 321         ;; from optimizing the test away because of the type declaim
 322         ;; for *bytes-consed-between-gcs*.
 323         ;;
 324         ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
 325         ;; trust it, instead of doing this weird hack. It's not
 326         ;; particularly trustable, since (SETF
 327         ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
 328         ;; very nice to have the type of the variable specified in two
 329         ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
 330         ;; INDEX) drift apart. So perhaps we should just add a note to
 331         ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
 332         ;; that it must be an INDEX, and remove the DECLAIM. Or we
 333         ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
 334         ;; and enforce the typing that way. And in fact the SETFable
 335         ;; function already exists, so all we need do is make the
 336         ;; variable private, and then we can trust the DECLAIM.
 337         (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
 338                integer. Resetting it to ~D."
 339               *bytes-consed-between-gcs*
 340                default-bytes-consed-between-gcs)
 341         (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
 342       (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
 343         (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
 344         (setf *need-to-collect-garbage* t))
 345       (when (or force-p
 346                 (and *need-to-collect-garbage* (not *gc-inhibit*)))
 347         (/show0 "Evidently we ought to collect garbage..")
 348         (when (and (not force-p)
 349                    *gc-inhibit-hook*
 350                    (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
 351           (/show0 "..but we're inhibited.")
 352           (setf *gc-inhibit* t)
 353           (return-from sub-gc nil))
 354         ;; KLUDGE: Wow, we really mask interrupts all the time we're
 355         ;; collecting garbage? That seems like a long time.. -- WHN 19991129
 356         (without-interrupts
 357          ;; FIXME: We probably shouldn't do this evil thing to
 358          ;; *STANDARD-OUTPUT* in a binding which is wrapped around
 359          ;; calls to user-settable GC hook functions.
 360           (let ((*standard-output* *terminal-io*))
 361             (when *gc-notify-stream*
 362               (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
 363               (if (streamp *gc-notify-stream*)
 364                   (carefully-funcall *gc-notify-before*
 365                                      *gc-notify-stream*
 366                                      pre-gc-dyn-usage)
 367                   (warn
 368                    "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
 369             (dolist (hook *before-gc-hooks*)
 370               (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
 371               (carefully-funcall hook))
 372             (when *gc-trigger*
 373               (clear-auto-gc-trigger))
 374             (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
 375             #!-gencgc (funcall *internal-gc*)
 376             ;; FIXME: This EQ test is pretty gross. Among its other
 377             ;; nastinesses, it looks as though it could break if we
 378             ;; recompile COLLECT-GARBAGE.
 379             #!+gencgc (if (eq *internal-gc* #'collect-garbage)
 380                           (funcall *internal-gc* gen)
 381                           (funcall *internal-gc*))
 382             (/show0 "back from FUNCALL to *INTERNAL-GC*")
 383             (let* ((post-gc-dyn-usage (dynamic-usage))
 384                    (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
 385               (when *last-bytes-in-use*
 386                 (incf *total-bytes-consed*
 387                       (- pre-gc-dyn-usage *last-bytes-in-use*))
 388                 (setq *last-bytes-in-use* post-gc-dyn-usage))
 389               (setf *need-to-collect-garbage* nil)
 390               (let ((new-gc-trigger (+ post-gc-dyn-usage
 391                                        *bytes-consed-between-gcs*)))
 392                 (setf *gc-trigger* new-gc-trigger))
 393               (set-auto-gc-trigger *gc-trigger*)
 394               (dolist (hook *after-gc-hooks*)
 395                 (/show0 "doing a hook from *AFTER-GC--HOOKS*")
 396                 ;; FIXME: This hook should be called with the
 397                 ;; same kind of information as *GC-NOTIFY-AFTER*.
 398                 ;; In particular, it would be nice for the
 399                 ;; hook function to be able to adjust *GC-TRIGGER*
 400                 ;; intelligently to e.g. 108% of total memory usage.
 401                 (carefully-funcall hook))
 402               (when *gc-notify-stream*
 403                 (/show0 "doing the *GC-NOTIFY-AFTER* thing")
 404                 (if (streamp *gc-notify-stream*)
 405                     (carefully-funcall *gc-notify-after*
 406                                        *gc-notify-stream*
 407                                        post-gc-dyn-usage
 408                                        bytes-freed
 409                                        *gc-trigger*)
 410                     (warn
 411                      "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
 412           (/show0 "scrubbing control stack")
 413           (scrub-control-stack)))
 414       (/show0 "updating *GC-RUN-TIME*")
 415       (incf *gc-run-time* (- (get-internal-run-time)
 416                              start-time))))
 417   ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
 418   (/show "returning from tail of SUB-GC")
 419   nil)
 420
 421 ;;; This routine is called by the allocation miscops to decide whether
 422 ;;; a GC should occur. The argument, OBJECT, is the newly allocated
 423 ;;; object which must be returned to the caller.
 424 (defun maybe-gc (&optional object)
 425   (sub-gc)
 426   object)
 427
 428 ;;; This is the user-advertised garbage collection function.
 429 ;;;
 430 ;;; KLUDGE: GC shouldn't have different parameters depending on what
 431 ;;; garbage collector we use. -- WHN 19991020
 432 #!-gencgc
 433 (defun gc (&optional (verbose-p *gc-verbose*))
 434   #!+sb-doc
 435   "Initiates a garbage collection. VERBOSE-P controls
 436   whether or not GC statistics are printed."
 437   (sub-gc :verbose-p verbose-p :force-p t))
 438 #!+gencgc
 439 (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
 440   #!+sb-doc
 441   "Initiates a garbage collection. VERBOSE controls whether or not GC
 442   statistics are printed. GEN controls the number of generations to garbage
 443   collect."
 444   ;; FIXME: The bare 6 here (corresponding to a bare 6 in
 445   ;; the gencgc.c sources) is nasty.
 446   (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
 447 \f
 448 ;;;; auxiliary functions
 449
 450 (defun bytes-consed-between-gcs ()
 451   #!+sb-doc
 452   "Return the amount of memory that will be allocated before the next garbage
 453    collection is initiated. This can be set with SETF."
 454   *bytes-consed-between-gcs*)
 455 (defun (setf bytes-consed-between-gcs) (val)
 456   ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
 457   ;; be for a strictly positive number type, e.g.
 458   ;; (AND (INTEGER 1) FIXNUM)?
 459   (declare (type index val))
 460   (let ((old *bytes-consed-between-gcs*))
 461     (setf *bytes-consed-between-gcs* val)
 462     (when *gc-trigger*
 463       (setf *gc-trigger* (+ *gc-trigger* (- val old)))
 464       (cond ((<= (dynamic-usage) *gc-trigger*)
 465              (clear-auto-gc-trigger)
 466              (set-auto-gc-trigger *gc-trigger*))
 467             (t
 468              (sb!sys:scrub-control-stack)
 469              (sub-gc)))))
 470   val)
 471
 472 (defun gc-on ()
 473   #!+sb-doc
 474   "Enables the garbage collector."
 475   (setq *gc-inhibit* nil)
 476   (when *need-to-collect-garbage*
 477     (sub-gc))
 478   nil)
 479
 480 (defun gc-off ()
 481   #!+sb-doc
 482   "Disables the garbage collector."
 483   (setq *gc-inhibit* t)
 484   nil)
 485 \f
 486 ;;;; initialization stuff
 487
 488 (defun gc-cold-init-or-reinit ()
 489   (when *gc-trigger*
 490     (if (< *gc-trigger* (dynamic-usage))
 491         (sub-gc)
 492         (set-auto-gc-trigger *gc-trigger*))))