1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00

Enable interrupts only when running thread body

* libguile/threads.c (really_launch): Start threads with asyncs
  blocked.
* module/ice-9/threads.scm (call-with-new-thread): Unblock asyncs once
  we have the bookkeeping sorted out.  Don't use
  with-continuation-barrier; it's not needed.  Print nice thread
  backtraces.
This commit is contained in:
Andy Wingo 2017-01-08 13:02:56 +01:00
parent 78239acff6
commit a000e5c38d
2 changed files with 29 additions and 12 deletions

View file

@ -732,6 +732,9 @@ typedef struct {
static void * static void *
really_launch (void *d) really_launch (void *d)
{ {
scm_i_thread *t = SCM_I_CURRENT_THREAD;
/* The thread starts with asyncs blocked. */
t->block_asyncs++;
SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk); SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk);
return 0; return 0;
} }

View file

@ -128,23 +128,37 @@ Once @var{thunk} or @var{handler} returns, the return value is made the
(lambda () (catch #t thunk handler)) (lambda () (catch #t thunk handler))
thunk)) thunk))
(thread #f)) (thread #f))
(define (call-with-backtrace thunk)
(let ((err (current-error-port)))
(catch #t
(lambda () (%start-stack 'thread thunk))
(lambda _ (values))
(lambda (key . args)
;; Narrow by three: the dispatch-exception,
;; this thunk, and make-stack.
(let ((stack (make-stack #t 3)))
(false-if-exception
(begin
(when stack
(display-backtrace stack err))
(let ((frame (and stack (stack-ref stack 0))))
(print-exception err frame key args)))))))))
(with-mutex mutex (with-mutex mutex
(%call-with-new-thread (%call-with-new-thread
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () (lambda ()
(with-continuation-barrier (call-with-prompt cancel-tag
(lambda () (lambda ()
(call-with-prompt cancel-tag (lock-mutex mutex)
(lambda () (set! thread (current-thread))
(lock-mutex mutex) (set! (thread-join-data thread) (cons cv mutex))
(set! thread (current-thread)) (signal-condition-variable cv)
(set! (thread-join-data thread) (cons cv mutex)) (unlock-mutex mutex)
(signal-condition-variable cv) (call-with-unblocked-asyncs
(unlock-mutex mutex) (lambda () (call-with-backtrace thunk))))
(thunk)) (lambda (k . args)
(lambda (k . args) (apply values args))))
(apply values args))))))
(lambda vals (lambda vals
(lock-mutex mutex) (lock-mutex mutex)
;; Probably now you're wondering why we are going to use ;; Probably now you're wondering why we are going to use