X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=8a8fe4612fcb0261f9f2ffabf26d5bf12144984d;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=a41dec0a4a4bd591af36ae6d73e1bb968ad9f3fe;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index a41dec0..8a8fe46 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 @@ -70,7 +70,7 @@ (format t "Control and binding stack usage is for the current thread only.~%") (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%" - (> *gc-inhibit* 0))) + *gc-inhibit*)) (defun room-intermediate-info () (room-minimal-info) @@ -118,11 +118,14 @@ (declaim (type unsigned-byte *n-bytes-freed-or-purified*)) (defvar *n-bytes-freed-or-purified* 0) (defun gc-reinit () - (gc-on) + (setq *gc-inhibit* nil) (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 @@ -137,40 +140,10 @@ 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.") -;;;; The following specials are used to control when garbage -;;;; collection occurs. - -;;; 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. -;;; -;;; FIXME: *GC-TRIGGER* seems to be denominated in bytes, not words. -;;; And limiting it to INDEX is fairly reasonable in order to avoid -;;; bignum arithmetic on every allocation, and to minimize the need -;;; for thought about weird gotchas of the GC-control mechanism itself -;;; consing as it operates. But as of sbcl-0.7.5, 512Mbytes of memory -;;; costs $54.95 at Fry's in Dallas but cheap consumer 64-bit machines -;;; are still over the horizon, so gratuitously limiting our heap size -;;; to FIXNUM bytes seems fairly stupid. It'd be reasonable to -;;; (1) allow arbitrary UNSIGNED-BYTE values of *GC-TRIGGER*, or -;;; (2) redenominate this variable in words instead of bytes, postponing -;;; the problem to heaps which exceed 50% of the machine's address -;;; space, or even -;;; (3) redemoninate this variable in CONS-sized two-word units, -;;; allowing it to cover the entire memory space at the price of -;;; possible loss of clarity. -;;; (And whatever is done, it'd also be good to rename the variable so -;;; that it's clear what unit it's denominated in.) -(declaim (type (or index null) *gc-trigger*)) -(defvar *gc-trigger* nil) - -;;; When T, indicates that a GC should have happened but did not due to -;;; *GC-INHIBIT*. -(defvar *need-to-collect-garbage* nil) ; initialized in cold init ;;;; internal GC @@ -204,47 +177,105 @@ environment these hooks may run in any thread.") ;;; For GENCGC all generations < GEN will be GC'ed. -(defvar *already-in-gc* - (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC") +(defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock")) + +;;; 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*)) - ;; With gencgc, unless *NEED-TO-COLLECT-GARBAGE* every allocation - ;; in this function triggers another gc, potentially exceeding - ;; maximum interrupt nesting. - (setf *need-to-collect-garbage* t) - (when (zerop *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 *need-to-collect-garbage* 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))))))) + (cond (*gc-inhibit* + (setf *gc-pending* t) + nil) + (t + (without-interrupts + (setf *gc-pending* :in-progress) + ;; Tricks to to prevent triggerring a recursive gc. This is + ;; like a WITHOUT-GCING inside the lock except that we + ;; cannot call MAYBE-HANDLE-PENDING-GC at the end, because + ;; that would lead to a recursive attempt on the lock. In + ;; case you are wondering, wrapping the lock in a + ;; WITHOUT-GCING would also deadlock. The + ;; *IN-WITHOUT-GCING* part is used to tell the runtime that + ;; it's ok to have a pending gc even though *GC-INHIBIT* is + ;; NIL. + ;; + ;; Now, if GET-MUTEX did not cons, that would be enough. + ;; Because it does, we need the :IN-PROGRESS bit above to + ;; tell the runtime not to trigger gcs. + (let ((sb!impl::*in-without-gcing* t) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil)) + (sb!thread:with-mutex (*already-in-gc*) + (let ((*gc-inhibit* t)) + (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)) + #!+sb-thread + (assert (not *stop-for-gc-pending*)) + (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))))))) + ;; While holding the mutex we were protected from + ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to + ;; preserve the invariant (*GC-PENDING* -> + ;; pseudo-atomic-interrupted or *GC-INHIBIT*), let's check + ;; explicitly for a pending gc before interrupts are + ;; enabled again. + (maybe-handle-pending-gc)) + t))) + +(defun post-gc () + ;; Outside the mutex, interrupts may be 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? If the nested GCs happen in interrupt + ;; handlers that's not enough. + ;; + ;; KLUDGE: Don't run the hooks in GC's if: + ;; + ;; A) this thread is dying, so that user-code never runs with + ;; (thread-alive-p *current-thread*) => nil + ;; + ;; B) interrupts are disabled somewhere up the call chain since we + ;; don't want to run user code in such a case. + ;; + ;; 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*) + (when *allow-with-interrupts* + (with-interrupts + (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) @@ -254,13 +285,17 @@ environment these hooks may run in any thread.") #!+(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 :gen (if full 6 gen))) + (when (sub-gc :gen (if full 6 gen)) + (post-gc))) (defun unsafe-clear-roots () ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe ;; 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)) @@ -281,19 +316,9 @@ environment these hooks may run in any thread.") (sb!alien:unsigned 32)) val)) -;;; FIXME: Aren't these utterly wrong if called inside WITHOUT-GCING? -;;; Unless something that works there too can be deviced this fact -;;; should be documented. -(defun gc-on () - #!+sb-doc - "Enable the garbage collector." - (setq *gc-inhibit* 0) - (when *need-to-collect-garbage* - (sub-gc)) - nil) - -(defun gc-off () - #!+sb-doc - "Disable the garbage collector." - (setq *gc-inhibit* 1) - nil) +(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)))