X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=7ba3b3b3e05f7e3a2e50819992006df7b7018cec;hb=4603ca100a7d181fe4316429365fc725501336dd;hp=b9d7fb1e930a4383792b8401782452ae0456e550;hpb=47eb330ef0f3b99d24c0e24d897b757f16950c4b;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index b9d7fb1..7ba3b3b 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -49,14 +49,14 @@ (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*)))) ;;;; ROOM @@ -120,7 +120,10 @@ (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)) (defun get-bytes-consed () @@ -137,8 +140,9 @@ and submit it as a patch." ;;;; 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.") ;;;; internal GC @@ -176,44 +180,79 @@ environment these hooks may run in any thread.") (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) + (dolist (hook *after-gc-hooks*) + (handler-case + (funcall hook) + (serious-condition (c) + (warn "Error calling after-GC hook ~S:~% ~A" hook c))))))))) ;;; This is the user-advertised garbage collection function. (defun gc (&key (gen 0) (full nil) &allow-other-keys) @@ -230,6 +269,9 @@ environment these hooks may run in any thread.") ;; 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)) @@ -250,16 +292,20 @@ environment these hooks may run in any thread.") (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 ()