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