;;;; -*- coding: utf-8; -*-
+changes in sbcl-0.9.5 relative to sbcl-0.9.4:
+ * threads
+ ** bug fix: parent thread now can be gc'ed even with a live
+ child thread
+
changes in sbcl-0.9.4 relative to sbcl-0.9.3:
* new port: the Solaris operating system on x86 processors is now
mostly supported, though some rough edges in the environment
system-area-pointer
(lisp-fun-address unsigned-long))
- (define-alien-routine "block_deferrable_signals_and_inhibit_gc"
+ (define-alien-routine "block_blockable_signals"
void)
(define-alien-routine reap-dead-thread void
(setup-p nil)
(real-function (coerce function 'function))
(thread-sap
- (%create-thread
- (sb!kernel:get-lisp-obj-address
- (lambda ()
- ;; FIXME: use semaphores?
- (loop until setup-p)
- ;; in time we'll move some of the binding presently done in C
- ;; here too
- (let ((*current-thread* thread)
- (sb!kernel::*restart-clusters* nil)
- (sb!kernel::*handler-clusters* nil)
- (sb!kernel::*condition-restarts* nil)
- (sb!impl::*descriptor-handlers* nil)) ; serve-event
- ;; can't use handling-end-of-the-world, because that flushes
- ;; output streams, and we don't necessarily have any (or we
- ;; could be sharing them)
- (unwind-protect
- (catch 'sb!impl::toplevel-catcher
- (catch 'sb!impl::%end-of-the-world
- (with-simple-restart
- (terminate-thread
- (format nil "~~@<Terminate this thread (~A)~~@:>"
- *current-thread*))
- ;; now that most things have a chance to work
- ;; properly without messing up other threads, it's
- ;; time to enable signals
- (sb!unix::reset-signal-mask)
- (unwind-protect
- (funcall real-function)
- ;; we're going down, can't handle
- ;; interrupts sanely anymore
- (block-deferrable-signals-and-inhibit-gc)))))
- ;; and remove what can be the last references to the
- ;; thread object
- (handle-thread-exit thread)
- (setq *current-thread* nil)
- 0))
- (values))))))
+ ;; don't let the child inherit *CURRENT-THREAD* because that
+ ;; can prevent gc'ing this thread while the child runs
+ (let ((*current-thread* nil))
+ (%create-thread
+ (sb!kernel:get-lisp-obj-address
+ (lambda ()
+ ;; FIXME: use semaphores?
+ (loop until setup-p)
+ ;; in time we'll move some of the binding presently done in C
+ ;; here too
+ (let ((*current-thread* thread)
+ (sb!kernel::*restart-clusters* nil)
+ (sb!kernel::*handler-clusters* nil)
+ (sb!kernel::*condition-restarts* nil)
+ (sb!impl::*descriptor-handlers* nil)) ; serve-event
+ ;; can't use handling-end-of-the-world, because that flushes
+ ;; output streams, and we don't necessarily have any (or we
+ ;; could be sharing them)
+ (unwind-protect
+ (catch 'sb!impl::toplevel-catcher
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (terminate-thread
+ (format nil
+ "~~@<Terminate this thread (~A)~~@:>"
+ *current-thread*))
+ ;; now that most things have a chance to
+ ;; work properly without messing up other
+ ;; threads, it's time to enable signals
+ (sb!unix::reset-signal-mask)
+ (unwind-protect
+ (funcall real-function)
+ ;; we're going down, can't handle
+ ;; interrupts sanely anymore
+ (let ((sb!impl::*gc-inhibit* t))
+ (block-blockable-signals)
+ ;; and remove what can be the last
+ ;; reference to this thread
+ (handle-thread-exit thread))))))
+ 0))
+ (values)))))))
(when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
(error "Can't create a new thread"))
(setf (thread-%sap thread) thread-sap)
thread_sigmask(SIG_SETMASK,&new,0);
}
-void block_deferrable_signals_and_inhibit_gc ()
-{
- struct thread *thread=arch_os_get_current_thread();
- sigset_t block;
- sigemptyset(&block);
- sigaddset_deferrable(&block);
- thread_sigmask(SIG_BLOCK, &block, 0);
- bind_variable(GC_INHIBIT,T,thread);
-}
-
-static void block_blockable_signals ()
+void block_blockable_signals ()
{
sigset_t block;
sigemptyset(&block);
int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */
struct thread * volatile all_threads;
-volatile lispobj all_threads_lock;
extern struct interrupt_data * global_interrupt_data;
extern int linux_no_threads_p;
#ifdef LISP_FEATURE_SB_THREAD
+
+pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
+
/* When trying to get all_threads_lock one should make sure that
* sig_stop_for_gc is not blocked. Else there would be a possible
* deadlock: gc locks it, other thread blocks signals, gc sends stop
check_sig_stop_for_gc_can_arrive_or_lose(); \
FSHOW_SIGNAL((stderr,"/%s:waiting on lock=%ld, thread=%lu\n",name, \
all_threads_lock,arch_os_get_current_thread()->os_thread)); \
- get_spinlock(&all_threads_lock,(long)arch_os_get_current_thread()); \
+ pthread_mutex_lock(&all_threads_lock); \
FSHOW_SIGNAL((stderr,"/%s:got lock, thread=%lu\n", \
name,arch_os_get_current_thread()->os_thread));
#define RELEASE_ALL_THREADS_LOCK(name) \
FSHOW_SIGNAL((stderr,"/%s:released lock\n",name)); \
- release_spinlock(&all_threads_lock); \
+ pthread_mutex_unlock(&all_threads_lock); \
thread_sigmask(SIG_SETMASK,&_oldset,0); \
}
#endif
}
#endif /* LISP_FEATURE_SB_THREAD */
+#define THREAD_STRUCT_SIZE (THREAD_CONTROL_STACK_SIZE + BINDING_STACK_SIZE + \
+ ALIEN_STACK_SIZE + dynamic_values_bytes + \
+ 32 * SIGSTKSZ)
+
+static void
+free_thread_struct(struct thread *th)
+{
+ if (th->interrupt_data)
+ os_invalidate((os_vm_address_t) th->interrupt_data,
+ (sizeof (struct interrupt_data)));
+ os_invalidate((os_vm_address_t) th->control_stack_start,
+ THREAD_STRUCT_SIZE);
+}
+
/* this is called from any other thread to create the new one, and
* initialize all parts of it that can be initialized from another
* thread
*/
-struct thread * create_thread_struct(lispobj initial_function) {
+static struct thread *
+create_thread_struct(lispobj initial_function) {
union per_thread_data *per_thread;
struct thread *th=0; /* subdue gcc */
void *spaces=0;
/* may as well allocate all the spaces at once: it saves us from
* having to decide what to do if only some of the allocations
* succeed */
- spaces=os_validate(0,
- THREAD_CONTROL_STACK_SIZE+
- BINDING_STACK_SIZE+
- ALIEN_STACK_SIZE+
- dynamic_values_bytes+
- 32*SIGSTKSZ);
+ spaces=os_validate(0, THREAD_STRUCT_SIZE);
if(!spaces)
return NULL;
per_thread=(union per_thread_data *)
th->interrupt_data = (struct interrupt_data *)
os_validate(0,(sizeof (struct interrupt_data)));
+ if (!th->interrupt_data) {
+ free_thread_struct(th);
+ return 0;
+ }
if(all_threads)
memcpy(th->interrupt_data,
arch_os_get_current_thread()->interrupt_data,
if (success)
link_thread(th,kid_tid);
else
- os_invalidate((os_vm_address_t) th->control_stack_start,
- ((sizeof (lispobj))
- * (th->control_stack_end-th->control_stack_start)) +
- BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+
- 32*SIGSTKSZ);
+ free_thread_struct(th);
RELEASE_ALL_THREADS_LOCK("create_thread")
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
gc_alloc_update_page_tables(0, &th->alloc_region);
- release_spinlock(&all_threads_lock);
thread_sigmask(SIG_SETMASK,&oldset,0);
}
#endif
RELEASE_ALL_THREADS_LOCK("reap_dead_thread")
if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
gc_assert(pthread_join(th->os_thread,NULL)==0);
- os_invalidate((os_vm_address_t) th->control_stack_start,
- ((sizeof (lispobj))
- * (th->control_stack_end-th->control_stack_start)) +
- BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+
- 32*SIGSTKSZ);
+ free_thread_struct(th);
}
/* Send the signo to os_thread, retry if the rt signal queue is
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock, thread=%lu\n",
th->os_thread));
/* keep threads from starting while the world is stopped. */
- get_spinlock(&all_threads_lock,(long)th);
+ pthread_mutex_lock(&all_threads_lock); \
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock, thread=%lu\n",
th->os_thread));
/* stop all other threads by sending them SIG_STOP_FOR_GC */
for(p=all_threads; p; p=p->next) {
while(p->state==STATE_STARTING) sched_yield();
if((p!=th) && (p->state==STATE_RUNNING)) {
- status=kill_thread_safely(p->os_thread,SIG_STOP_FOR_GC);
FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending %lu\n",
p->os_thread));
+ status=kill_thread_safely(p->os_thread,SIG_STOP_FOR_GC);
if (status==ESRCH) {
/* This thread has exited. */
gc_assert(p->state==STATE_DEAD);
* SIG_STOP_FOR_GC wouldn't need to be a rt signal. That has some
* performance implications, but does away with the 'rt signal
* queue full' problem. */
- release_spinlock(&all_threads_lock);
+ pthread_mutex_unlock(&all_threads_lock); \
FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
}
#endif
(in-package "SB-THREAD") ; this is white-box testing, really
+(defun wait-for-threads (threads)
+ (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+
(assert (eql 1 (length (list-all-threads))))
(assert (eq *current-thread*
;; Start NTHREADS idle threads.
(dotimes (i nthreads)
(sb-thread:make-thread (lambda ()
- (sb-thread:condition-wait queue mutex)
+ (with-mutex (mutex)
+ (sb-thread:condition-wait queue mutex))
(sb-ext:quit))))
(let ((start-time (get-internal-run-time)))
(funcall function)
(format t "done ~A~%" *current-thread*))))
(let ((kid1 (make-thread #'run))
(kid2 (make-thread #'run)))
- (format t "contention ~A ~A~%" kid1 kid2))))
+ (format t "contention ~A ~A~%" kid1 kid2)
+ (wait-for-threads (list kid1 kid2)))))
(defun test-interrupt (function-to-interrupt &optional quit-p)
(let ((child (make-thread function-to-interrupt)))
(test-interrupt #'loop-forever :quit)
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
- (terminate-thread child))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
(let ((lock (make-mutex :name "loctite"))
child)
(sleep 5)
(interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
(format t "parent releasing lock~%"))
- (terminate-thread child))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
(format t "~&locking test done~%")
(sleep (random 0.1d0))
(princ ".")
(force-output)
- (sb-thread:interrupt-thread
- thread
- (lambda ()))))))))
- (loop while (some #'thread-alive-p killers) do (sleep 0.1))
- (sb-thread:terminate-thread thread)))
+ (sb-thread:interrupt-thread thread (lambda ()))))))))
+ (wait-for-threads killers)
+ (sb-thread:terminate-thread thread)
+ (wait-for-threads (list thread))))
(sb-ext:gc :full t))
(format t "~&multi interrupt test done~%")
(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
;; NB this only works on x86: other ports don't have a symbol for
;; pseudo-atomic atomicity
- (format t "new thread ~A~%" c)
(dotimes (i 100)
(sleep (random 0.1d0))
(interrupt-thread c
(princ ".") (force-output)
(assert (eq (thread-state *current-thread*) :running))
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
- (terminate-thread c))
+ (terminate-thread c)
+ (wait-for-threads (list c)))
(format t "~&interrupt test done~%")
(dotimes (i 100)
(sleep (random 0.1d0))
(interrupt-thread c func))
- (format t "~&waiting for interrupts to arrive~%")
(loop until (= *interrupt-count* 100) do (sleep 0.1))
- (terminate-thread c)))
+ (terminate-thread c)
+ (wait-for-threads (list c))))
(format t "~&interrupt count test done~%")
(loop while (thread-alive-p interruptor-thread)))
(format t "~&session lock test done~%")
+
+(sb-ext:gc :full t)
+(loop repeat 20 do
+ (wait-for-threads
+ (loop for i below 100 collect
+ (sb-thread:make-thread (lambda ()))))
+ (sb-ext:gc :full t)
+ (princ "+")
+ (force-output))
+
+(format t "~&creation test done~%")
+
+;; watch out for *current-thread* being the parent thread after exit
+(let ((thread (sb-thread:make-thread (lambda ()))))
+ (wait-for-threads (list thread))
+ (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
+ thread))))
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
;;; 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.9.4"
+"0.9.4.1"
projects / sbcl.git / commitdiff