guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 04/07: Enable interrupts only when running thread body


From: Andy Wingo
Subject: [Guile-commits] 04/07: Enable interrupts only when running thread body
Date: Sun, 8 Jan 2017 14:51:37 +0000 (UTC)

wingo pushed a commit to branch master
in repository guile.

commit a000e5c38d50883c517214776dda36f4e478ebad
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 8 13:02:56 2017 +0100

    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.
---
 libguile/threads.c       |    3 +++
 module/ice-9/threads.scm |   38 ++++++++++++++++++++++++++------------
 2 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index b46a71b..64bef8c 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 ae6a97d..65108d9 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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]