Merge thread-gc-branch.
Summary: move time-to-gc-p logic entirely into C. Delete a
lot of Lisp stuff no longer necessary. Make SUB-GC
thread-safe or at least thread-tolerant. Some hooks and
variables that were previously available but not apparently
used for much are now no longer present.
(setf *gc-notify-stream* nil
*before-gc-hooks* nil
*after-gc-hooks* nil
- *already-maybe-gcing* t
*gc-inhibit* 1
*need-to-collect-garbage* nil
sb!unix::*interrupts-enabled* t
(setf *cold-init-complete-p* t)
;; The system is finally ready for GC.
- (setf *already-maybe-gcing* nil)
(/show0 "enabling GC")
(gc-on)
(/show0 "doing first GC")
(os-cold-init-or-reinit)
(stream-reinit)
(signal-cold-init-or-reinit)
- (gc-reinit)
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
;; PRINT seems not to like x86 NPX denormal floats like
;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are
;; reason.. (Perhaps we should do it anyway in case someone
;; manages to save an image from within a pseudo-atomic-atomic
;; operation?)
- #!+x86 (setf *pseudo-atomic-atomic* 0))
- (gc-on)))
+ #!+x86 (setf *pseudo-atomic-atomic* 0)))
+ (gc-on)
+ (gc))
\f
;;;; some support for any hapless wretches who end up debugging cold
;;;; init code
(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)
+
\f
;;;; SUB-GC
;;; For GENCGC all generations < GEN will be GC'ed.
-(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
-
+#!+sb-thread
(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)
-
+ (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)))
+ (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))
+ (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))
+ (setf *need-to-collect-garbage* nil))
+ (scrub-control-stack))
+ (values))
+
;;; This is the user-advertised garbage collection function.
#!+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
"Disable the garbage collector."
(setq *gc-inhibit* 1)
nil)
-\f
-;;;; initialization stuff
-(defun gc-reinit ()
- (when *gc-trigger*
- (if (< *gc-trigger* (dynamic-usage))
- (sub-gc)
- (set-auto-gc-trigger *gc-trigger*))))
n)))
(defun purify (&key root-structures (environment-name "Auxiliary"))
- #!+sb-doc
+ ;; #!+sb-doc
"This function optimizes garbage collection by moving all currently live
objects into non-collected storage. ROOT-STRUCTURES is an optional list of
objects which should be copied first to maximize locality.
supplied, then environment compaction is inhibited."
(when environment-name (compact-environment-aux environment-name 200))
-
- (let ((*gc-notify-before*
- (lambda (notify-stream bytes-in-use)
- (declare (ignore bytes-in-use))
- (write-string "[doing purification: " notify-stream)
- (force-output notify-stream)))
- (*internal-gc*
- (lambda (ignored-generation-arg)
- (%purify (get-lisp-obj-address root-structures)
- (get-lisp-obj-address nil))))
- (*gc-notify-after*
- (lambda (notify-stream &rest ignore)
- (declare (ignore ignore))
- (write-line "done]" notify-stream))))
- (gc))
- nil)
+ (%purify (get-lisp-obj-address root-structures)
+ (get-lisp-obj-address nil)))
;; the sigcont? For that matter, can we get interrupted?
(block-sigcont)
(when lock (release-mutex lock))
- (get-spinlock queue 2 pid)
- (pushnew pid (waitqueue-data queue))
- (setf (waitqueue-lock queue) 0)
+ (sb!sys:without-interrupts
+ (get-spinlock queue 2 pid)
+ (pushnew pid (waitqueue-data queue))
+ (setf (waitqueue-lock queue) 0))
(unblock-sigcont-and-sleep)))
(defun dequeue (queue)
(let ((pid (current-thread-id)))
- (get-spinlock queue 2 pid)
- (setf (waitqueue-data queue)
- (delete pid (waitqueue-data queue)))
- (setf (waitqueue-lock queue) 0)))
+ (sb!sys:without-interrupts
+ (get-spinlock queue 2 pid)
+ (setf (waitqueue-data queue)
+ (delete pid (waitqueue-data queue)))
+ (setf (waitqueue-lock queue) 0))))
(defun signal-queue-head (queue)
- (let ((pid (current-thread-id)))
- (get-spinlock queue 2 pid)
- (let ((h (car (waitqueue-data queue))))
- (setf (waitqueue-lock queue) 0)
- (when h
- (sb!unix:unix-kill h :sigcont)))))
+ (let ((pid (current-thread-id))
+ h)
+ (sb!sys:without-interrupts
+ (get-spinlock queue 2 pid)
+ (setf h (car (waitqueue-data queue)))
+ (setf (waitqueue-lock queue) 0))
+ (when h
+ (sb!unix:unix-kill h :sigcont))))
;;;; mutex
(defun release-mutex (lock &optional (new-value nil))
(declare (type mutex lock))
- (let ((old-value (mutex-value lock))
- (t1 nil))
- (loop
- (unless
- ;; args are object slot-num old-value new-value
- (eql old-value
- (setf t1
- (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
- (signal-queue-head lock)
- (return t))
- (setf old-value t1))))
+ ;; we assume the lock is ours to release
+ (setf (mutex-value lock) new-value)
+ (signal-queue-head lock))
+
(defmacro with-mutex ((mutex &key value (wait-p t)) &body body)
(with-unique-names (got)
static void scavenge_interrupt_contexts(void);
extern struct interrupt_data * global_interrupt_data;
+extern unsigned long bytes_consed_between_gcs;
+
\f
/* collecting garbage */
double real_time, system_time, user_time;
double percent_retained, gc_rate;
unsigned long size_discarded;
- unsigned long size_retained;
#endif
+ unsigned long size_retained;
lispobj *current_static_space_free_pointer;
unsigned long static_space_size;
unsigned long control_stack_size, binding_stack_size;
#ifdef PRINTNOISE
size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
- size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
#endif
+ size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
/* Zero stack. */
#ifdef PRINTNOISE
printf("Zeroing empty part of control stack ...\n");
#endif
zero_stack();
-
+ set_auto_gc_trigger(size_retained+bytes_consed_between_gcs);
sigprocmask(SIG_SETMASK, &old, 0);
\f
/* noise to manipulate the gc trigger stuff */
+/* Functions that substantially change the dynamic space free pointer
+ * (collect_garbage, purify) are responsible also for resettting the
+ * auto_gc_trigger */
void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
{
os_vm_address_t addr=(os_vm_address_t)current_dynamic_space
+ dynamic_usage;
-
long length = DYNAMIC_SPACE_SIZE - dynamic_usage;
if (addr < (os_vm_address_t)dynamic_space_free_pointer) {
int (*sizetab[256])(lispobj *where);
struct weak_pointer *weak_pointers;
+unsigned long bytes_consed_between_gcs = 4*1024*1024;
+
+
/*
* copying objects
*/
/* the total bytes allocated. These are seen by Lisp DYNAMIC-USAGE. */
unsigned long bytes_allocated = 0;
-static unsigned long auto_gc_trigger = 0;
+extern unsigned long bytes_consed_between_gcs; /* gc-common.c */
+unsigned long auto_gc_trigger = 0;
/* the source and destination generations. These are set before a GC starts
* scavenging. */
/* Is there any possibility that pointer is a valid Lisp object
* reference, and/or something else (e.g. subroutine call return
- * address) which should prevent us from moving the referred-to thing? */
+ * address) which should prevent us from moving the referred-to thing?
+ * This is called from preserve_pointers() */
static int
possibly_valid_dynamic_space_pointer(lispobj *pointer)
{
/* Check that the object pointed to is consistent with the pointer
* low tag.
- *
- * FIXME: It's not safe to rely on the result from this check
- * before an object is initialized. Thus, if we were interrupted
- * just as an object had been allocated but not initialized, the
- * GC relying on this result could bogusly reclaim the memory.
- * However, we can't really afford to do without this check. So
- * we should make it safe somehow.
- * (1) Perhaps just review the code to make sure
- * that WITHOUT-GCING or WITHOUT-INTERRUPTS or some such
- * thing is wrapped around critical sections where allocated
- * memory type bits haven't been set.
- * (2) Perhaps find some other hack to protect against this, e.g.
- * recording the result of the last call to allocate-lisp-memory,
- * and returning true from this function when *pointer is
- * a reference to that result.
- *
- * (surely pseudo-atomic is supposed to be used for exactly this?)
*/
switch (lowtag_of((lispobj)pointer)) {
case FUN_POINTER_LOWTAG:
* (or, as a special case which also requires dont_move, a return
* address referring to something in a CodeObject). This is
* expensive but important, since it vastly reduces the
- * probability that random garbage will be bogusly interpreter as
+ * probability that random garbage will be bogusly interpreted as
* a pointer which prevents a page from moving. */
if (!(possibly_valid_dynamic_space_pointer(addr)))
return;
gc_alloc_generation = 0;
update_x86_dynamic_space_free_pointer();
-
+ auto_gc_trigger = bytes_allocated + bytes_consed_between_gcs;
+ if(gencgc_verbose)
+ fprintf(stderr,"Next gc when %d bytes have been consed\n",
+ auto_gc_trigger);
SHOW("returning from collect_garbage");
}
* we should GC in the near future
*/
if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
- auto_gc_trigger *= 2;
/* set things up so that GC happens when we finish the PA
* section. */
maybe_gc_pending=1;
}
\f
-/*
- * noise to manipulate the gc trigger stuff
- */
-
-void
-set_auto_gc_trigger(os_vm_size_t dynamic_usage)
-{
- auto_gc_trigger += dynamic_usage;
-}
-
-void
-clear_auto_gc_trigger(void)
-{
- auto_gc_trigger = 0;
-}
-\f
/* Find the code object for the given pc, or return NULL on failure.
*
* FIXME: PC shouldn't be lispobj*, should it? Maybe void*? */
else return 0;
}
-#ifndef LISP_FEATURE_X86
+#ifndef LISP_FEATURE_GENCGC
/* This function gets called from the SIGSEGV (for e.g. Linux or
* OpenBSD) or SIGBUS (for e.g. FreeBSD) handler. Here we check
* whether the signal was due to treading on the mprotect()ed zone -
* and if so, arrange for a GC to happen. */
+extern unsigned long bytes_consed_between_gcs; /* gc-common.c */
+
boolean
interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context)
{
struct interrupt_data *data=
th ? th->interrupt_data : global_interrupt_data;
- if (!foreign_function_call_active
-#ifndef LISP_FEATURE_GENCGC
- /* nb: GENCGC on non-x86? I really don't think so. This
- * happens every time */
- && gc_trigger_hit(signal, info, context)
-#endif
- ) {
-#ifndef LISP_FEATURE_GENCGC
+ if(!foreign_function_call_active && gc_trigger_hit(signal, info, context)){
clear_auto_gc_trigger();
-#endif
if (arch_pseudo_atomic_atomic(context)) {
/* don't GC during an atomic operation. Instead, copy the
arch_set_pseudo_atomic_interrupted(context);
}
else {
- lispobj *old_free_space=current_dynamic_space;
fake_foreign_function_call(context);
+ /* SUB-GC may return without GCing if *GC-INHIBIT* is set,
+ * in which case we will be running with no gc trigger
+ * barrier thing for a while. But it shouldn't be long
+ * until the end of WITHOUT-GCING. */
funcall0(SymbolFunction(SUB_GC));
undo_fake_foreign_function_call(context);
- if(current_dynamic_space==old_free_space)
- /* MAYBE-GC (as the name suggest) might not. If it
- * doesn't, it won't reset the GC trigger either, so we
- * have to do it ourselves. Put it near the end of
- * dynamic space so we're not running into it continually
- */
- set_auto_gc_trigger(DYNAMIC_SPACE_SIZE
- -(u32)os_vm_page_size);
}
return 1;
} else {
*/
static lispobj *dynamic_space_free_pointer;
#endif
+extern unsigned long bytes_consed_between_gcs;
#define gc_abort() \
lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
static unsigned pointer_filter_verbose = 0;
-/* FIXME: This is substantially the same code as in gencgc.c. (There
- * are some differences, at least (1) the gencgc.c code needs to worry
- * about return addresses on the stack pinning code objects, (2) the
- * gencgc.c code needs to worry about the GC maybe happening in an
- * interrupt service routine when the main thread of control was
- * interrupted just as it had allocated memory and before it
- * initialized it, while PURIFY needn't worry about that, and (3) the
- * gencgc.c code has mutated more under maintenance since the fork
- * from CMU CL than the code here has.) The two versions should be
- * made to explicitly share common code, instead of just two different
- * cut-and-pasted versions. */
+/* FIXME: This is substantially the same code as
+ * possibly_valid_dynamic_space_pointer in gencgc.c. The only
+ * relevant difference seems to be that the gencgc code also checks
+ * for raw pointers into Code objects */
+
static int
valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
{
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
- /* Temporarly convert the self pointer to a real function
+ /* Temporarily convert the self pointer to a real function
* pointer. */
((struct simple_fun *)native_pointer(func))->self
-= FUN_RAW_ADDR_OFFSET;
#if !defined(__i386__)
dynamic_space_free_pointer = current_dynamic_space;
+ set_auto_gc_trigger(bytes_consed_between_gcs);
#else
#if defined LISP_FEATURE_GENCGC
gc_free_heap();
printf(" done]\n");
fflush(stdout);
#endif
-
return 0;
}
* finished being pseudo_atomic. once there it will
* signal itself SIGSTOP, which will give us another
* event to wait for */
+#if 0
fprintf(stderr, "%d was pseudo-atomic, letting it resume \n",
th->pid);
+#endif
SetTlSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,make_fixnum(1),th);
if(ptrace(PTRACE_CONT,th->pid,0,0))
perror("PTRACE_CONT");
collect_garbage(maybe_gc_pending-1);
maybe_gc_pending=0;
stop_the_world=0;
- /* fprintf(stderr, "gc done\n"); */
for_each_thread(th)
if(ptrace(PTRACE_DETACH,th->pid,0,0))
perror("PTRACE_DETACH");
struct sigaction sa;
sigset_t sigset;
int status;
+ pid_t pid=0;
sigemptyset(&sigset);
while(!all_threads) {
sched_yield();
}
-
- while(all_threads) {
- pid_t pid=0;
- while(pid=waitpid(-1,&status,__WALL|WUNTRACED)) {
- struct thread *th;
- if(pid==-1) {
- if(errno == EINTR) {
- if(maybe_gc_pending) parent_do_garbage_collect();
- continue;
- }
- if(errno == ECHILD) break;
- fprintf(stderr,"waitpid: %s\n",strerror(errno));
+ maybe_gc_pending=0;
+ while(all_threads && (pid=waitpid(-1,&status,__WALL|WUNTRACED))) {
+ struct thread *th;
+ while(maybe_gc_pending) parent_do_garbage_collect();
+ if(pid==-1) {
+ if(errno == EINTR) {
continue;
}
- th=find_thread_by_pid(pid);
- if(!th) continue;
- if(WIFEXITED(status) || WIFSIGNALED(status)) {
- fprintf(stderr,"waitpid : child %d %x exited \n", pid,th);
- destroy_thread(th);
- /* FIXME arrange to call or fake (free-mutex *session-lock*)
- * if necessary */
- if(!all_threads) break;
- }
+ if(errno == ECHILD) break;
+ fprintf(stderr,"waitpid: %s\n",strerror(errno));
+ continue;
+ }
+ th=find_thread_by_pid(pid);
+ if(!th) continue;
+ if(WIFEXITED(status) || WIFSIGNALED(status)) {
+ fprintf(stderr,"waitpid : child %d %x exited \n", pid,th);
+ destroy_thread(th);
+ /* FIXME arrange to call or fake (free-mutex *session-lock*)
+ * if necessary */
+ if(!all_threads) break;
}
}
exit(WEXITSTATUS(status));
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8alpha.0.13"
+"0.8alpha.0.14"
projects / sbcl.git / commitdiff