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

Enable interrupts only when running thread body

Browse source 
* 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
Download patch file Download diff file Expand all files Collapse all files

3
libguile/threads.c
View file

@ -732,6 +732,9 @@ typedef struct {
static void *
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);
return 0;
}

38
module/ice-9/threads.scm
View file

@ -128,23 +128,37 @@ Once @var{thunk} or @var{handler} returns, the return value is made the
(lambda () (catch #t thunk handler))
thunk))
(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
(%call-with-new-thread
(lambda ()
(call-with-values
(lambda ()
(with-continuation-barrier
(lambda ()
(call-with-prompt cancel-tag
(lambda ()
(lock-mutex mutex)
(set! thread (current-thread))
(set! (thread-join-data thread) (cons cv mutex))
(signal-condition-variable cv)
(unlock-mutex mutex)
(thunk))
(lambda (k . args)
(apply values args))))))
(call-with-prompt cancel-tag
(lambda ()
(lock-mutex mutex)
(set! thread (current-thread))
(set! (thread-join-data thread) (cons cv mutex))
(signal-condition-variable cv)
(unlock-mutex mutex)
(call-with-unblocked-asyncs
(lambda () (call-with-backtrace thunk))))
(lambda (k . args)
(apply values args))))
(lambda vals
(lock-mutex mutex)
;; Probably now you're wondering why we are going to use