X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=042ab05e61b5c9d48d148f7c73998af5437980fb;hb=eaec8176060e89efa39f01017df1f6204e491ecc;hp=32aa109155e77fd843de1ce52478f5974d7a2627;hpb=4f9b5cd4268d3e28ac54748c4871e07f38acfd4c;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 32aa109..042ab05 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -13,9 +13,6 @@ ;;;; DYNAMIC-USAGE and friends -(declaim (special sb!vm:*read-only-space-free-pointer* - sb!vm:*static-space-free-pointer*)) - (eval-when (:compile-toplevel :execute) (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name) `(defun ,lisp-fun () @@ -215,7 +212,9 @@ run in any thread.") ;; 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)) + (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)) @@ -225,8 +224,13 @@ run in any thread.") (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))) + (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 @@ -286,6 +290,8 @@ run in any thread.") (when (sub-gc :gen (if full 6 gen)) (post-gc))) +(define-alien-routine scrub-control-stack sb!alien:void) + (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 @@ -303,8 +309,8 @@ run in any thread.") (defun bytes-consed-between-gcs () #!+sb-doc - "Return the amount of memory that will be allocated before the next garbage - collection is initiated. This can be set with SETF." + "The amount of memory that will be allocated before the next garbage +collection is initiated. This can be set with SETF." (sb!alien:extern-alien "bytes_consed_between_gcs" (sb!alien:unsigned 32))) @@ -320,3 +326,111 @@ run in any thread.") (or #!+sb-thread *stop-for-gc-pending* *gc-pending*)) (sb!unix::receive-pending-interrupt))) + +;;;; GENCGC specifics +;;;; +;;;; For documentation convenience, these have stubs on non-GENCGC platforms +;;;; as well. +#!+gencgc +(deftype generation-index () + '(integer 0 #.sb!vm:+pseudo-static-generation+)) + +;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be +;;; defined in Lisp, and written to header files by genesis, instead of this +;;; OAOOMiness -- this duplicates the struct definition in gencgc.c. +#!+gencgc +(define-alien-type generation + (struct generation + (alloc-start-page page-index-t) + (alloc-unboxed-start-page page-index-t) + (alloc-large-start-page page-index-t) + (alloc-large-unboxed-start-page page-index-t) + (bytes-allocated unsigned-long) + (gc-trigger unsigned-long) + (bytes-consed-between-gcs unsigned-long) + (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)))) + +#!+gencgc +(define-alien-variable generations + (array generation #.(1+ sb!vm:+pseudo-static-generation+))) + +(macrolet ((def (slot doc &optional setfp) + (declare (ignorable doc)) + `(progn + (defun ,(symbolicate "GENERATION-" slot) (generation) + #!+sb-doc + ,doc + #!+gencgc + (declare (generation-index generation)) + #!-gencgc + (declare (ignore generation)) + #!-gencgc + (error "~S is a GENCGC only function and unavailable in this build" + ',slot) + #!+gencgc + (slot (deref generations generation) ',slot)) + ,@(when setfp + `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation) + #!+gencgc + (declare (generation-index generation)) + #!-gencgc + (declare (ignore value generation)) + #!-gencgc + (error "(SETF ~S) is a GENCGC only function and unavailable in this build" + ',slot) + #!+gencgc + (setf (slot (deref generations generation) ',slot) value))))))) + (def bytes-consed-between-gcs + "Number of bytes that can be allocated to GENERATION before that +generation is considered for garbage collection. This value is meaningless for +generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is +20Mb. Can be assigned to using SETF. Available on GENCGC platforms only. + +Experimental: interface subject to change." + t) + (def minimum-age-before-gc + "Minimum average age of objects allocated to GENERATION before that +generation is may be garbage collected. Default is 0.75. See also +GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC +platforms only. + +Experimental: interface subject to change." + t) + (def number-of-gcs-before-promotion + "Number of times garbage collection is done on GENERATION before +automatic promotion to the next generation is triggered. Can be assigned to +using SETF. Available on GENCGC platforms only. + +Experimental: interface subject to change." + t) + (def bytes-allocated + "Number of bytes allocated to GENERATION currently. Available on GENCGC +platforms only. + +Experimental: interface subject to change.") + (def number-of-gcs + "Number of times garbage collection has been done on GENERATION without +promotion. Available on GENCGC platforms only. + +Experimental: interface subject to change.")) + (defun generation-average-age (generation) + "Average age of memory allocated to GENERATION: average number of times +objects allocated to the generation have seen younger objects promoted to it. +Available on GENCGC platforms only. + +Experimental: interface subject to change." + #!+gencgc + (declare (generation-index generation)) + #!-gencgc (declare (ignore generation)) + #!-gencgc + (error "~S is a GENCGC only function and unavailable in this build." + 'generation-average-age) + #!+gencgc + (alien-funcall (extern-alien "generation_average_age" + (function double generation-index-t)) + generation))