X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=bc5c9200855aa77ac62a09a78b0034863aa2a400;hb=cdd026dddac3eaddbaa0221503e49e2673d54545;hp=fb4a0e1bb685de97981cc0179aaeccae40b57952;hpb=4084b6b95c1d5e0a45e073a9b875d8471efd8505;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index fb4a0e1..bc5c920 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -13,22 +13,19 @@ ;;;; DYNAMIC-USAGE and friends -(eval-when (:compile-toplevel :execute) - (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name) - `(defun ,lisp-fun () - (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))) - #!-sb-fluid (declaim (inline current-dynamic-space-start)) #!+gencgc (defun current-dynamic-space-start () sb!vm:dynamic-space-start) #!-gencgc -(def-c-var-fun current-dynamic-space-start "current_dynamic_space") +(defun current-dynamic-space-start () + (sb!alien:extern-alien "current_dynamic_space" sb!alien:unsigned-long)) #!-sb-fluid (declaim (inline dynamic-usage)) #!+gencgc -(def-c-var-fun dynamic-usage "bytes_allocated") +(defun dynamic-usage () + (sb!alien:extern-alien "bytes_allocated" sb!alien:unsigned-long)) #!-gencgc (defun dynamic-usage () (the (unsigned-byte 32) @@ -36,11 +33,11 @@ (current-dynamic-space-start)))) (defun static-space-usage () - (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes) + (- (ash sb!vm:*static-space-free-pointer* sb!vm:n-fixnum-tag-bits) sb!vm:static-space-start)) (defun read-only-space-usage () - (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes) + (- (ash sb!vm::*read-only-space-free-pointer* sb!vm:n-fixnum-tag-bits) sb!vm:read-only-space-start)) (defun control-stack-usage () @@ -236,39 +233,40 @@ NIL as the pathname." ;; 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 gen) - (gc-stop-the-world) - (let ((start-time (get-internal-run-time))) - (collect-garbage gen) - (setf *gc-epoch* (cons nil nil)) - (let ((run-time (- (get-internal-run-time) start-time))) - ;; KLUDGE: Sometimes we see the second getrusage() call - ;; return a smaller value than the first, which can - ;; lead to *GC-RUN-TIME* to going negative, which in - ;; turn is a type-error. - (when (plusp run-time) - (incf *gc-run-time* run-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))))))) + (sb!thread::without-thread-waiting-for (:already-without-interrupts t) + (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 gen) + (gc-stop-the-world) + (let ((start-time (get-internal-run-time))) + (collect-garbage gen) + (setf *gc-epoch* (cons nil nil)) + (let ((run-time (- (get-internal-run-time) start-time))) + ;; KLUDGE: Sometimes we see the second getrusage() call + ;; return a smaller value than the first, which can + ;; lead to *GC-RUN-TIME* to going negative, which in + ;; turn is a type-error. + (when (plusp run-time) + (incf *gc-run-time* run-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* -> @@ -299,9 +297,10 @@ NIL as the pathname." ;; 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))))) + (sb!thread::without-thread-waiting-for () + (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) @@ -317,6 +316,7 @@ NIL as the pathname." (define-alien-routine scrub-control-stack sb!alien:void) (defun unsafe-clear-roots (gen) + #!-gencgc (declare (ignore gen)) ;; 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. @@ -380,9 +380,7 @@ collection is initiated. This can be set with SETF." (number-of-gcs int) (number-of-gcs-before-promotion int) (cum-sum-bytes-allocated unsigned-long) - (minimum-age-before-gc double) - ;; `struct lutex *' or `void *', depending. - (lutexes (* char)))) + (minimum-age-before-gc double))) #!+gencgc (define-alien-variable generations