(defun ,lisp-fun ()
(sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
-#!-sb-fluid (declaim (inline dynamic-usage))
+#!-gencgc
+(progn
+ ;; This is called once per PROFILEd function call, so it's worth a
+ ;; little possible space cost to reduce its time cost.
+ #!-sb-fluid
+ (declaim (inline current-dynamic-space-start))
+ (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
+
+#!-sb-fluid
+(declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
+#!+(or cgc gencgc)
(def-c-var-frob dynamic-usage "bytes_allocated")
+#!-(or cgc gencgc)
+(defun dynamic-usage ()
+ (the (unsigned-byte 32)
+ (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
+ (current-dynamic-space-start))))
(defun static-space-usage ()
- (- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
+ (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)
sb!vm:static-space-start))
(defun read-only-space-usage ()
- (- (* sb!vm::*read-only-space-free-pointer* sb!vm:word-bytes)
+ (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes)
sb!vm:read-only-space-start))
(defun control-stack-usage ()
(defun room (&optional (verbosity :default))
#!+sb-doc
- "Prints to *STANDARD-OUTPUT* information about the state of internal
+ "Print to *STANDARD-OUTPUT* information about the state of internal
storage and its management. The optional argument controls the
- verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
+ verbosity of output. If it is T, ROOM prints out a maximal amount of
information. If it is NIL, ROOM prints out a minimal amount of
information. If it is :DEFAULT or it is not supplied, ROOM prints out
- an intermediate amount of information. See also VM:MEMORY-USAGE and
- VM:INSTANCE-USAGE for finer report control."
+ an intermediate amount of information."
(fresh-line)
(ecase verbosity
((t)
\f
;;;; GET-BYTES-CONSED
-;;; internal state
-(defvar *last-bytes-in-use* nil)
-(defvar *total-bytes-consed* 0)
-(declaim (type (or index null) *last-bytes-in-use*))
-(declaim (type integer *total-bytes-consed*))
+;;; the total number of bytes freed so far (including any freeing
+;;; which goes on in PURIFY)
+;;;
+;;; (We save this so that we can calculate the total number of bytes
+;;; ever allocated by adding this to the number of bytes currently
+;;; allocated and never freed.)
+(declaim (type unsigned-byte *n-bytes-freed-or-purified*))
+(defvar *n-bytes-freed-or-purified* 0)
+(push (lambda ()
+ (setf *n-bytes-freed-or-purified* 0))
+ ;; KLUDGE: It's probably not quite safely right either to do
+ ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
+ ;; worse, something which depended on (GET-BYTES-CONSED), might
+ ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
+ ;; it's probably not a big problem, and there seems to be no
+ ;; other obvious time to do it. -- WHN 2001-07-30
+ *after-save-initializations*)
(declaim (ftype (function () unsigned-byte) get-bytes-consed))
(defun get-bytes-consed ()
#!+sb-doc
- "Returns the number of bytes consed since the first time this function
- was called. The first time it is called, it returns zero."
- (declare (optimize (speed 3) (safety 0)))
- (cond ((null *last-bytes-in-use*)
- (setq *last-bytes-in-use* (dynamic-usage))
- (setq *total-bytes-consed* 0))
- (t
- (let ((bytes (dynamic-usage)))
- (incf *total-bytes-consed*
- (the index (- bytes *last-bytes-in-use*)))
- (setq *last-bytes-in-use* bytes))))
- *total-bytes-consed*)
+ "Return the number of bytes consed since the program began. Typically
+this result will be a consed bignum, so if you have an application (e.g.
+profiling) which can't tolerate the overhead of consing bignums, you'll
+probably want either to hack in at a lower level (as the code in the
+SB-PROFILE package does), or to design a more microefficient interface
+and submit it as a patch."
+ (+ (dynamic-usage)
+ *n-bytes-freed-or-purified*))
\f
;;;; variables and constants
-;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
-(defconstant default-bytes-consed-between-gcs 2000000)
-
-;;; This variable is the user-settable variable that specifies the
-;;; minimum amount of dynamic space which must be consed before a GC
-;;; will be triggered.
+;;; the minimum amount of dynamic space which must be consed before a
+;;; GC will be triggered
;;;
-;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
-;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
-(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
- #!+sb-doc
- "This number specifies the minimum number of bytes of dynamic space
- that must be consed before the next GC will occur.")
+;;; Unlike CMU CL, we don't export this variable. (There's no need to,
+;;; since our BYTES-CONSED-BETWEEN-GCS function is SETFable.)
+(defvar *bytes-consed-between-gcs* (* 4 (expt 10 6)))
(declaim (type index *bytes-consed-between-gcs*))
;;;; GC hooks
-;;; These variables are a list of functions which are run before and
-;;; after garbage collection occurs.
(defvar *before-gc-hooks* nil ; actually initialized in cold init
#!+sb-doc
"A list of functions that are called before garbage collection occurs.
The functions should take no arguments.")
+
(defvar *after-gc-hooks* nil ; actually initialized in cold init
#!+sb-doc
"A list of functions that are called after garbage collection occurs.
The functions should take no arguments.")
-;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
-;;; was explicitly forced by calling SB!EXT:GC). If the hook function
-;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
-;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
-;;; Presumably someone will call GC-ON later to collect the garbage.
-(defvar *gc-inhibit-hook* nil
- #!+sb-doc
- "Should be bound to a function or NIL. If it is a function, this
- function should take one argument, the current amount of dynamic
- usage. The function should return NIL if garbage collection should
- continue and non-NIL if it should be inhibited. Use with caution.")
-
-(defvar *gc-verbose* nil ; (actually initialized in cold init)
- #!+sb-doc
- "Should low-level GC functions produce verbose diagnostic output?")
-
(defvar *gc-notify-stream* nil ; (actually initialized in cold init)
#!+sb-doc
"When non-NIL, this must be a STREAM; and the functions bound to
(defvar *gc-run-time* 0
#!+sb-doc
- "The total CPU time spent doing garbage collection (as reported by
- GET-INTERNAL-RUN-TIME.)")
-
+ "the total CPU time spent doing garbage collection (as reported by
+ GET-INTERNAL-RUN-TIME)")
(declaim (type index *gc-run-time*))
-;;; Internal trigger. When the dynamic usage increases beyond this
-;;; amount, the system notes that a garbage collection needs to occur by
-;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
+;;; a limit to help catch programs which allocate too much memory,
+;;; since a hard heap overflow is so hard to recover from
+(declaim (type (or unsigned-byte null) *soft-heap-limit*))
+(defvar *soft-heap-limit* nil)
+
+;;; When the dynamic usage increases beyond this amount, the system
+;;; notes that a garbage collection needs to occur by setting
+;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
;;; nobody has figured out what it should be yet.
(defvar *gc-trigger* nil)
(declaim (type (or index null) *gc-trigger*))
-;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
-;;; letting magic C code handle it. It gets initialized by the startup
-;;; code. The X86 port defines this here because it uses the `ibmrt'
-;;; feature in the C code for allocation and binding stack access and
-;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
-#!+(or ibmrt x86)
+;;; On the X86, we store the GC trigger in a ``static'' symbol instead
+;;; of letting magic C code handle it. It gets initialized by the
+;;; startup code.
+#!+x86
(defvar sb!vm::*internal-gc-trigger*)
;;;; The following specials are used to control when garbage collection
\f
(defun default-gc-notify-before (notify-stream bytes-in-use)
(declare (type stream notify-stream))
- (format notify-stream
- "~&; GC is beginning with ~:D bytes in use.~%"
- bytes-in-use)
+ (format
+ notify-stream
+ "~&; GC is beginning with ~:D bytes in use at internal runtime ~:D.~%"
+ bytes-in-use
+ (get-internal-run-time))
(finish-output notify-stream))
(defparameter *gc-notify-before* #'default-gc-notify-before
#!+sb-doc
new-trigger)
(declare (type stream notify-stream))
(format notify-stream
- "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
+ "~&; GC has finished with ~:D bytes in use (~:D bytes freed)~@
+ ; at internal runtime ~:D. The new GC trigger is ~:D bytes.~%"
bytes-retained
- bytes-freed)
- (format notify-stream
- "~&; The new GC trigger is ~:D bytes.~%"
+ bytes-freed
+ (get-internal-run-time)
new-trigger)
(finish-output notify-stream))
(defparameter *gc-notify-after* #'default-gc-notify-after
#!+sb-doc
- "The function bound to this variable is invoked after GC'ing (unless
- *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
- the amount of dynamic usage (in bytes) now free, the number of
- bytes freed by the GC, and the new GC trigger threshold. The function
- should notify the user that the system has finished GC'ing.")
+ "The function bound to this variable is invoked after GC'ing with the
+value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in bytes) now
+free, the number of bytes freed by the GC, and the new GC trigger
+threshold; or if *GC-NOTIFY-STREAM* is NIL, it's not invoked. The
+function should notify the user that the system has finished GC'ing.")
\f
;;;; internal GC
\f
;;;; SUB-GC
-;;; Used to carefully invoke hooks.
+;;; This is used to carefully invoke hooks.
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro carefully-funcall (function &rest args)
`(handler-case (funcall ,function ,@args)
(warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
nil))))
-;;; SUB-GC decides when and if to do a garbage collection. The
-;;; VERBOSE-P flag controls whether or not the notify functions are
-;;; called. The FORCE-P flags controls if a GC should occur even if
-;;; the dynamic usage is not greater than *GC-TRIGGER*.
+;;; SUB-GC decides when and if to do a garbage collection. The FORCE-P
+;;; flags controls whether a GC should occur even if the dynamic usage
+;;; is not greater than *GC-TRIGGER*.
;;;
;;; For GENCGC all generations < GEN will be GC'ed.
-;;;
-;;; FIXME: The VERBOSE-P stuff is no longer used.
-(defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0))
+(defun sub-gc (&key force-p (gen 0))
(/show0 "entering SUB-GC")
(unless *already-maybe-gcing*
- (/show0 "not *ALREADY-MAYBE-GCING*")
(let* ((*already-maybe-gcing* t)
(start-time (get-internal-run-time))
- (pre-gc-dyn-usage (dynamic-usage)))
- (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
- ;; The noise w/ symbol-value above is to keep the compiler
- ;; from optimizing the test away because of the type declaim
- ;; for *bytes-consed-between-gcs*.
- ;;
- ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
- ;; trust it, instead of doing this weird hack. It's not
- ;; particularly trustable, since (SETF
- ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
- ;; very nice to have the type of the variable specified in two
- ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
- ;; INDEX) drift apart. So perhaps we should just add a note to
- ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
- ;; that it must be an INDEX, and remove the DECLAIM. Or we
- ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
- ;; and enforce the typing that way. And in fact the SETFable
- ;; function already exists, so all we need do is make the
- ;; variable private, and then we can trust the DECLAIM.
- (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
- integer. Resetting it to ~D."
- *bytes-consed-between-gcs*
- default-bytes-consed-between-gcs)
- (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
- (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
- (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
+ (pre-gc-dynamic-usage (dynamic-usage))
+ ;; Currently we only check *SOFT-HEAP-LIMIT* at GC time,
+ ;; not for every allocation. That makes it cheap to do,
+ ;; even if it is a little ugly.
+ (soft-heap-limit-exceeded? (and *soft-heap-limit*
+ (> pre-gc-dynamic-usage
+ *soft-heap-limit*)))
+ (*soft-heap-limit* (if soft-heap-limit-exceeded?
+ (+ pre-gc-dynamic-usage
+ *bytes-consed-between-gcs*)
+ *soft-heap-limit*)))
+ (when soft-heap-limit-exceeded?
+ (cerror "Continue with GC."
+ "soft heap limit exceeded (temporary new limit=~D)"
+ *soft-heap-limit*))
+ (when (and *gc-trigger* (> pre-gc-dynamic-usage *gc-trigger*))
(setf *need-to-collect-garbage* t))
(when (or force-p
(and *need-to-collect-garbage* (not *gc-inhibit*)))
- (/show0 "Evidently we ought to collect garbage..")
- (when (and (not force-p)
- *gc-inhibit-hook*
- (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
- (/show0 "..but we're inhibited.")
- (setf *gc-inhibit* t)
- (return-from sub-gc nil))
;; KLUDGE: Wow, we really mask interrupts all the time we're
;; collecting garbage? That seems like a long time.. -- WHN 19991129
(without-interrupts
;; calls to user-settable GC hook functions.
(let ((*standard-output* *terminal-io*))
(when *gc-notify-stream*
- (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
(if (streamp *gc-notify-stream*)
(carefully-funcall *gc-notify-before*
*gc-notify-stream*
- pre-gc-dyn-usage)
+ pre-gc-dynamic-usage)
(warn
"*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
(dolist (hook *before-gc-hooks*)
- (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
(carefully-funcall hook))
(when *gc-trigger*
(clear-auto-gc-trigger))
- (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
- #!-gencgc (funcall *internal-gc*)
- ;; FIXME: This EQ test is pretty gross. Among its other
- ;; nastinesses, it looks as though it could break if we
- ;; recompile COLLECT-GARBAGE.
- #!+gencgc (if (eq *internal-gc* #'collect-garbage)
- (funcall *internal-gc* gen)
- (funcall *internal-gc*))
- (/show0 "back from FUNCALL to *INTERNAL-GC*")
- (let* ((post-gc-dyn-usage (dynamic-usage))
- (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
- (when *last-bytes-in-use*
- (incf *total-bytes-consed*
- (- pre-gc-dyn-usage *last-bytes-in-use*))
- (setq *last-bytes-in-use* post-gc-dyn-usage))
+ (let* (;; We do DYNAMIC-USAGE once more here in order to
+ ;; get a more accurate measurement of the space
+ ;; actually freed, since the messing around, e.g.
+ ;; GC-notify stuff, since the DYNAMIC-USAGE which
+ ;; triggered GC could've done a fair amount of
+ ;; consing.)
+ (pre-internal-gc-dynamic-usage (dynamic-usage))
+ (ignore-me
+ #!-gencgc (funcall *internal-gc*)
+ ;; FIXME: This EQ test is pretty gross. Among its other
+ ;; nastinesses, it looks as though it could break if we
+ ;; recompile COLLECT-GARBAGE. We should probably just
+ ;; straighten out the interface so that all *INTERNAL-GC*
+ ;; functions accept a GEN argument (and then the
+ ;; non-generational ones just ignore it).
+ #!+gencgc (if (eq *internal-gc* #'collect-garbage)
+ (funcall *internal-gc* gen)
+ (funcall *internal-gc*)))
+ (post-gc-dynamic-usage (dynamic-usage))
+ (n-bytes-freed (- pre-internal-gc-dynamic-usage
+ post-gc-dynamic-usage))
+ ;; In sbcl-0.6.12.39, the raw N-BYTES-FREED from
+ ;; GENCGC could sometimes be substantially negative
+ ;; (e.g. -5872). I haven't looked into what causes
+ ;; that, but I suspect it has to do with
+ ;; fluctuating inefficiency in the way that the
+ ;; GENCGC packs things into page boundaries.
+ ;; Bumping the raw result up to 0 is a little ugly,
+ ;; but shouldn't be a problem, and it's even
+ ;; possible to sort of justify it: the packing
+ ;; inefficiency which has caused (DYNAMIC-USAGE) to
+ ;; grow is effectively consing, or at least
+ ;; overhead of consing, so it's sort of correct to
+ ;; add it to the running total of consing. ("Man
+ ;; isn't a rational animal, he's a rationalizing
+ ;; animal.":-) -- WHN 2001-06-23
+ (eff-n-bytes-freed (max 0 n-bytes-freed)))
+ (declare (ignore ignore-me))
+ (/show0 "got (DYNAMIC-USAGE) and EFF-N-BYTES-FREED")
+ (incf *n-bytes-freed-or-purified*
+ eff-n-bytes-freed)
+ (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
(setf *need-to-collect-garbage* nil)
- (let ((new-gc-trigger (+ post-gc-dyn-usage
+ (/show0 "calculating NEW-GC-TRIGGER")
+ (let ((new-gc-trigger (+ post-gc-dynamic-usage
*bytes-consed-between-gcs*)))
+ (/show0 "setting *GC-TRIGGER*")
(setf *gc-trigger* new-gc-trigger))
+ (/show0 "calling SET-AUTO-GC-TRIGGER")
(set-auto-gc-trigger *gc-trigger*)
(dolist (hook *after-gc-hooks*)
(/show0 "doing a hook from *AFTER-GC--HOOKS*")
;; e.g. 108% of total memory usage.
(carefully-funcall hook))
(when *gc-notify-stream*
- (/show0 "doing the *GC-NOTIFY-AFTER* thing")
(if (streamp *gc-notify-stream*)
(carefully-funcall *gc-notify-after*
*gc-notify-stream*
- post-gc-dyn-usage
- bytes-freed
+ post-gc-dynamic-usage
+ eff-n-bytes-freed
*gc-trigger*)
(warn
"*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
- (/show0 "scrubbing control stack")
- (scrub-control-stack)))
- (/show0 "updating *GC-RUN-TIME*")
+ (scrub-control-stack))) ;XXX again? we did this from C ...
(incf *gc-run-time* (- (get-internal-run-time)
start-time))))
;; FIXME: should probably return (VALUES), here and in RETURN-FROM
- (/show0 "returning from tail of SUB-GC")
nil)
;;; This routine is called by the allocation miscops to decide whether
object)
;;; This is the user-advertised garbage collection function.
-;;;
-;;; KLUDGE: GC shouldn't have different parameters depending on what
-;;; garbage collector we use. -- WHN 19991020
-#!-gencgc
-(defun gc (&optional (verbose-p *gc-verbose*))
- #!+sb-doc
- "Initiates a garbage collection. VERBOSE-P controls
- whether or not GC statistics are printed."
- (sub-gc :verbose-p verbose-p :force-p t))
-#!+gencgc
-(defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
- #!+sb-doc
- "Initiates a garbage collection. VERBOSE controls whether or not GC
- statistics are printed. GEN controls the number of generations to garbage
- collect."
- ;; FIXME: The bare 6 here (corresponding to a bare 6 in
- ;; the gencgc.c sources) is nasty.
- (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
+(defun gc (&key (gen 0) (full nil) &allow-other-keys)
+ #!+(and sb-doc gencgc)
+ "Initiate a garbage collection. GEN controls the number of generations
+ to garbage collect."
+ #!+(and sb-doc (not gencgc))
+ "Initiate a garbage collection. GEN may be provided for compatibility with
+ generational garbage collectors, but is ignored in this implementation."
+ (sub-gc :force-p t :gen (if full 6 gen)))
+
\f
;;;; auxiliary functions
(clear-auto-gc-trigger)
(set-auto-gc-trigger *gc-trigger*))
(t
+ ;; FIXME: If SCRUB-CONTROL-STACK is required here, why
+ ;; isn't it built into SUB-GC? And *is* it required here?
(sb!sys:scrub-control-stack)
(sub-gc)))))
val)
(defun gc-on ()
#!+sb-doc
- "Enables the garbage collector."
+ "Enable the garbage collector."
(setq *gc-inhibit* nil)
(when *need-to-collect-garbage*
(sub-gc))
(defun gc-off ()
#!+sb-doc
- "Disables the garbage collector."
+ "Disable the garbage collector."
(setq *gc-inhibit* t)
nil)
\f
;;;; initialization stuff
-(defun gc-cold-init-or-reinit ()
+(defun gc-reinit ()
(when *gc-trigger*
(if (< *gc-trigger* (dynamic-usage))
(sub-gc)