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