- (thread-sap
- ;; don't let the child inherit *CURRENT-THREAD* because that
- ;; can prevent gc'ing this thread while the child runs
- (let ((*current-thread* nil))
- (%create-thread
- (sb!kernel:get-lisp-obj-address
- (lambda ()
- ;; in time we'll move some of the binding presently done in C
- ;; here too
- (let ((*current-thread* thread)
- (sb!kernel::*restart-clusters* nil)
- (sb!kernel::*handler-clusters* nil)
- (sb!kernel::*condition-restarts* nil)
- (sb!impl::*descriptor-handlers* nil)) ; serve-event
- (wait-on-semaphore setup-sem)
- ;; can't use handling-end-of-the-world, because that flushes
- ;; output streams, and we don't necessarily have any (or we
- ;; could be sharing them)
- (unwind-protect
- (catch 'sb!impl::toplevel-catcher
- (catch 'sb!impl::%end-of-the-world
- (with-simple-restart
- (terminate-thread
- (format nil
- "~~@<Terminate this thread (~A)~~@:>"
- *current-thread*))
- ;; now that most things have a chance to
- ;; work properly without messing up other
- ;; threads, it's time to enable signals
- (sb!unix::reset-signal-mask)
- (unwind-protect
- (funcall real-function)
- ;; we're going down, can't handle
- ;; interrupts sanely anymore
- (let ((sb!impl::*gc-inhibit* t))
- (block-blockable-signals)
- ;; and remove what can be the last
- ;; reference to this thread
- (handle-thread-exit thread))))))
- 0))
- (values)))))))
- (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
- (error "Can't create a new thread"))
- (setf (thread-%sap thread) thread-sap)
- (with-mutex (*all-threads-lock*)
- (push thread *all-threads*))
- (with-session-lock (*session*)
- (push thread (session-threads *session*)))
- (signal-semaphore setup-sem)
- (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
- thread))
+ (initial-function
+ (lambda ()
+ ;; In time we'll move some of the binding presently done in C
+ ;; here too.
+ ;;
+ ;; KLUDGE: Here we have a magic list of variables that are
+ ;; not thread-safe for one reason or another. As people
+ ;; report problems with the thread safety of certain
+ ;; variables, (e.g. "*print-case* in multiple threads
+ ;; broken", sbcl-devel 2006-07-14), we add a few more
+ ;; bindings here. The Right Thing is probably some variant
+ ;; of Allegro's *cl-default-special-bindings*, as that is at
+ ;; least accessible to users to secure their own libraries.
+ ;; --njf, 2006-07-15
+ ;;
+ ;; As it is, this lambda must not cons until we are ready
+ ;; to run GC. Be very careful.
+ (let* ((*current-thread* thread)
+ (*restart-clusters* nil)
+ (*handler-clusters* (sb!kernel::initial-handler-clusters))
+ (*condition-restarts* nil)
+ (sb!impl::*deadline* nil)
+ (sb!impl::*step-out* nil)
+ ;; internal printer variables
+ (sb!impl::*previous-case* nil)
+ (sb!impl::*previous-readtable-case* nil)
+ (empty (vector))
+ (sb!impl::*merge-sort-temp-vector* empty)
+ (sb!impl::*zap-array-data-temp* empty)
+ (sb!impl::*internal-symbol-output-fun* nil)
+ (sb!impl::*descriptor-handlers* nil)) ; serve-event
+ ;; Binding from C
+ (setf sb!vm:*alloc-signal* *default-alloc-signal*)
+ (setf (thread-os-thread thread) (current-thread-os-thread))
+ (with-mutex ((thread-result-lock thread))
+ (with-all-threads-lock
+ (push thread *all-threads*))
+ (with-session-lock (*session*)
+ (push thread (session-threads *session*)))
+ (setf (thread-%alive-p thread) t)
+ (signal-semaphore setup-sem)
+ ;; can't use handling-end-of-the-world, because that flushes
+ ;; output streams, and we don't necessarily have any (or we
+ ;; could be sharing them)
+ (catch 'sb!impl::toplevel-catcher
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (terminate-thread
+ (format nil
+ "~~@<Terminate this thread (~A)~~@:>"
+ *current-thread*))
+ (without-interrupts
+ (unwind-protect
+ (with-local-interrupts
+ ;; Now that most things have a chance
+ ;; to work properly without messing up
+ ;; other threads, it's time to enable
+ ;; signals.
+ (sb!unix::unblock-deferrable-signals)
+ (setf (thread-result thread)
+ (cons t
+ (multiple-value-list
+ (funcall real-function))))
+ ;; Try to block deferrables. An
+ ;; interrupt may unwind it, but for a
+ ;; normal exit it prevents interrupt
+ ;; loss.
+ (block-deferrable-signals))
+ ;; We're going down, can't handle interrupts
+ ;; sanely anymore. GC remains enabled.
+ (block-deferrable-signals)
+ ;; We don't want to run interrupts in a dead
+ ;; thread when we leave WITHOUT-INTERRUPTS.
+ ;; This potentially causes important
+ ;; interupts to be lost: SIGINT comes to
+ ;; mind.
+ (setq *interrupt-pending* nil)
+ (handle-thread-exit thread))))))))
+ (values))))
+ ;; If the starting thread is stopped for gc before it signals the
+ ;; semaphore then we'd be stuck.
+ (assert (not *gc-inhibit*))
+ ;; Keep INITIAL-FUNCTION pinned until the child thread is
+ ;; initialized properly. Wrap the whole thing in
+ ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
+ ;; thread.
+ (without-interrupts
+ (with-pinned-objects (initial-function)
+ (let ((os-thread
+ (%create-thread
+ (get-lisp-obj-address initial-function))))
+ (when (zerop os-thread)
+ (error "Can't create a new thread"))
+ (wait-on-semaphore setup-sem)
+ thread)))))
+
+(define-condition join-thread-error (error)
+ ((thread :reader join-thread-error-thread :initarg :thread))
+ #!+sb-doc
+ (:documentation "Joining thread failed.")
+ (:report (lambda (c s)
+ (format s "Joining thread failed: thread ~A ~
+ has not returned normally."
+ (join-thread-error-thread c)))))
+
+#!+sb-doc
+(setf (fdocumentation 'join-thread-error-thread 'function)
+ "The thread that we failed to join.")
+
+(defun join-thread (thread &key (default nil defaultp))
+ #!+sb-doc
+ "Suspend current thread until THREAD exits. Returns the result
+values of the thread function. If the thread does not exit normally,
+return DEFAULT if given or else signal JOIN-THREAD-ERROR."
+ (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
+ (cond ((car (thread-result thread))
+ (return-from join-thread
+ (values-list (cdr (thread-result thread)))))
+ (defaultp
+ (return-from join-thread default))))
+ (error 'join-thread-error :thread thread))