(defun control-stack-usage ()
#!-stack-grows-downward-not-upward
(- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
- (sb!vm:fixnumize sb!vm:*control-stack-start*))
+ (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*)))
#!+stack-grows-downward-not-upward
- (- (sb!vm:fixnumize sb!vm:*control-stack-end*)
+ (- (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
(sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
(defun binding-stack-usage ()
(- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
- (sb!vm:fixnumize sb!vm:*binding-stack-start*)))
+ (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*binding-stack-start*))))
\f
;;;; ROOM
(defun gc-reinit ()
(gc-on)
(gc)
- (setf *n-bytes-freed-or-purified* 0))
+ (setf *n-bytes-freed-or-purified* 0
+ *gc-run-time* 0
+ ;; See comment in interr.lisp
+ *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error)))
-(declaim (ftype (function () unsigned-byte) get-bytes-consed))
+(declaim (ftype (sfunction () unsigned-byte) get-bytes-consed))
(defun get-bytes-consed ()
#!+sb-doc
"Return the number of bytes consed since the program began. Typically
;;;; GC hooks
(defvar *after-gc-hooks* nil
- "Called after each garbage collection. In a multithreaded
-environment these hooks may run in any thread.")
+ "Called after each garbage collection, except for garbage collections
+triggered during thread exits. In a multithreaded environment these hooks may
+run in any thread.")
\f
;;;; internal GC
(defvar *already-in-gc*
(sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
+;;; A unique GC id. This is supplied for code that needs to detect
+;;; whether a GC has happened since some earlier point in time. For
+;;; example:
+;;;
+;;; (let ((epoch *gc-epoch*))
+;;; ...
+;;; (unless (eql epoch *gc-epoch)
+;;; ....))
+;;;
+;;; This isn't just a fixnum counter since then we'd have theoretical
+;;; problems when exactly 2^29 GCs happen between epoch
+;;; comparisons. Unlikely, but the cost of using a cons instead is too
+;;; small to measure. -- JES, 2007-09-30
+(declaim (type cons *gc-epoch*))
+(defvar *gc-epoch* (cons nil nil))
+
(defun sub-gc (&key (gen 0))
(unless (eq sb!thread:*current-thread*
- (sb!thread::mutex-value *already-in-gc*))
+ (sb!thread:mutex-value *already-in-gc*))
;; With gencgc, unless *GC-PENDING* every allocation in this
;; function triggers another gc, potentially exceeding maximum
- ;; interrupt nesting.
- (setq *gc-pending* t)
- (unless *gc-inhibit*
- (sb!thread:with-mutex (*already-in-gc*)
- (let ((old-usage (dynamic-usage))
- (new-usage 0))
- (unsafe-clear-roots)
- ;; We need to disable interrupts for GC, but we also want
- ;; to run as little as possible without them.
- (without-interrupts
- (gc-stop-the-world)
- (collect-garbage gen)
- (setf *gc-pending* nil
- new-usage (dynamic-usage))
- (gc-start-the-world))
- ;; Interrupts re-enabled, but still inside the mutex.
- ;; In a multithreaded environment the other threads will
- ;; see *n-b-f-o-p* change a little late, but that's OK.
- (let ((freed (- old-usage new-usage)))
- ;; GENCGC occasionally reports negative here, but the
- ;; current belief is that it is part of the normal order
- ;; of things and not a bug.
- (when (plusp freed)
- (incf *n-bytes-freed-or-purified* freed)))))
- ;; Outside the mutex, these may cause another GC. FIXME: it can
- ;; potentially exceed maximum interrupt nesting by triggering
- ;; GCs.
- (run-pending-finalizers)
- (dolist (hook *after-gc-hooks*)
- (handler-case
- (funcall hook)
- (error (c)
- (warn "Error calling after GC hook ~S:~% ~S" hook c)))))))
+ ;; interrupt nesting. If *GC-INHIBIT* is not true, however,
+ ;; there is no guarantee that we would ever check for pending
+ ;; GC -- so in that case we must first disable interrupts, which
+ ;; needs to be done for GC anyways...
+ (cond (*gc-inhibit*
+ (setf *gc-pending* t))
+ (t
+ (without-interrupts
+ (setf *gc-pending* t)
+ (sb!thread:with-mutex (*already-in-gc*)
+ (let ((old-usage (dynamic-usage))
+ (new-usage 0))
+ (unsafe-clear-roots)
+
+ (gc-stop-the-world)
+ (let ((start-time (get-internal-run-time)))
+ (collect-garbage gen)
+ (setf *gc-epoch* (cons nil nil))
+ (incf *gc-run-time*
+ (- (get-internal-run-time) start-time)))
+ (setf *gc-pending* nil
+ new-usage (dynamic-usage))
+ (gc-start-the-world)
+
+ ;; In a multithreaded environment the other threads will
+ ;; see *n-b-f-o-p* change a little late, but that's OK.
+ (let ((freed (- old-usage new-usage)))
+ ;; GENCGC occasionally reports negative here, but the
+ ;; current belief is that it is part of the normal order
+ ;; of things and not a bug.
+ (when (plusp freed)
+ (incf *n-bytes-freed-or-purified* freed))))))
+
+ ;; Outside the mutex, interrupts enabled: these may cause
+ ;; another GC. FIXME: it can potentially exceed maximum
+ ;; interrupt nesting by triggering GCs.
+ ;;
+ ;; Can that be avoided by having the finalizers and hooks
+ ;; run only from the outermost SUB-GC?
+ ;;
+ ;; KLUDGE: Don't run the hooks in GC's triggered by dying
+ ;; threads, so that user-code never runs with
+ ;; (thread-alive-p *current-thread*) => nil
+ ;; The long-term solution will be to keep a separate thread
+ ;; for finalizers and after-gc hooks.
+ (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
+ (run-pending-finalizers)
+ (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))
;;; This is the user-advertised garbage collection function.
(defun gc (&key (gen 0) (full nil) &allow-other-keys)
;; as having these cons more then we have space left leads to huge
;; badness.
(scrub-control-stack)
+ ;; Power cache of the bignum printer: drops overly large bignums and
+ ;; removes duplicate entries.
+ (scrub-power-cache)
;; FIXME: CTYPE-OF-CACHE-CLEAR isn't thread-safe.
#!-sb-thread
(ctype-of-cache-clear))
(sb!alien:unsigned 32))
val))
+(declaim (inline maybe-handle-pending-gc))
+(defun maybe-handle-pending-gc ()
+ (when (and (not *gc-inhibit*)
+ (or #!+sb-thread *stop-for-gc-pending*
+ *gc-pending*))
+ (sb!unix::receive-pending-interrupt)))
+
;;; These work both regardless of whether we're inside WITHOUT-GCING
;;; or not.
(defun gc-on ()
#!+sb-doc
"Enable the garbage collector."
(setq *gc-inhibit* nil)
- (when (and (not *gc-inhibit*)
- (or #!+sb-thread *stop-for-gc-pending*
- *gc-pending*))
- (sb!unix::receive-pending-interrupt))
+ (maybe-handle-pending-gc)
nil)
(defun gc-off ()
projects / sbcl.git / blobdiff