From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 5 Jun 2018 08:15:56 +0000 (-0700)
Subject: Name most threads.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~6^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2dc989f9a19e082f7bd33eb3037e02bd69c15b92;p=mit-scheme.git

Name most threads.
---

diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm
index 7c4beaea7..691f82803 100644
--- a/src/edwin/editor.scm
+++ b/src/edwin/editor.scm
@@ -54,6 +54,7 @@ USA.
 		 (inferior-threads '())
 		 (recursive-edit-continuation #f)
 		 (recursive-edit-level 0))
+       (thread-put! editor-thread 'name edwin-editor)
        (editor-grab-display edwin-editor
 	 (lambda (with-editor-ungrabbed operations)
 	   (let ((message (cmdl-message/null)))
@@ -78,7 +79,9 @@ USA.
 					   thunks)
 					 (cdr thunks)))
 				((null? thunks))
-			      (create-thread root-continuation (car thunks)))
+			      (create-thread root-continuation
+				(car thunks)
+				(car thunks)))
 			    (top-level-command-reader
 			     edwin-initialization)))))))
 		 message)
@@ -580,7 +583,8 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
 		 (weak-set-cdr! (car threads) #f))
 	       (loop (cdr threads) threads)))))))
 
-(define (start-standard-polling-thread interval output-processor)
+(define (start-standard-polling-thread interval output-processor
+				       #!optional name)
   (let ((holder (list #f)))
     (set-car! holder
 	      (register-inferior-thread!
@@ -593,7 +597,8 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
 				     (exit-current-thread unspecific))
 				    (registration
 				     (inferior-thread-output! registration))))
-			    (sleep-current-thread interval))))))
+			    (sleep-current-thread interval)))
+			name)))
 		 (detach-thread thread)
 		 thread)
 	       output-processor))
diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm
index 711380dfb..dc85f554a 100644
--- a/src/edwin/intmod.scm
+++ b/src/edwin/intmod.scm
@@ -138,7 +138,8 @@ evaluated in the specified inferior REPL buffer."
 	     (lambda ()
 	       (signal-thread-event editor-thread
 		 (lambda ()
-		   (unwind-inferior-repl-buffer buffer)))))))))))
+		   (unwind-inferior-repl-buffer buffer)))))))))
+    buffer))
 
 (define (make-init-message message)
   (if message
diff --git a/src/edwin/notify.scm b/src/edwin/notify.scm
index 00fb94dd1..8a0661a0d 100644
--- a/src/edwin/notify.scm
+++ b/src/edwin/notify.scm
@@ -181,7 +181,8 @@ which can show various things including time, load average, and mail status."
     (set! notifier-thread-registration
 	  (start-standard-polling-thread (* (ref-variable notify-interval #f)
 					    1000)
-					 notifier))
+					 notifier
+					 (cons 'notifier current-editor)))
     unspecific))
 
 (define (notifier)
diff --git a/src/edwin/world-monitor.scm b/src/edwin/world-monitor.scm
index d98061a1b..b65b831fd 100644
--- a/src/edwin/world-monitor.scm
+++ b/src/edwin/world-monitor.scm
@@ -51,13 +51,12 @@ it, and spawn a thread to update it after every
   (set-buffer-major-mode! buffer (ref-mode-object read-only))
   (local-set-variable! truncate-lines #t buffer)
   (let ((registration #f)
-	(report #f)
-	(thread-flags (list (cons (current-thread) "edwin"))))
+	(report #f))
 
     (define (new-report)
       (call-with-output-string
 	(lambda (port)
-	  (world-report port thread-flags))))
+	  (world-report port))))
 
     (define (sleep)
       (sleep-current-thread
@@ -80,10 +79,9 @@ it, and spawn a thread to update it after every
 		       (if registration
 			   (deregister-inferior-thread! registration))
 		       (set! registration #f)
-		       (exit-current-thread #t))))))))
-
+		       (exit-current-thread #t)))))
+	     buffer)))
       (buffer-put! buffer 'WORLD-MONITOR monitor)
-      (set! thread-flags (cons (cons monitor "monitor") thread-flags))
       (update-world-monitor! buffer (new-report))
       (set-buffer-point! buffer (buffer-start buffer))
       (set! registration
diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm
index 076860a3f..d323f469d 100644
--- a/src/imail/imail-imap.scm
+++ b/src/imail/imail-imap.scm
@@ -741,7 +741,8 @@ USA.
 	   (set! connection-closure-thread-registration
 		 (start-standard-polling-thread
 		  connection-closure-thread-interval
-		  connection-closure-output-processor))
+		  connection-closure-output-processor
+		  'connection-closure-thread))
 	   unspecific)))))
 
 (define (connection-closure-output-processor)
diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm
index 9ab5d25c5..7aaaa8cbd 100644
--- a/src/imail/imail-top.scm
+++ b/src/imail/imail-top.scm
@@ -2229,7 +2229,8 @@ WARNING: With a prefix argument, this command may take a very long
 				  (start-standard-polling-thread
 				   (* 1000 interval)
 				   (probe-folder-output-processor
-				    (weak-cons folder unspecific)))))))))))
+				    (weak-cons folder unspecific))
+				   folder)))))))))
 
 (define ((probe-folder-output-processor folder))
   (let ((folder (weak-car folder)))