0.8.4.40

The attached changes are supposed to fix bugs in SBCL when used for

gc-intensive multithreaded applications.  They haven't had sufficient

testing to be commited in time for SBCL 0.8.5 (may even make things

worse), but if you run into problems with deadlock or spinning on CPU,

you may want to apply this and rebuild.    -dan 2003.10.23

Index: src/code/gc.lisp

===================================================================

RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v

retrieving revision 1.52

diff -u -r1.52 gc.lisp

--- src/code/gc.lisp	2 Oct 2003 23:13:09 -0000	1.52

+++ src/code/gc.lisp	23 Oct 2003 19:22:19 -0000

@@ -236,22 +236,26 @@

 (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))))

+  (let ((value (sb!thread::mutex-value *gc-mutex*))) 

+    (when (eql value (sb!thread:current-thread-id)) (return-from sub-gc nil))

+    (sb!thread:with-mutex (*gc-mutex*)

+      (when value (return-from sub-gc 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))

Index: src/runtime/thread.c

===================================================================

RCS file: /cvsroot/sbcl/sbcl/src/runtime/thread.c,v

retrieving revision 1.18

diff -u -r1.18 thread.c

--- src/runtime/thread.c	7 Oct 2003 21:41:27 -0000	1.18

+++ src/runtime/thread.c	23 Oct 2003 19:22:26 -0000

@@ -53,6 +53,8 @@

 	fprintf(stderr, "/continue\n");

     }

     th->unbound_marker = UNBOUND_MARKER_WIDETAG;

+    if(arch_os_thread_init(th)==0) 

+	return 1;		/* failure.  no, really */

 #ifdef LISP_FEATURE_SB_THREAD

     /* wait here until our thread is linked into all_threads: see below */

     while(th->pid<1) sched_yield();

@@ -61,8 +63,7 @@

 	lose("th->pid not set up right");

 #endif

-    if(arch_os_thread_init(th)==0) 

-	return 1;		/* failure.  no, really */

+    th->state=STATE_RUNNING;

 #if !defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_X86)

     return call_into_lisp_first_time(function,args,0);

 #else

@@ -139,7 +140,7 @@

     th->binding_stack_pointer=th->binding_stack_start;

     th->this=th;

     th->pid=0;

-    th->state=STATE_RUNNING;

+    th->state=STATE_STOPPED;

 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD

     th->alien_stack_pointer=((void *)th->alien_stack_start

 			     + ALIEN_STACK_SIZE-4); /* naked 4.  FIXME */

@@ -312,39 +313,36 @@

 {

     /* stop all other threads by sending them SIG_STOP_FOR_GC */

     struct thread *p,*th=arch_os_get_current_thread();

-    struct thread *tail=0;

+    pid_t old_pid;

     int finished=0;

     do {

 	get_spinlock(&all_threads_lock,th->pid);

-	if(tail!=all_threads) {

-	    /* new threads always get consed onto the front of all_threads,

-	     * and may be created by any thread that we haven't signalled

-	     * yet or hasn't received our signal and stopped yet.  So, check

-	     * for them on each time around */

-	    for(p=all_threads;p!=tail;p=p->next) {

-		if(p==th) continue;

-		/* if the head of all_threads is removed during

-		 * gc_stop_the_world, we may take a second trip through the 

-		 * list and end up counting twice as many threads to wait for

-		 * as actually exist */

-		if(p->state!=STATE_RUNNING) continue;

-		countdown_to_gc++;

-		p->state=STATE_STOPPING;

-		/* Note no return value check from kill().  If the

-		 * thread had been reaped already, we kill it and

-		 * increment countdown_to_gc anyway.  This is to avoid

-		 * complicating the logic in destroy_thread, which would 

-		 * otherwise have to know whether the thread died before or

-		 * after it was killed

-		 */

-		kill(p->pid,SIG_STOP_FOR_GC);

-	    }

-	    tail=all_threads;

-	} else {

-	    finished=(countdown_to_gc==0);

+	for(p=all_threads,old_pid=p->pid; p; p=p->next) {

+	    if(p==th) continue;

+	    if(p->state!=STATE_RUNNING) continue;

+	    countdown_to_gc++;

+	    p->state=STATE_STOPPING;

+	    /* Note no return value check from kill().  If the

+	     * thread had been reaped already, we kill it and

+	     * increment countdown_to_gc anyway.  This is to avoid

+	     * complicating the logic in destroy_thread, which would 

+	     * otherwise have to know whether the thread died before or

+	     * after it was killed

+	     */

+	    kill(p->pid,SIG_STOP_FOR_GC);

 	}

 	release_spinlock(&all_threads_lock);

 	sched_yield();

+	/* if everything has stopped, and there is no possibility that

+	 * a new thread has been created, we're done.  Otherwise go

+	 * round again and signal anything that sprang up since last

+	 * time	 */

+	if(old_pid==all_threads->pid) {

+	    finished=1;

+	    for_each_thread(p) 

+		finished = finished &&

+		((p==th) || (p->state==STATE_STOPPED));

+	}

     } while(!finished);

 }

             "EUSERS" "EVICEERR" "EVICEOP" "EWOULDBLOCK" "EXDEV"

             "FD-ISSET" "FD-SET" "LTCHARS" "UNIX-FAST-SELECT"

             "UNIX-FILE-KIND" "UNIX-KILL" "UNIX-SIGSETMASK"

             "UNIX-FILE-KIND" "UNIX-KILL" 

             "TCSETPGRP" "FD-ZERO" "FD-CLR" "CHECK" "UNIX-RESOLVE-LINKS"

             "FD-SETSIZE" "TCGETPGRP" "UNIX-FAST-GETRUSAGE"

             "UNIX-SIMPLIFY-PATHNAME" "UNIX-KILLPG"

(defun unix-killpg (pgrp signal)

  (real-unix-killpg pgrp signal))

;;; Set the current set of masked signals (those being blocked from

;;; Reset the current set of masked signals (those being blocked from

;;; delivery).

;;;

;;; (Note: CMU CL had a SIGMASK operator to create masks, but since

;;; SBCL only uses 0, we no longer support it. If you need it, you

;;; can pull it out of the CMU CL sources, or the old SBCL sources;

;;; but you might also consider doing things the SBCL way and moving

;;; this kind of C-level work down to C wrapper functions.)

#!-sunos

(sb!alien:define-alien-routine ("sigsetmask" unix-sigsetmask)

			       sb!alien:unsigned-long

  (mask sb!alien:unsigned-long))

;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK

;;; operator to create masks, but since we only ever reset to 0, we no

;;; longer support it. If you need it, you can pull it out of the CMU

;;; CL sources, or the old SBCL sources; but you might also consider

;;; doing things the SBCL way and moving this kind of C-level work

;;; down to C wrapper functions.)

;;; When inappropriate build options are used, this also prints messages

;;; listing the signals that were masked

(sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)

;;;; C routines that actually do all the work of establishing signal handlers

(sb!alien:define-alien-routine ("install_handler" install-handler)

			       sb!alien:unsigned-long

  (signal sb!alien:int)

  (handler sb!alien:unsigned-long))

;;; assert (though non-fatally) that there are no signals masked

(sb!alien:define-alien-routine "warn_when_signals_masked" sb!alien:void)

;;;; interface to enabling and disabling signal handlers

	   (abort

	    "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")

	 (catch 'toplevel-catcher

	   (sb!unix::warn-when-signals-masked)

	   (sb!unix::reset-signal-mask)

	   ;; in the event of a control-stack-exhausted-error, we should

	   ;; have unwound enough stack by the time we get here that this

	   ;; is now possible

struct interrupt_data * global_interrupt_data;

/* this is used from Lisp in toplevel.lisp, replacing an older 

 * (sigsetmask 0) - we'd like to find out when the signal mask is 

 * not 0 */

/* At the toplevel repl we routinely call this function.  The signal

 * mask ought to be clear anyway most of the time, but may be non-zero

 * if we were interrupted e.g. while waiting for a queue.  */

/* This check was introduced in 0.8.4.x and some day will go away

 * again unless we find a way to trigger it */

void warn_when_signals_masked () 

#if 1

void reset_signal_mask () 

{

    sigset_t new;

    sigemptyset(&new);

    sigprocmask(SIG_SETMASK,&new,0);

}

#else

void reset_signal_mask () 

{

    /* and as a side-eeffect, unmask them */

    sigset_t new,old;

    int i;

    int wrong=0;

    if(wrong) 

	fprintf(stderr,"If this version of SBCL is less than three months old, please report this.\nOtherwise, please try a newer version first\n.  Reset signal mask.\n");

}

#endif

/*