<font face="courier new, monospace">(dump-threads)</font> uses <font face="courier new, monospace">##thread-continuation-capture</font> to get the current continuation of a target thread.<div><br></div><div>This presumes that the target thread has been started, if it has not <font face="courier new, monospace">##thread-continuation-capture</font> causes SIGSEGV.</div>
<div><br></div><div>Checking for if it has been started requires access to thread object fields that are not exported currently, and thus to do this right now you need to make a hack consisting of copying out the thread structure's definition into your code and doing the check there - this is not version safe.</div>
<div><br></div><div>I propose the introduction in Gambit of a procedure</div><div><br></div><blockquote style="margin:0 0 0 40px;border:none;padding:0px"><div><font face="courier new, monospace">(##thread-status thread)</font></div>
<div><font face="courier new, monospace">=> </font><span style="font-family:'courier new',monospace">list ('created) = The thread has not yet been started</span></div><div><font face="courier new, monospace"> list ('starting) = The thread has been started but execution has not yet begun</font></div>
<div><font face="courier new, monospace"> list ('running) = The thread is running</font></div><div><font face="courier new, monospace"> list ('ended result) = The thread terminated ordinarily, with the return value result</font></div>
<div><font face="courier new, monospace"> list ('ended/exception exception) = The thread terminated with the exception exception</font></div></blockquote><div><br></div><div>as the definition is quite short and its presence enables the programmer to without hacks reliably dump threads, which is like a core thing for debug.</div>
<div><br></div><div>Here follows a definition for inclusion into Gambit, based on an email Marc sent 2011-12-16, quoted below:</div><div><br></div><blockquote style="margin:0 0 0 40px;border:none;padding:0px"><div><font face="courier new, monospace">(define (##thread-status thread #!optional capture-continuation-if-running?)</font></div>
<div><font face="courier new, monospace"> </font></div><div><font face="courier new, monospace"> (let loop ()</font></div><div><font face="courier new, monospace"> </font></div><div><font face="courier new, monospace"> ; Make snapshot of thread state</font></div>
<div><font face="courier new, monospace"> ; Quantum manipulation just to ensure get a consistent snapshot</font></div><div><font face="courier new, monospace"> (define quantum-pre (thread-quantum (current-thread)))</font></div>
<div><font face="courier new, monospace"> (thread-quantum-set! (current-thread) +inf.0)</font></div><div><font face="courier new, monospace"> (let* ((end-condvar (macro-thread-end-condvar thread))</font></div><div>
<font face="courier new, monospace"> (exception? (macro-thread-exception? thread))</font></div>
<div><font face="courier new, monospace"> (result (macro-thread-result thread)))</font></div><div><font face="courier new, monospace"> (thread-quantum-set! (current-thread) quantum-pre)</font></div>
<div><font face="courier new, monospace"><br></font></div><div><font face="courier new, monospace"> ; Generate return value</font></div><div><font face="courier new, monospace"> (cond ((not end-condvar)</font></div>
<div><font face="courier new, monospace"> ;; Thread has terminated</font></div><div><font face="courier new, monospace"> (if exception?</font></div><div><font face="courier new, monospace"> ;; Thread has terminated with exception</font></div>
<div><font face="courier new, monospace"> (list 'ended/exception result)</font></div><div><font face="courier new, monospace"> ;; Thread has terminated with result</font></div><div><font face="courier new, monospace"> (list 'ended result)))</font></div>
<div><font face="courier new, monospace"> (exception?</font></div><div><font face="courier new, monospace"> ;; Thread has never run and is not terminated</font></div><div><font face="courier new, monospace"> (if (not result)</font></div>
<div><font face="courier new, monospace"> ;; Thread is not yet started</font></div><div><font face="courier new, monospace"> (list 'created)</font></div><div><font face="courier new, monospace"> ;; Thread is started but has not yet run</font></div>
<div><font face="courier new, monospace"> (list 'starting)))</font></div><div><font face="courier new, monospace"> (else</font></div><div><font face="courier new, monospace"> (if </font><span style="font-family:'courier new',monospace">capture-continuation-if-running?</span></div>
<div><font face="courier new, monospace"> (let ((continuation</font></div><div><font face="courier new, monospace"> (with-exception-catcher</font></div><div><font face="courier new, monospace"> (lambda (e) (loop))</font></div>
<div><font face="courier new, monospace"> (lambda () (capture-continuation-if-running? thread)))))</font></div><div><font face="courier new, monospace"> (list 'running continuation)</font></div>
<div><font face="courier new, monospace"> (list 'running))))))))</font></div></blockquote><div><br></div><div><div>Use would look something like:</div><div><br></div><div><blockquote style="margin:0px 0px 0px 40px;border:none;padding:0px">
<font face="courier new, monospace">> (define t (make-thread (lambda () (thread-sleep! 5))))<br>> (##thread-status t)<br>(created)<br>> (thread-start! t)<br>> (##thread-status t)<br>(running)<br>> (thread-sleep! 5)<br>
> (##thread-status t)<br>(ended #!void)</font></blockquote></div><div><br></div></div><div>With such a definition, a (dump-threads) could be defined as easy as:</div><div><br></div><div><blockquote style="margin:0 0 0 40px;border:none;padding:0px">
<div><div><font face="courier new, monospace">(define (dump-threads #!key threads thread-group thread #!rest display-continuation-backtrace-args)</font></div><div><font face="courier new, monospace"> (map (lambda (thread)</font></div>
<div><font face="courier new, monospace"> (let loop ()</font></div><div><font face="courier new, monospace"> (let ((status (##thread-status thread #t)))</font></div><div><font face="courier new, monospace"> (if (eq? (car status) 'running)</font></div>
<div><font face="courier new, monospace"> (list 'running (call-with-output-string</font></div><div><font face="courier new, monospace"> '()</font></div><div><font face="courier new, monospace"> (lambda (port) (apply display-continuation-backtrace</font></div>
<div><font face="courier new, monospace"> `(,(cadr status) ; = continuation</font></div><div><font face="courier new, monospace"> ,port</font></div>
<div><font face="courier new, monospace"> .,display-continuation-backtrace-args)))))</font></div><div><font face="courier new, monospace"> status))))</font></div>
<div><font face="courier new, monospace"> (or threads (thread-group->thread-list (or thread-group (thread-thread-group (or thread (current-thread))))))))</font></div></div></blockquote></div><div><br></div><div>
Please feel free to provide feedback.</div>
<div><br></div><div>Brgds, Mikael<br><br><div class="gmail_quote">2011/12/16 Marc Feeley<br><blockquote class="gmail_quote" style="margin:0px 0px 0px 0.8ex;border-left-width:1px;border-left-color:rgb(204,204,204);border-left-style:solid;padding-left:1ex">
<div class="im"><br>On 2011-12-15, at 6:22 PM, Mikael wrote:<br><br></div></blockquote><div>[..] </div><blockquote class="gmail_quote" style="margin:0px 0px 0px 0.8ex;border-left-width:1px;border-left-color:rgb(204,204,204);border-left-style:solid;padding-left:1ex">
<div class="im">> Aha, that is good to be aware of - before running ##thread-continuation-capture on a thread, how can i check it's started (as to safeguard from this)?<br><br></div>The attached code checks for all possible states of a thread. Please try to dump the state of your threads with it to see if the segmentation fault goes away.<br>
<br>(##include "~~lib/_gambit#.scm")<br><br>(define (dump-thread thread)<br><br> (write thread)<br><br> (let* ((end-condvar (macro-thread-end-condvar thread))<br> (exception? (macro-thread-exception? thread))<br>
(result (macro-thread-result thread)))<br> (cond ((not end-condvar)<br> ;; thread has terminated<br> (if exception?<br> (begin<br> ;; thread has terminated with exception<br>
(display " is terminated with exception:\n")<br> (display-exception result))<br> (begin<br> ;; thread has terminated with result<br> (display " is terminated with result:\n")<br>
(pretty-print result))))<br> (exception?<br> ;; thread has never run and is not terminated<br> (if (not result)<br> (begin<br> ;; thread is not yet started<br>
(display " is not yet started\n"))<br> (begin<br> ;; thread is started but has not yet run<br> (display " is started but has not yet run\n"))))<br>
(else<br> ;; thread is started and has run<br> (let ((c (##thread-continuation-capture thread)))<br> (display " is running with continuation:\n")<br> (display-continuation-backtrace c)))))<br>
<br> (newline))<br><br>(define t2 (make-thread (lambda () 222)))<br>(define t3 (make-thread (lambda () 333)))<br>(define t4 (make-thread (lambda () (/ 1 0))))<br>(define t5 (make-thread (lambda () 555)))<br><br>(thread-start! t3)<br>
(thread-start! t4)<br><br>(thread-sleep! 0.01)<br><br>(dump-thread (current-thread))<br>(dump-thread t2)<br>(dump-thread t3)<br>(dump-thread t4)<br>(thread-start! t5)<br>(dump-thread t5)<br><br>;; % gsi dump-thread.scm<br>
;; #<thread #1 primordial> is running with continuation:<br>;; 0 dump-thread "dump-thread.scm"@32:21 (##thread-continuation...<br>;; 1 (interaction) "dump-thread.scm"@48:1 (dump-thread (current-...<br>
;; 2 ##load<br>;; 3 ##load<br>;; 4 ##main<br>;;<br>;; #<thread #2> is not yet started<br>;;<br>;; #<thread #3> is terminated with result:<br>;; 333<br>;;<br>;; #<thread #4> is terminated with exception:<br>
;; Divide by zero<br>;; (/ 1 0)<br>;;<br>;; #<thread #5> is started but has not yet run<br><br></blockquote></div></div>