From 0e2c926fea68a32c8ec58f12daa0c2b5befef1d4 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Mon, 5 May 2003 23:27:07 +0000 Subject: [PATCH] 0.8alpha.0.14 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. --- src/code/cold-init.lisp | 8 ++- src/code/gc.lisp | 113 +++++++++++++------------------------------ src/code/purify.lisp | 20 ++------ src/code/target-thread.lisp | 45 ++++++++--------- src/runtime/cheneygc.c | 12 +++-- src/runtime/gc-common.c | 3 ++ src/runtime/gencgc.c | 47 ++++-------------- src/runtime/interrupt.c | 27 +++-------- src/runtime/purify.c | 21 +++----- src/runtime/runtime.c | 43 ++++++++-------- version.lisp-expr | 2 +- 11 files changed, 119 insertions(+), 222 deletions(-) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index eae1527..fc26b92 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -95,7 +95,6 @@ (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 @@ -235,7 +234,6 @@ (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") @@ -277,7 +275,6 @@ instead (which is another name for the same thing).")) (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 @@ -293,8 +290,9 @@ instead (which is another name for the same thing).")) ;; 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)) ;;;; some support for any hapless wretches who end up debugging cold ;;;; init code diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 39d59a6..9566365 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -220,25 +220,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 +249,35 @@ 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")) - +#!+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. @@ -324,25 +297,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 +319,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*)))) diff --git a/src/code/purify.lisp b/src/code/purify.lisp index 4ff9fc0..162b86c 100644 --- a/src/code/purify.lisp +++ b/src/code/purify.lisp @@ -31,7 +31,7 @@ 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. @@ -45,19 +45,5 @@ 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))) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index fd13e62..ec06a87 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -89,25 +89,29 @@ ;; 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 @@ -127,17 +131,10 @@ (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) diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c index 2c03339..53930cf 100644 --- a/src/runtime/cheneygc.c +++ b/src/runtime/cheneygc.c @@ -50,6 +50,8 @@ static void scavenge_newspace(void); static void scavenge_interrupt_contexts(void); extern struct interrupt_data * global_interrupt_data; +extern unsigned long bytes_consed_between_gcs; + /* collecting garbage */ @@ -116,8 +118,8 @@ collect_garbage(unsigned ignore) 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; @@ -241,15 +243,15 @@ collect_garbage(unsigned ignore) #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); @@ -595,11 +597,13 @@ gc_initialize_pointers(void) /* 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) { diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 147b2f3..357ad77 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -99,6 +99,9 @@ lispobj (*transother[256])(lispobj object); int (*sizetab[256])(lispobj *where); struct weak_pointer *weak_pointers; +unsigned long bytes_consed_between_gcs = 4*1024*1024; + + /* * copying objects */ diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 17064ee..a67748a 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -129,7 +129,8 @@ boolean gencgc_zero_check_during_free_heap = 0; /* 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. */ @@ -2146,7 +2147,8 @@ search_dynamic_space(lispobj *pointer) /* 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) { @@ -2173,23 +2175,6 @@ 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: @@ -2587,7 +2572,7 @@ preserve_pointer(void *addr) * (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; @@ -3984,7 +3969,10 @@ collect_garbage(unsigned last_gen) 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"); } @@ -4220,7 +4208,6 @@ alloc(int nbytes) * 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; @@ -4231,22 +4218,6 @@ alloc(int nbytes) } -/* - * 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; -} - /* Find the code object for the given pc, or return NULL on failure. * * FIXME: PC shouldn't be lispobj*, should it? Maybe void*? */ diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 5155c6a..4480fc9 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -562,11 +562,13 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) 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) { @@ -575,16 +577,8 @@ 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 @@ -604,18 +598,13 @@ interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context) 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 { diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 772b905..642dea9 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -45,6 +45,7 @@ */ 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__) @@ -132,17 +133,11 @@ dynamic_pointer_p(lispobj ptr) 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) { @@ -1063,7 +1058,7 @@ pscav_code(struct code*code) 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; @@ -1488,6 +1483,7 @@ purify(lispobj static_roots, lispobj read_only_roots) #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(); @@ -1500,6 +1496,5 @@ purify(lispobj static_roots, lispobj read_only_roots) printf(" done]\n"); fflush(stdout); #endif - return 0; } diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 620e7b6..ad6a34b 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -418,8 +418,10 @@ static void parent_do_garbage_collect(void) * 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"); @@ -431,7 +433,6 @@ static void parent_do_garbage_collect(void) 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"); @@ -442,6 +443,7 @@ static void /* noreturn */ parent_loop(void) struct sigaction sa; sigset_t sigset; int status; + pid_t pid=0; sigemptyset(&sigset); @@ -463,29 +465,26 @@ static void /* noreturn */ parent_loop(void) 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)); diff --git a/version.lisp-expr b/version.lisp-expr index f99abeb..5ddf697 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4