X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=61c351c8dbbcfbe677033ad797b24164e12706d3;hb=54da325f13fb41669869aea688ae195426c0e231;hp=eabb4b4d9dfdb09f688eff7155bb9d980d8baf4d;hpb=95110584db3224cf61b774f1402a71a79e61432f;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index eabb4b4..61c351c 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -13,28 +13,19 @@ ;;;; 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-frob (lisp-fun c-var-name) - `(progn - #!-sb-fluid (declaim (inline ,lisp-fun)) - (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 -(progn - ;; This is called once per PROFILEd function call, so it's worth a - ;; little possible space cost to reduce its time cost. - #!-sb-fluid - (declaim (inline current-dynamic-space-start)) - (def-c-var-frob 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)) ; to reduce PROFILEd call overhead +(declaim (inline dynamic-usage)) #!+gencgc -(def-c-var-frob dynamic-usage "bytes_allocated") +(defun dynamic-usage () + (sb!alien:extern-alien "bytes_allocated" os-vm-size-t)) #!-gencgc (defun dynamic-usage () (the (unsigned-byte 32) @@ -42,24 +33,24 @@ (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 () #!-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,23 +61,27 @@ (format t "Control stack usage is: ~10:D bytes.~%" (control-stack-usage)) (format t "Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage)) #!+sb-thread - (format t - "Control and binding stack usage is for the current thread only.~%") + (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) (sb!vm:memory-usage :count-spaces '(:dynamic) - :print-spaces t - :cutoff 0.05f0 - :print-summary nil)) + :print-spaces t + :cutoff 0.05f0 + :print-summary nil)) (defun room-maximal-info () - (room-minimal-info) - (sb!vm:memory-usage :count-spaces '(:static :dynamic)) - (sb!vm:instance-usage :dynamic :top-n 10) - (sb!vm:instance-usage :static :top-n 10)) + ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed + (room-intermediate-info) + ;; old way, could be restored when bug 344 fixed: + ;;x (room-minimal-info) + ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic)) + ;;x (sb!vm:instance-usage :dynamic :top-n 10) + ;;x (sb!vm:instance-usage :static :top-n 10) + ) (defun room (&optional (verbosity :default)) #!+sb-doc @@ -116,17 +111,15 @@ ;;; allocated and never freed.) (declaim (type unsigned-byte *n-bytes-freed-or-purified*)) (defvar *n-bytes-freed-or-purified* 0) -(push (lambda () - (setf *n-bytes-freed-or-purified* 0)) - ;; KLUDGE: It's probably not quite safely right either to do - ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even - ;; worse, something which depended on (GET-BYTES-CONSED), might - ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But - ;; it's probably not a big problem, and there seems to be no - ;; other obvious time to do it. -- WHN 2001-07-30 - *after-save-initializations*) - -(declaim (ftype (function () unsigned-byte) get-bytes-consed)) +(defun gc-reinit () + (setq *gc-inhibit* nil) + (gc) + (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 (sfunction () unsigned-byte) get-bytes-consed)) (defun get-bytes-consed () #!+sb-doc "Return the number of bytes consed since the program began. Typically @@ -140,55 +133,11 @@ and submit it as a patch." ;;;; GC hooks -(defvar *before-gc-hooks* nil ; actually initialized in cold init - #!+sb-doc - "A list of functions that are called before garbage collection occurs. - The functions are run with interrupts disabled and all other threads - paused. They should take no arguments.") - -(defvar *after-gc-hooks* nil ; actually initialized in cold init - #!+sb-doc - "A list of functions that are called after garbage collection occurs. - The functions are run with interrupts disabled and all other threads - paused. They should take no arguments.") - -(defvar *gc-run-time* 0 - #!+sb-doc - "the total CPU time spent doing garbage collection (as reported by - GET-INTERNAL-RUN-TIME)") -(declaim (type index *gc-run-time*)) - -;;;; The following specials are used to control when garbage -;;;; collection occurs. +(defvar *after-gc-hooks* nil + "Called after each garbage collection, except for garbage collections +triggered during thread exits. In a multithreaded environment these hooks may +run in any thread.") -;;; 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,19 +153,37 @@ and submit it as a patch." (defun gc-stop-the-world ()) (defun gc-start-the-world ())) +#!+gencgc +(progn + (sb!alien:define-alien-variable ("gc_logfile" %gc-logfile) (* char)) + (defun (setf gc-logfile) (pathname) + (let ((new (when pathname + (sb!alien:make-alien-string + (native-namestring (translate-logical-pathname pathname) + :as-file t)))) + (old %gc-logfile)) + (setf %gc-logfile new) + (when old + (sb!alien:free-alien old)) + pathname)) + (defun gc-logfile () + #!+sb-doc + "Return the pathname used to log garbage collections. Can be SETF. +Default is NIL, meaning collections are not logged. If non-null, the +designated file is opened before and after each collection, and generation +statistics are appended to it." + (let ((val (cast %gc-logfile c-string))) + (when val + (native-pathname val)))) + (declaim (inline dynamic-space-size)) + (defun dynamic-space-size () + "Size of the dynamic space in bytes." + (sb!alien:extern-alien "dynamic_space_size" os-vm-size-t))) ;;;; SUB-GC -;;; This is used to carefully invoke hooks. -(eval-when (:compile-toplevel :execute) - (sb!xc:defmacro carefully-funcall (function &rest args) - `(handler-case (funcall ,function ,@args) - (error (cond) - (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond) - nil)))) - ;;; SUB-GC does a garbage collection. This is called from three places: -;;; (1) The C runtime will call here when it detects that we've consed +;;; (1) The C runtime will call here when it detects that we've consed ;;; enough to exceed the gc trigger threshold. This is done in ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc ;;; (2) The user may request a collection using GC, below @@ -230,66 +197,290 @@ and submit it as a patch." ;;; For GENCGC all generations < GEN will be GC'ed. -(defvar *already-in-gc* nil "System is running SUB-GC") -(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex")) - -(defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage))) - ;; catch attempts to gc recursively or during post-hooks and ignore them - (when (sb!thread::mutex-value *gc-mutex*) (return-from sub-gc nil)) - (sb!thread:with-mutex (*gc-mutex* :wait-p nil) - (setf *need-to-collect-garbage* t) - (when (zerop *gc-inhibit*) - (without-interrupts - (gc-stop-the-world) - (collect-garbage gen) - (incf *n-bytes-freed-or-purified* - (max 0 (- pre-gc-dynamic-usage (dynamic-usage)))) - (setf *need-to-collect-garbage* nil) - (gc-start-the-world)) - (scrub-control-stack) - (setf *need-to-collect-garbage* nil) - (dolist (h *after-gc-hooks*) (carefully-funcall h)))) - (values)) - +(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. + (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)))) + #!+sb-safepoint + (setf *stop-for-gc-pending* nil) + (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* + (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) +(defun gc (&key (full nil) (gen 0) &allow-other-keys) #!+(and sb-doc gencgc) - "Initiate a garbage collection. GEN controls the number of generations - to garbage collect." - #!+(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))) + "Initiate a garbage collection. + +The default is to initiate a nursery collection, which may in turn +trigger a collection of one or more older generations as well. If FULL +is true, all generations are collected. If GEN is provided, it can be +used to specify the oldest generation guaranteed to be collected. +On CheneyGC platforms arguments FULL and GEN take no effect: a full +collection is always preformed." + #!+(and sb-doc (not gencgc)) + "Initiate a garbage collection. + +The collection is always a full collection. + +Arguments FULL and GEN can be used for compatibility with GENCGC +platforms: there the default is to initiate a nursery collection, +which may in turn trigger a collection of one or more older +generations as well. If FULL is true, all generations are collected. +If GEN is provided, it can be used to specify the oldest generation +guaranteed to be collected." + (when (sub-gc :gen (if full sb!vm:+pseudo-static-generation+ gen)) + (post-gc))) + +(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. + (scrub-control-stack) + ;; Power cache of the bignum printer: drops overly large bignums and + ;; removes duplicate entries. + (scrub-power-cache) + ;; Clear caches depending on the generation being collected. + #!+gencgc + (cond ((eql 0 gen)) + ((eql 1 gen) + (ctype-of-cache-clear)) + (t + (drop-all-hash-caches))) + #!-gencgc + (drop-all-hash-caches)) ;;;; auxiliary functions (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." - (sb!alien:extern-alien "bytes_consed_between_gcs" - (sb!alien:unsigned 32))) + "The amount of memory that will be allocated before the next garbage +collection is initiated. This can be set with SETF. + +On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic +space size. + +Note: currently changes to this value are lost when saving core." + (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t)) (defun (setf bytes-consed-between-gcs) (val) (declare (type index val)) - (setf (sb!alien:extern-alien "bytes_consed_between_gcs" - (sb!alien:unsigned 32)) - val)) + (setf (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t) + val)) -(defun gc-on () - #!+sb-doc - "Enable the garbage collector." - (setq *gc-inhibit* 0) - (when *need-to-collect-garbage* - (sub-gc)) - 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))) -(defun gc-off () - #!+sb-doc - "Disable the garbage collector." - (setq *gc-inhibit* 1) - nil) +;;;; 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 os-vm-size-t) + (gc-trigger os-vm-size-t) + (bytes-consed-between-gcs os-vm-size-t) + (number-of-gcs int) + (number-of-gcs-before-promotion int) + (cum-sum-bytes-allocated os-vm-size-t) + (minimum-age-before-gc double))) +#!+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 +5% of the dynamic space size divided by the number of non-nursery generations. +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. Default is 1. 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))