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.

2 files changed, 29 insertions, 12 deletions

diff --git a/libguile/threads.c b/libguile/threads.c
index b46a71b42..64bef8c89 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -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;
 }
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index ae6a97db9..65108d9f1 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -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