X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=f3dacccbcd22e1dba6d3afb5b8a3438e2f19182b;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=39d59a63ab097d8d02686bc62fcb386ef786ed1f;hpb=02c9007b4ca5753406f60019f4fe5e5f8392541a;p=sbcl.git diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 39d59a6..f3daccc 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -52,14 +52,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!vm:fixnumize sb!vm:*control-stack-start*)) #!+stack-grows-downward-not-upward - (- (sb!vm:fixnumize sb!vm::*control-stack-end*) + (- (sb!vm:fixnumize 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!vm:fixnumize sb!vm:*binding-stack-start*))) ;;;; ROOM @@ -138,23 +138,6 @@ and submit it as a patch." (+ (dynamic-usage) *n-bytes-freed-or-purified*)) -;;;; variables and constants - -;;; the minimum amount of dynamic space which must be consed before a -;;; GC will be triggered -;;; -;;; Unlike CMU CL, we don't export this variable. (There's no need to, -;;; since our BYTES-CONSED-BETWEEN-GCS function is SETFable.) -(defvar *bytes-consed-between-gcs* - #!+gencgc (* 4 (expt 10 6)) - ;; Stop-and-copy GC is really really slow when used too often. CSR - ;; reported that even on his old 64 Mb SPARC, 20 Mb is much faster - ;; than 4 Mb when rebuilding SBCL ca. 0.7.1. For modern machines - ;; with >> 128 Mb memory, the optimum could be significantly more - ;; than this, but at least 20 Mb should be better than 4 Mb. - #!-gencgc (* 20 (expt 10 6))) -(declaim (type index *bytes-consed-between-gcs*)) - ;;;; GC hooks (defvar *before-gc-hooks* nil ; actually initialized in cold init @@ -220,25 +203,9 @@ and submit it as a patch." (sb!alien:define-alien-routine collect-garbage sb!alien:int (#!+gencgc last-gen #!-gencgc ignore sb!alien:int)) -(sb!alien:define-alien-routine set-auto-gc-trigger sb!alien:void - (dynamic-usage sb!alien:unsigned-long)) - -(sb!alien:define-alien-routine clear-auto-gc-trigger sb!alien:void) - #!+sb-thread (def-c-var-frob gc-thread-pid "gc_thread_pid") -#!+sb-thread -(defun other-thread-collect-garbage (gen) - (setf (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32)) - (1+ gen)) - (sb!unix:unix-kill (gc-thread-pid) :SIGALRM)) - -;;; This variable contains the function that does the real GC. This is -;;; for low-level GC experimentation. Do not touch it if you do not -;;; know what you are doing. -(defvar *internal-gc* - #!+sb-thread #'other-thread-collect-garbage - #!-sb-thread #'collect-garbage) + ;;;; SUB-GC @@ -265,46 +232,39 @@ and submit it as a patch." ;;; For GENCGC all generations < GEN will be GC'ed. -(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex")) - -(defun sub-gc (&key (gen 0)) - (when (sb!thread::mutex-value *gc-mutex*) (return-from sub-gc nil)) - (sb!thread:with-mutex (*gc-mutex* :wait-p nil) - (let* ((start-time (get-internal-run-time))) - (setf *need-to-collect-garbage* t) - (when (zerop *gc-inhibit*) - (without-interrupts - (dolist (hook *before-gc-hooks*) (carefully-funcall hook)) - (when *gc-trigger* - (clear-auto-gc-trigger)) - (let* ((pre-internal-gc-dynamic-usage (dynamic-usage)) - (ignore-me (funcall *internal-gc* gen)) - (post-gc-dynamic-usage (dynamic-usage)) - (n-bytes-freed (- pre-internal-gc-dynamic-usage - post-gc-dynamic-usage)) - ;; the raw N-BYTES-FREED from GENCGC can sometimes be - ;; substantially negative (e.g. -5872). This is - ;; probably due to fluctuating inefficiency in the way - ;; that the GENCGC packs things into page boundaries. - ;; We bump the raw result up to 0: the space is - ;; allocated even if unusable, so should be counted - ;; for deciding when we've allocated enough to GC - ;; next. ("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)) - (incf *n-bytes-freed-or-purified* eff-n-bytes-freed) - (setf *need-to-collect-garbage* nil) - (setf *gc-trigger* (+ post-gc-dynamic-usage - *bytes-consed-between-gcs*)) - (set-auto-gc-trigger *gc-trigger*) - (dolist (hook *after-gc-hooks*) - (carefully-funcall hook)))) - (scrub-control-stack)) ;XXX again? we did this from C ... - (incf *gc-run-time* (- (get-internal-run-time) start-time)))) - nil) - +#!+sb-thread +(defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage))) + (setf *need-to-collect-garbage* t) + (when (zerop *gc-inhibit*) + (setf (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32)) + (1+ gen)) + (if (zerop (sb!alien:extern-alien "stop_the_world" (sb!alien:unsigned 32))) + (sb!unix:unix-kill (gc-thread-pid) :SIGALRM)) + (loop + (when (zerop + (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32))) + (return nil))) + (incf *n-bytes-freed-or-purified* + (max 0 (- pre-gc-dynamic-usage (dynamic-usage)))) + (setf *need-to-collect-garbage* nil) + (scrub-control-stack)) + (values)) +#!-sb-thread +(defvar *already-in-gc* nil "System is running SUB-GC") +#!-sb-thread +(defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage))) + (when *already-in-gc* (return-from sub-gc nil)) + (setf *need-to-collect-garbage* t) + (when (zerop *gc-inhibit*) + (let ((*already-in-gc* t)) + (without-interrupts (collect-garbage gen)) + (incf *n-bytes-freed-or-purified* + (max 0 (- pre-gc-dynamic-usage (dynamic-usage)))) + (setf *need-to-collect-garbage* nil)) + (scrub-control-stack)) + (values)) + ;;; This is the user-advertised garbage collection function. @@ -315,7 +275,7 @@ and submit it as a patch." #!+(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))) + (sub-gc :gen (if full 6 gen))) ;;;; auxiliary functions @@ -324,25 +284,14 @@ and submit it as a patch." #!+sb-doc "Return the amount of memory that will be allocated before the next garbage collection is initiated. This can be set with SETF." - *bytes-consed-between-gcs*) + (sb!alien:extern-alien "bytes_consed_between_gcs" + (sb!alien:unsigned 32))) + (defun (setf bytes-consed-between-gcs) (val) - ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable) - ;; be for a strictly positive number type, e.g. - ;; (AND (INTEGER 1) FIXNUM)? (declare (type index val)) - (let ((old *bytes-consed-between-gcs*)) - (setf *bytes-consed-between-gcs* val) - (when *gc-trigger* - (setf *gc-trigger* (+ *gc-trigger* (- val old))) - (cond ((<= (dynamic-usage) *gc-trigger*) - (clear-auto-gc-trigger) - (set-auto-gc-trigger *gc-trigger*)) - (t - ;; FIXME: If SCRUB-CONTROL-STACK is required here, why - ;; isn't it built into SUB-GC? And *is* it required here? - (sb!sys:scrub-control-stack) - (sub-gc))))) - val) + (setf (sb!alien:extern-alien "bytes_consed_between_gcs" + (sb!alien:unsigned 32)) + val)) (defun gc-on () #!+sb-doc @@ -357,11 +306,4 @@ and submit it as a patch." "Disable the garbage collector." (setq *gc-inhibit* 1) nil) - -;;;; initialization stuff -(defun gc-reinit () - (when *gc-trigger* - (if (< *gc-trigger* (dynamic-usage)) - (sub-gc) - (set-auto-gc-trigger *gc-trigger*))))