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