X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=773fe9c9d38c74325b31918eb0c0113ec6a9b3bf;hb=c712f88b26cd7547ee984b90e18c134401335bc3;hp=0ec0b37955211d8ee62531de0cc98d93f01e2bf6;hpb=239125681cb03e2cce08a50e9bf03589956fd125;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 0ec0b37..773fe9c 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
@@ -1352,7 +1360,7 @@ Invoking the initial ABORT restart estabilished by MAKE-THREAD
 terminates the thread.
 
 See also: RETURN-FROM-THREAD, ABORT-THREAD."
-  #!-sb-thread (declare (ignore function name arguments))
+  #!-sb-thread (declare (ignore function name arguments ephemeral))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread (assert (or (atom arguments)
                            (null (cdr (last arguments))))
@@ -1360,10 +1368,9 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                        "Argument passed to ~S, ~S, is an improper list."
                        'make-thread arguments)
   #!+sb-thread
-  (tagbody
+  (let ((thread (%make-thread :name name :%ephemeral-p ephemeral)))
      (with-mutex (*make-thread-lock*)
-       (let* ((thread (%make-thread :name name))
-              (setup-sem (make-semaphore :name "Thread setup semaphore"))
+       (let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
               (real-function (coerce function 'function))
               (arguments     (if (listp arguments)
                                  arguments
@@ -1453,15 +1460,11 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
          ;; thread.
          (without-interrupts
            (with-pinned-objects (initial-function)
-             (let ((os-thread
-                     (%create-thread
-                      (get-lisp-obj-address initial-function))))
-               (when (zerop os-thread)
-                 (go :cant-spawn))
-               (wait-on-semaphore setup-sem)
-               (return-from make-thread thread))))))
-   :cant-spawn
-     (error "Could not create a new thread.")))
+             (if (zerop
+                  (%create-thread (get-lisp-obj-address initial-function)))
+                 (setf thread nil)
+                 (wait-on-semaphore setup-sem))))))
+     (or thread (error "Could not create a new thread."))))
 
 (defun join-thread (thread &key (default nil defaultp) timeout)
   #!+sb-doc
@@ -1602,12 +1605,12 @@ the state of a thread:
   (interrupt-thread thread #'break)
 
 Short version: be careful out there."
- #!+win32
+  #!+(and (not sb-thread) win32)
+  #!+(and (not sb-thread) win32)
   (declare (ignore thread))
-  #!+win32
   (with-interrupt-bindings
     (with-interrupts (funcall function)))
-  #!-win32
+  #!-(and (not sb-thread) win32)
   (let ((os-thread (thread-os-thread thread)))
     (cond ((not os-thread)
            (error 'interrupt-thread-error :thread thread))