-(defun sub-gc (&key force-p (gen 0))
- (/show0 "entering SUB-GC")
- (unless *already-maybe-gcing*
- (let* ((*already-maybe-gcing* t)
- (start-time (get-internal-run-time))
- (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=~W)"
- *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*)))
- ;; KLUDGE: Wow, we really mask interrupts all the time we're
- ;; collecting garbage? That seems like a long time.. -- WHN 19991129
- (without-interrupts
- ;; FIXME: We probably shouldn't do this evil thing to
- ;; *STANDARD-OUTPUT* in a binding which is wrapped around
- ;; calls to user-settable GC hook functions.
- (let ((*standard-output* *terminal-io*))
- (when *gc-notify-stream*
- (if (streamp *gc-notify-stream*)
- (carefully-funcall *gc-notify-before*
- *gc-notify-stream*
- pre-gc-dynamic-usage)
- (warn
- "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
- (dolist (hook *before-gc-hooks*)
- (carefully-funcall hook))
- (when *gc-trigger*
- (clear-auto-gc-trigger))
- (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)
- (/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*")
- ;; FIXME: This hook should be called with the same
- ;; kind of information as *GC-NOTIFY-AFTER*. In
- ;; particular, it would be nice for the hook function
- ;; to be able to adjust *GC-TRIGGER* intelligently to
- ;; e.g. 108% of total memory usage.
- (carefully-funcall hook))
- (when *gc-notify-stream*
- (if (streamp *gc-notify-stream*)
- (carefully-funcall *gc-notify-after*
- *gc-notify-stream*
- post-gc-dynamic-usage
- eff-n-bytes-freed
- *gc-trigger*)
- (warn
- "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
- (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
- nil)
-
-;;; This routine is called by the allocation miscops to decide whether
-;;; a GC should occur. The argument, OBJECT, is the newly allocated
-;;; object which must be returned to the caller.
-(defun maybe-gc (&optional object)
- (sub-gc)
- object)
+
+(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))
+ (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)))))