src/code/target-thread.lisp

   1 ;;;; support for threads in the target machine
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!THREAD")
  13
  14 ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
  15 ;;; necessary because threads are only supported with the conservative
  16 ;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
  17 ;;; are treated as references.
  18
  19 ;;; set the doc here because in early-thread FDOCUMENTATION is not
  20 ;;; available, yet
  21 #!+sb-doc
  22 (setf (fdocumentation '*current-thread* 'variable)
  23       "Bound in each thread to the thread itself.")
  24
  25 (defstruct (thread (:constructor %make-thread))
  26   #!+sb-doc
  27   "Thread type. Do not rely on threads being structs as it may change
  28 in future versions."
  29   name
  30   %alive-p
  31   os-thread
  32   interruptions
  33   (interruptions-lock (make-mutex :name "thread interruptions lock"))
  34   result
  35   (result-lock (make-mutex :name "thread result lock")))
  36
  37 #!+sb-doc
  38 (setf (fdocumentation 'thread-name 'function)
  39       "The name of the thread. Setfable.")
  40
  41 (def!method print-object ((thread thread) stream)
  42   (if (thread-name thread)
  43       (print-unreadable-object (thread stream :type t :identity t)
  44         (prin1 (thread-name thread) stream))
  45       (print-unreadable-object (thread stream :type t :identity t)
  46         ;; body is empty => there is only one space between type and
  47         ;; identity
  48         ))
  49   thread)
  50
  51 (defun thread-alive-p (thread)
  52   #!+sb-doc
  53   "Check if THREAD is running."
  54   (thread-%alive-p thread))
  55
  56 ;; A thread is eligible for gc iff it has finished and there are no
  57 ;; more references to it. This list is supposed to keep a reference to
  58 ;; all running threads.
  59 (defvar *all-threads* ())
  60 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
  61
  62 (defmacro with-all-threads-lock (&body body)
  63   #!-sb-thread
  64   `(locally ,@body)
  65   #!+sb-thread
  66   `(without-interrupts
  67      (with-mutex (*all-threads-lock*)
  68        ,@body)))
  69
  70 (defun list-all-threads ()
  71   #!+sb-doc
  72   "Return a list of the live threads."
  73   (with-all-threads-lock
  74     (copy-list *all-threads*)))
  75
  76 (declaim (inline current-thread-sap))
  77 (defun current-thread-sap ()
  78   (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
  79
  80 (declaim (inline current-thread-sap-id))
  81 (defun current-thread-sap-id ()
  82   (sap-int
  83    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
  84
  85 (defun init-initial-thread ()
  86   (/show0 "Entering INIT-INITIAL-THREAD")
  87   (let ((initial-thread (%make-thread :name "initial thread"
  88                                       :%alive-p t
  89                                       :os-thread (current-thread-sap-id))))
  90     (setq *current-thread* initial-thread)
  91     ;; Either *all-threads* is empty or it contains exactly one thread
  92     ;; in case we are in reinit since saving core with multiple
  93     ;; threads doesn't work.
  94     (setq *all-threads* (list initial-thread))))
  95
  96 ;;;;
  97
  98 #!+sb-thread
  99 (progn
 100   ;; FIXME it would be good to define what a thread id is or isn't
 101   ;; (our current assumption is that it's a fixnum).  It so happens
 102   ;; that on Linux it's a pid, but it might not be on posix thread
 103   ;; implementations.
 104   (define-alien-routine ("create_thread" %create-thread)
 105       unsigned-long (lisp-fun-address unsigned-long))
 106
 107   (define-alien-routine "signal_interrupt_thread"
 108       integer (os-thread unsigned-long))
 109
 110   (define-alien-routine "block_deferrable_signals"
 111       void)
 112
 113   #!+sb-lutex
 114   (progn
 115     (declaim (inline %lutex-init %lutex-wait %lutex-wake
 116                      %lutex-lock %lutex-unlock))
 117
 118     (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
 119         int (lutex unsigned-long))
 120
 121     (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait)
 122         int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
 123
 124     (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake)
 125         int (lutex unsigned-long) (n int))
 126
 127     (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
 128         int (lutex unsigned-long))
 129
 130     (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
 131         int (lutex unsigned-long))
 132
 133     (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
 134         int (lutex unsigned-long))
 135
 136     (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
 137         int (lutex unsigned-long))
 138
 139     ;; FIXME: Defining a whole bunch of alien-type machinery just for
 140     ;; passing primitive lutex objects directly to foreign functions
 141     ;; doesn't seem like fun right now. So instead we just manually
 142     ;; pin the lutex, get its address, and let the callee untag it.
 143     (defmacro with-lutex-address ((name lutex) &body body)
 144       `(let ((,name ,lutex))
 145          (with-pinned-objects (,name)
 146            (let ((,name (get-lisp-obj-address ,name)))
 147              ,@body))))
 148
 149     (defun make-lutex ()
 150       (/show0 "Entering MAKE-LUTEX")
 151       ;; Suppress GC until the lutex has been properly registered with
 152       ;; the GC.
 153       (without-gcing
 154         (let ((lutex (sb!vm::%make-lutex)))
 155           (/show0 "LUTEX=..")
 156           (/hexstr lutex)
 157           (with-lutex-address (lutex lutex)
 158             (%lutex-init lutex))
 159           lutex))))
 160
 161   #!-sb-lutex
 162   (progn
 163     (declaim (inline futex-wait futex-wake))
 164
 165     (sb!alien:define-alien-routine "futex_wait"
 166         int (word unsigned-long) (old-value unsigned-long))
 167
 168     (sb!alien:define-alien-routine "futex_wake"
 169         int (word unsigned-long) (n unsigned-long))))
 170
 171 ;;; used by debug-int.lisp to access interrupt contexts
 172 #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 173 #!-sb-thread
 174 (defun sb!vm::current-thread-offset-sap (n)
 175   (declare (type (unsigned-byte 27) n))
 176   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
 177                (* n sb!vm:n-word-bytes)))
 178
 179 #!+sb-thread
 180 (defun sb!vm::current-thread-offset-sap (n)
 181   (declare (type (unsigned-byte 27) n))
 182   (sb!vm::current-thread-offset-sap n))
 183
 184 ;;;; spinlocks
 185 #!+sb-thread
 186 (define-structure-slot-compare-and-exchange
 187     compare-and-exchange-spinlock-value
 188     :structure spinlock
 189     :slot value)
 190
 191 (declaim (inline get-spinlock release-spinlock))
 192
 193 (defun get-spinlock (spinlock)
 194   (declare (optimize (speed 3) (safety 0))
 195            #!-sb-thread
 196            (ignore spinlock))
 197   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
 198   ;; store any value
 199   #!+sb-thread
 200   (loop until
 201        (eql 0 (compare-and-exchange-spinlock-value spinlock 0 1)))
 202   t)
 203
 204 (defun release-spinlock (spinlock)
 205   (declare (optimize (speed 3) (safety 0))
 206            #!-sb-thread (ignore spinlock))
 207   ;; %instance-set-conditional cannot compare arbitrary objects
 208   ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0)
 209   ;; does not work for bignum thread ids.
 210   #!+sb-thread
 211   (setf (spinlock-value spinlock) 0)
 212   nil)
 213
 214 ;;;; mutexes
 215
 216 #!+sb-doc
 217 (setf (fdocumentation 'make-mutex 'function)
 218       "Create a mutex."
 219       (fdocumentation 'mutex-name 'function)
 220       "The name of the mutex. Setfable."
 221       (fdocumentation 'mutex-value 'function)
 222       "The value of the mutex. NIL if the mutex is free. Setfable.")
 223
 224 #!+(and sb-thread (not sb-lutex))
 225 (progn
 226   (define-structure-slot-addressor mutex-value-address
 227       :structure mutex
 228       :slot value)
 229   (define-structure-slot-compare-and-exchange
 230       compare-and-exchange-mutex-value
 231       :structure mutex
 232       :slot value))
 233
 234 (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
 235   #!+sb-doc
 236   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
 237 value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep
 238 until it is available."
 239   (declare (type mutex mutex) (optimize (speed 3)))
 240   (/show0 "Entering GET-MUTEX")
 241   (unless new-value
 242     (setq new-value *current-thread*))
 243   #!-sb-thread
 244   (let ((old-value (mutex-value mutex)))
 245     (when (and old-value wait-p)
 246       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
 247               new-value ~S, but has already been acquired (with value ~S)."
 248              mutex wait-p new-value old-value))
 249     (setf (mutex-value mutex) new-value)
 250     t)
 251   #!+sb-thread
 252   (progn
 253     (when (eql new-value (mutex-value mutex))
 254       (warn "recursive lock attempt ~S~%" mutex)
 255       (format *debug-io* "Thread: ~A~%" *current-thread*)
 256       (sb!debug:backtrace most-positive-fixnum *debug-io*)
 257       (force-output *debug-io*))
 258     #!+sb-lutex
 259     (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
 260                    (if wait-p
 261                        (%lutex-lock lutex)
 262                        (%lutex-trylock lutex))))
 263       (setf (mutex-value mutex) new-value))
 264     #!-sb-lutex
 265     (let (old)
 266       (loop
 267          (unless
 268              (setf old
 269                    (compare-and-exchange-mutex-value mutex nil new-value))
 270            (return t))
 271          (unless wait-p (return nil))
 272          (with-pinned-objects (mutex old)
 273            (futex-wait (mutex-value-address mutex)
 274                        (get-lisp-obj-address old)))))))
 275
 276 (defun release-mutex (mutex)
 277   #!+sb-doc
 278   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 279 this mutex."
 280   (declare (type mutex mutex))
 281   (/show0 "Entering RELEASE-MUTEX")
 282   (setf (mutex-value mutex) nil)
 283   #!+sb-thread
 284   (progn
 285     #!+sb-lutex
 286     (with-lutex-address (lutex (mutex-lutex mutex))
 287       (%lutex-unlock lutex))
 288     #!-sb-lutex
 289     (futex-wake (mutex-value-address mutex) 1)))
 290
 291 ;;;; waitqueues/condition variables
 292
 293 (defstruct (waitqueue (:constructor %make-waitqueue))
 294   #!+sb-doc
 295   "Waitqueue type."
 296   (name nil :type (or null simple-string))
 297   #!+(and sb-lutex sb-thread)
 298   (lutex (make-lutex))
 299   #!-sb-lutex
 300   (data nil))
 301
 302 (defun make-waitqueue (&key name)
 303   #!+sb-doc
 304   "Create a waitqueue."
 305   (%make-waitqueue :name name))
 306
 307 #!+sb-doc
 308 (setf (fdocumentation 'waitqueue-name 'function)
 309       "The name of the waitqueue. Setfable.")
 310
 311 #!+(and sb-thread (not sb-lutex))
 312 (define-structure-slot-addressor waitqueue-data-address
 313     :structure waitqueue
 314     :slot data)
 315
 316 (defun condition-wait (queue mutex)
 317   #!+sb-doc
 318   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
 319 thread may subsequently notify us using CONDITION-NOTIFY, at which
 320 time we reacquire MUTEX and return to the caller."
 321   #!-sb-thread (declare (ignore queue))
 322   (assert mutex)
 323   #!-sb-thread (error "Not supported in unithread builds.")
 324   #!+sb-thread
 325   (let ((value (mutex-value mutex)))
 326     (/show0 "CONDITION-WAITing")
 327     #!+sb-lutex
 328     (progn
 329       (setf (mutex-value mutex) nil)
 330       (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
 331         (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
 332           (%lutex-wait queue-lutex-address mutex-lutex-address)))
 333       (setf (mutex-value mutex) value))
 334     #!-sb-lutex
 335     (unwind-protect
 336          (let ((me *current-thread*))
 337            ;; XXX we should do something to ensure that the result of this setf
 338            ;; is visible to all CPUs
 339            (setf (waitqueue-data queue) me)
 340            (release-mutex mutex)
 341            ;; Now we go to sleep using futex-wait.  If anyone else
 342            ;; manages to grab MUTEX and call CONDITION-NOTIFY during
 343            ;; this comment, it will change queue->data, and so
 344            ;; futex-wait returns immediately instead of sleeping.
 345            ;; Ergo, no lost wakeup
 346            (with-pinned-objects (queue me)
 347              (futex-wait (waitqueue-data-address queue)
 348                          (get-lisp-obj-address me))))
 349       ;; If we are interrupted while waiting, we should do these things
 350       ;; before returning.  Ideally, in the case of an unhandled signal,
 351       ;; we should do them before entering the debugger, but this is
 352       ;; better than nothing.
 353       (get-mutex mutex value))))
 354
 355 (defun condition-notify (queue &optional (n 1))
 356   #!+sb-doc
 357   "Notify N threads waiting on QUEUE."
 358   #!-sb-thread (declare (ignore queue n))
 359   #!-sb-thread (error "Not supported in unithread builds.")
 360   #!+sb-thread
 361   (declare (type (and fixnum (integer 1)) n))
 362   (/show0 "Entering CONDITION-NOTIFY")
 363   #!+sb-thread
 364   (progn
 365     #!+sb-lutex
 366     (with-lutex-address (lutex (waitqueue-lutex queue))
 367       (%lutex-wake lutex n))
 368     ;; no problem if >1 thread notifies during the comment in
 369     ;; condition-wait: as long as the value in queue-data isn't the
 370     ;; waiting thread's id, it matters not what it is
 371     ;; XXX we should do something to ensure that the result of this setf
 372     ;; is visible to all CPUs
 373     #!-sb-lutex
 374     (let ((me *current-thread*))
 375       (progn
 376         (setf (waitqueue-data queue) me)
 377         (with-pinned-objects (queue)
 378           (futex-wake (waitqueue-data-address queue) n))))))
 379
 380 (defun condition-broadcast (queue)
 381   #!+sb-doc
 382   "Notify all threads waiting on QUEUE."
 383   (condition-notify queue
 384                     ;; On a 64-bit platform truncating M-P-F to an int results
 385                     ;; in -1, which wakes up only one thread.
 386                     (ldb (byte 29 0)
 387                          most-positive-fixnum)))
 388
 389 ;;;; semaphores
 390
 391 (defstruct (semaphore (:constructor %make-semaphore))
 392   #!+sb-doc
 393   "Semaphore type."
 394   (name nil :type (or null simple-string))
 395   (count 0 :type (integer 0))
 396   (mutex (make-mutex))
 397   (queue (make-waitqueue)))
 398
 399 (defun make-semaphore (&key name (count 0))
 400   #!+sb-doc
 401   "Create a semaphore with the supplied COUNT."
 402   (%make-semaphore :name name :count count))
 403
 404 (setf (fdocumentation 'semaphore-name 'function)
 405       "The name of the semaphore. Setfable.")
 406
 407 (defun wait-on-semaphore (sem)
 408   #!+sb-doc
 409   "Decrement the count of SEM if the count would not be negative. Else
 410 block until the semaphore can be decremented."
 411   ;; a more direct implementation based directly on futexes should be
 412   ;; possible
 413   (with-mutex ((semaphore-mutex sem))
 414     (loop until (> (semaphore-count sem) 0)
 415           do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
 416           finally (decf (semaphore-count sem)))))
 417
 418 (defun signal-semaphore (sem &optional (n 1))
 419   #!+sb-doc
 420   "Increment the count of SEM by N. If there are threads waiting on
 421 this semaphore, then N of them is woken up."
 422   (declare (type (and fixnum (integer 1)) n))
 423   (with-mutex ((semaphore-mutex sem))
 424     (when (= n (incf (semaphore-count sem) n))
 425       (condition-notify (semaphore-queue sem) n))))
 426
 427 ;;;; job control, independent listeners
 428
 429 (defstruct session
 430   (lock (make-mutex :name "session lock"))
 431   (threads nil)
 432   (interactive-threads nil)
 433   (interactive-threads-queue (make-waitqueue)))
 434
 435 (defvar *session* nil)
 436
 437 ;;; the debugger itself tries to acquire the session lock, don't let
 438 ;;; funny situations (like getting a sigint while holding the session
 439 ;;; lock) occur
 440 (defmacro with-session-lock ((session) &body body)
 441   #!-sb-thread (declare (ignore session))
 442   #!-sb-thread
 443   `(locally ,@body)
 444   #!+sb-thread
 445   `(without-interrupts
 446      (with-mutex ((session-lock ,session))
 447        ,@body)))
 448
 449 (defun new-session ()
 450   (make-session :threads (list *current-thread*)
 451                 :interactive-threads (list *current-thread*)))
 452
 453 (defun init-job-control ()
 454   (/show0 "Entering INIT-JOB-CONTROL")
 455   (setf *session* (new-session))
 456   (/show0 "Exiting INIT-JOB-CONTROL"))
 457
 458 (defun %delete-thread-from-session (thread session)
 459   (with-session-lock (session)
 460     (setf (session-threads session)
 461           (delete thread (session-threads session))
 462           (session-interactive-threads session)
 463           (delete thread (session-interactive-threads session)))))
 464
 465 (defun call-with-new-session (fn)
 466   (%delete-thread-from-session *current-thread* *session*)
 467   (let ((*session* (new-session)))
 468     (funcall fn)))
 469
 470 (defmacro with-new-session (args &body forms)
 471   (declare (ignore args))               ;for extensibility
 472   (sb!int:with-unique-names (fb-name)
 473     `(labels ((,fb-name () ,@forms))
 474       (call-with-new-session (function ,fb-name)))))
 475
 476 ;;; Remove thread from its session, if it has one.
 477 #!+sb-thread
 478 (defun handle-thread-exit (thread)
 479   (/show0 "HANDLING THREAD EXIT")
 480   ;; We're going down, can't handle interrupts sanely anymore.
 481   ;; GC remains enabled.
 482   (block-deferrable-signals)
 483   ;; Lisp-side cleanup
 484   (with-all-threads-lock
 485     (setf (thread-%alive-p thread) nil)
 486     (setf (thread-os-thread thread) nil)
 487     (setq *all-threads* (delete thread *all-threads*))
 488     (when *session*
 489       (%delete-thread-from-session thread *session*)))
 490   #!+sb-lutex
 491   (without-gcing
 492     (/show0 "FREEING MUTEX LUTEX")
 493     (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
 494       (%lutex-destroy lutex))))
 495
 496 (defun terminate-session ()
 497   #!+sb-doc
 498   "Kill all threads in session except for this one.  Does nothing if current
 499 thread is not the foreground thread."
 500   ;; FIXME: threads created in other threads may escape termination
 501   (let ((to-kill
 502          (with-session-lock (*session*)
 503            (and (eq *current-thread*
 504                     (car (session-interactive-threads *session*)))
 505                 (session-threads *session*)))))
 506     ;; do the kill after dropping the mutex; unwind forms in dying
 507     ;; threads may want to do session things
 508     (dolist (thread to-kill)
 509       (unless (eq thread *current-thread*)
 510         ;; terminate the thread but don't be surprised if it has
 511         ;; exited in the meantime
 512         (handler-case (terminate-thread thread)
 513           (interrupt-thread-error ()))))))
 514
 515 ;;; called from top of invoke-debugger
 516 (defun debugger-wait-until-foreground-thread (stream)
 517   "Returns T if thread had been running in background, NIL if it was
 518 interactive."
 519   (declare (ignore stream))
 520   #!-sb-thread nil
 521   #!+sb-thread
 522   (prog1
 523       (with-session-lock (*session*)
 524         (not (member *current-thread*
 525                      (session-interactive-threads *session*))))
 526     (get-foreground)))
 527
 528 (defun get-foreground ()
 529   #!-sb-thread t
 530   #!+sb-thread
 531   (let ((was-foreground t))
 532     (loop
 533      (/show0 "Looping in GET-FOREGROUND")
 534      (with-session-lock (*session*)
 535        (let ((int-t (session-interactive-threads *session*)))
 536          (when (eq (car int-t) *current-thread*)
 537            (unless was-foreground
 538              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 539            (return-from get-foreground t))
 540          (setf was-foreground nil)
 541          (unless (member *current-thread* int-t)
 542            (setf (cdr (last int-t))
 543                  (list *current-thread*)))
 544          (condition-wait
 545           (session-interactive-threads-queue *session*)
 546           (session-lock *session*)))))))
 547
 548 (defun release-foreground (&optional next)
 549   #!+sb-doc
 550   "Background this thread.  If NEXT is supplied, arrange for it to
 551 have the foreground next."
 552   #!-sb-thread (declare (ignore next))
 553   #!-sb-thread nil
 554   #!+sb-thread
 555   (with-session-lock (*session*)
 556     (when (rest (session-interactive-threads *session*))
 557       (setf (session-interactive-threads *session*)
 558             (delete *current-thread* (session-interactive-threads *session*))))
 559     (when next
 560       (setf (session-interactive-threads *session*)
 561             (list* next
 562                    (delete next (session-interactive-threads *session*)))))
 563     (condition-broadcast (session-interactive-threads-queue *session*))))
 564
 565 (defun foreground-thread ()
 566   (car (session-interactive-threads *session*)))
 567
 568 (defun make-listener-thread (tty-name)
 569   (assert (probe-file tty-name))
 570   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 571          (out (sb!unix:unix-dup in))
 572          (err (sb!unix:unix-dup in)))
 573     (labels ((thread-repl ()
 574                (sb!unix::unix-setsid)
 575                (let* ((sb!impl::*stdin*
 576                        (make-fd-stream in :input t :buffering :line
 577                                        :dual-channel-p t))
 578                       (sb!impl::*stdout*
 579                        (make-fd-stream out :output t :buffering :line
 580                                               :dual-channel-p t))
 581                       (sb!impl::*stderr*
 582                        (make-fd-stream err :output t :buffering :line
 583                                               :dual-channel-p t))
 584                       (sb!impl::*tty*
 585                        (make-fd-stream err :input t :output t
 586                                               :buffering :line
 587                                               :dual-channel-p t))
 588                       (sb!impl::*descriptor-handlers* nil))
 589                  (with-new-session ()
 590                    (unwind-protect
 591                         (sb!impl::toplevel-repl nil)
 592                      (sb!int:flush-standard-output-streams))))))
 593       (make-thread #'thread-repl))))
 594
 595 ;;;; the beef
 596
 597 (defun make-thread (function &key name)
 598   #!+sb-doc
 599   "Create a new thread of NAME that runs FUNCTION. When the function
 600 returns the thread exits. The return values of FUNCTION are kept
 601 around and can be retrieved by JOIN-THREAD."
 602   #!-sb-thread (declare (ignore function name))
 603   #!-sb-thread (error "Not supported in unithread builds.")
 604   #!+sb-thread
 605   (let* ((thread (%make-thread :name name))
 606          (setup-sem (make-semaphore :name "Thread setup semaphore"))
 607          (real-function (coerce function 'function))
 608          (initial-function
 609           (lambda ()
 610             ;; In time we'll move some of the binding presently done in C
 611             ;; here too.
 612             ;;
 613             ;; KLUDGE: Here we have a magic list of variables that are
 614             ;; not thread-safe for one reason or another.  As people
 615             ;; report problems with the thread safety of certain
 616             ;; variables, (e.g. "*print-case* in multiple threads
 617             ;; broken", sbcl-devel 2006-07-14), we add a few more
 618             ;; bindings here.  The Right Thing is probably some variant
 619             ;; of Allegro's *cl-default-special-bindings*, as that is at
 620             ;; least accessible to users to secure their own libraries.
 621             ;;   --njf, 2006-07-15
 622             (let ((*current-thread* thread)
 623                   (*restart-clusters* nil)
 624                   (*handler-clusters* nil)
 625                   (*condition-restarts* nil)
 626                   (sb!impl::*step-out* nil)
 627                   ;; internal printer variables
 628                   (sb!impl::*previous-case* nil)
 629                   (sb!impl::*previous-readtable-case* nil)
 630                   (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
 631                   (sb!impl::*zap-array-data-temp* (vector))    ;
 632                   (sb!impl::*internal-symbol-output-fun* nil)
 633                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
 634               (setf (thread-os-thread thread) (current-thread-sap-id))
 635               (with-mutex ((thread-result-lock thread))
 636                 (with-all-threads-lock
 637                   (push thread *all-threads*))
 638                 (with-session-lock (*session*)
 639                   (push thread (session-threads *session*)))
 640                 (setf (thread-%alive-p thread) t)
 641                 (signal-semaphore setup-sem)
 642                 ;; can't use handling-end-of-the-world, because that flushes
 643                 ;; output streams, and we don't necessarily have any (or we
 644                 ;; could be sharing them)
 645                 (catch 'sb!impl::toplevel-catcher
 646                   (catch 'sb!impl::%end-of-the-world
 647                     (with-simple-restart
 648                         (terminate-thread
 649                          (format nil
 650                                  "~~@<Terminate this thread (~A)~~@:>"
 651                                  *current-thread*))
 652                       (unwind-protect
 653                            (progn
 654                              ;; now that most things have a chance to
 655                              ;; work properly without messing up other
 656                              ;; threads, it's time to enable signals
 657                              (sb!unix::reset-signal-mask)
 658                              (setf (thread-result thread)
 659                                    (cons t
 660                                          (multiple-value-list
 661                                           (funcall real-function)))))
 662                         (handle-thread-exit thread)))))))
 663             (values))))
 664     ;; Keep INITIAL-FUNCTION pinned until the child thread is
 665     ;; initialized properly.
 666     (with-pinned-objects (initial-function)
 667       (let ((os-thread
 668              (%create-thread
 669               (get-lisp-obj-address initial-function))))
 670         (when (zerop os-thread)
 671           (error "Can't create a new thread"))
 672         (wait-on-semaphore setup-sem)
 673         thread))))
 674
 675 (define-condition join-thread-error (error)
 676   ((thread :reader join-thread-error-thread :initarg :thread))
 677   #!+sb-doc
 678   (:documentation "Joining thread failed.")
 679   (:report (lambda (c s)
 680              (format s "Joining thread failed: thread ~A ~
 681                         has not returned normally."
 682                      (join-thread-error-thread c)))))
 683
 684 #!+sb-doc
 685 (setf (fdocumentation 'join-thread-error-thread 'function)
 686       "The thread that we failed to join.")
 687
 688 (defun join-thread (thread &key (default nil defaultp))
 689   #!+sb-doc
 690   "Suspend current thread until THREAD exits. Returns the result
 691 values of the thread function. If the thread does not exit normally,
 692 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
 693   (with-mutex ((thread-result-lock thread))
 694     (cond ((car (thread-result thread))
 695            (values-list (cdr (thread-result thread))))
 696           (defaultp
 697            default)
 698           (t
 699            (error 'join-thread-error :thread thread)))))
 700
 701 (defun destroy-thread (thread)
 702   #!+sb-doc
 703   "Deprecated. Same as TERMINATE-THREAD."
 704   (terminate-thread thread))
 705
 706 (define-condition interrupt-thread-error (error)
 707   ((thread :reader interrupt-thread-error-thread :initarg :thread))
 708   #!+sb-doc
 709   (:documentation "Interrupting thread failed.")
 710   (:report (lambda (c s)
 711              (format s "Interrupt thread failed: thread ~A has exited."
 712                      (interrupt-thread-error-thread c)))))
 713
 714 #!+sb-doc
 715 (setf (fdocumentation 'interrupt-thread-error-thread 'function)
 716       "The thread that was not interrupted.")
 717
 718 (defmacro with-interruptions-lock ((thread) &body body)
 719   `(without-interrupts
 720      (with-mutex ((thread-interruptions-lock ,thread))
 721        ,@body)))
 722
 723 ;; Called from the signal handler.
 724 (defun run-interruption ()
 725   (in-interruption ()
 726     (loop
 727        (let ((interruption (with-interruptions-lock (*current-thread*)
 728                              (pop (thread-interruptions *current-thread*)))))
 729          (if interruption
 730              (with-interrupts
 731                (funcall interruption))
 732              (return))))))
 733
 734 ;; The order of interrupt execution is peculiar. If thread A
 735 ;; interrupts thread B with I1, I2 and B for some reason receives I1
 736 ;; when FUN2 is already on the list, then it is FUN2 that gets to run
 737 ;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
 738 ;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
 739 ;; just one scenario, and the order of thread interrupt execution is
 740 ;; undefined.
 741 (defun interrupt-thread (thread function)
 742   #!+sb-doc
 743   "Interrupt the live THREAD and make it run FUNCTION. A moderate
 744 degree of care is expected for use of INTERRUPT-THREAD, due to its
 745 nature: if you interrupt a thread that was holding important locks
 746 then do something that turns out to need those locks, you probably
 747 won't like the effect."
 748   #!-sb-thread (declare (ignore thread))
 749   ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
 750   ;; into account
 751   #!-sb-thread
 752   (funcall function)
 753   #!+sb-thread
 754   (if (eq thread *current-thread*)
 755       (funcall function)
 756       (let ((os-thread (thread-os-thread thread)))
 757         (cond ((not os-thread)
 758                (error 'interrupt-thread-error :thread thread))
 759               (t
 760                (with-interruptions-lock (thread)
 761                  (push function (thread-interruptions thread)))
 762                (when (minusp (signal-interrupt-thread os-thread))
 763                  (error 'interrupt-thread-error :thread thread)))))))
 764
 765 (defun terminate-thread (thread)
 766   #!+sb-doc
 767   "Terminate the thread identified by THREAD, by causing it to run
 768 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 769   (interrupt-thread thread 'sb!ext:quit))
 770
 771 ;;; internal use only.  If you think you need to use this, either you
 772 ;;; are an SBCL developer, are doing something that you should discuss
 773 ;;; with an SBCL developer first, or are doing something that you
 774 ;;; should probably discuss with a professional psychiatrist first
 775 #!+sb-thread
 776 (defun thread-sap-for-id (id)
 777   (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
 778     (loop
 779      (when (sap= thread-sap (int-sap 0)) (return nil))
 780      (let ((os-thread (sap-ref-word thread-sap
 781                                     (* sb!vm:n-word-bytes
 782                                        sb!vm::thread-os-thread-slot))))
 783        (when (= os-thread id) (return thread-sap))
 784        (setf thread-sap
 785              (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
 786                                         sb!vm::thread-next-slot)))))))
 787
 788 #!+sb-thread
 789 (defun symbol-value-in-thread (symbol thread-sap)
 790   (let* ((index (sb!vm::symbol-tls-index symbol))
 791          (tl-val (sap-ref-word thread-sap
 792                                (* sb!vm:n-word-bytes index))))
 793     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
 794         (sb!vm::symbol-global-value symbol)
 795         (make-lisp-obj tl-val))))
 796
 797 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
 798   (sb!vm::locked-symbol-global-value-add symbol-name delta))
 799
 800 ;;; Stepping
 801
 802 (defun thread-stepping ()
 803   (make-lisp-obj
 804    (sap-ref-word (current-thread-sap)
 805                  (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
 806
 807 (defun (setf thread-stepping) (value)
 808   (setf (sap-ref-word (current-thread-sap)
 809                       (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
 810         (get-lisp-obj-address value)))