From 83fc8f3154fa6ffe1c9451399eb23586ae07357d Mon Sep 17 00:00:00 2001
From: David Lichteblau <david@lichteblau.com>
Date: Tue, 18 Sep 2012 19:33:10 +0200
Subject: [PATCH] New predicate THREAD-EPHEMERAL-P for certain system threads

Adds an `ephemeral' flag to the thread structure and exports it.
When true, we can assume that the thread will be started and stopped
by the runtime automatically as needed.

The flag is currently of a purely informational nature; it does not
change the behaviour of thread-related functions.

Thanks to Anton Kovalenko.
---
 package-data-list.lisp-expr |    1 +
 src/code/target-thread.lisp |   12 ++++++++++--
 src/code/thread.lisp        |    1 +
 tests/test-util.lisp        |    3 ++-
 4 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index bad7f20..d3829cf 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2019,6 +2019,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "THREAD-ERROR"
                "THREAD-ERROR-THREAD"
                "THREAD-ALIVE-P"
+               "THREAD-EMPHEMERAL-P"
                "THREAD-NAME"
                "THREAD-YIELD"
                ;; Memory barrier
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 0ec0b37..ec60aab 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -220,6 +220,14 @@ potentially stale even before the function returns, as the thread may exit at
 any time."
   (thread-%alive-p thread))
 
+(defun thread-emphemeral-p (thread)
+  #!+sb-doc
+  "Return T if THREAD is `ephemeral', which indicates that this thread is
+used by SBCL for internal purposes, and specifically that it knows how to
+to terminate this thread cleanly prior to core file saving without signalling
+an error in that case."
+  (thread-%ephemeral-p thread))
+
 ;; A thread is eligible for gc iff it has finished and there are no
 ;; more references to it. This list is supposed to keep a reference to
 ;; all running threads.
@@ -1341,7 +1349,7 @@ have the foreground next."
 
 ;;;; The beef
 
-(defun make-thread (function &key name arguments)
+(defun make-thread (function &key name arguments ephemeral)
   #!+sb-doc
   "Create a new thread of NAME that runs FUNCTION with the argument
 list designator provided (defaults to no argument). Thread exits when
@@ -1362,7 +1370,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
   #!+sb-thread
   (tagbody
      (with-mutex (*make-thread-lock*)
-       (let* ((thread (%make-thread :name name))
+       (let* ((thread (%make-thread :name name :%ephemeral-p ephemeral))
               (setup-sem (make-semaphore :name "Thread setup semaphore"))
               (real-function (coerce function 'function))
               (arguments     (if (listp arguments)
diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index d796f60..bbd9e30 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -20,6 +20,7 @@
 in future versions."
   (name          nil :type (or thread-name null))
   (%alive-p      nil :type boolean)
+  (%ephemeral-p  nil :type boolean)
   (os-thread     nil :type (or integer null))
   (interruptions nil :type list)
   (result        nil :type list)
diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 43bafa0..1d44174 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -72,7 +72,8 @@
                     (dolist (thread (sb-thread:list-all-threads))
                       (unless (or (not (sb-thread:thread-alive-p thread))
                                   (eql thread sb-thread:*current-thread*)
-                                  (member thread ,threads))
+                                  (member thread ,threads)
+                                  (sb-thread:thread-emphemeral-p thread))
                         (setf any-leftover thread)
                         (ignore-errors (sb-thread:terminate-thread thread))))
                     (when any-leftover
-- 
1.7.10.4