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 (sb!kernel: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
  35 #!+sb-doc
  36 (setf (sb!kernel:fdocumentation 'thread-name 'function)
  37       "The name of the thread. Setfable.")
  38
  39 (def!method print-object ((thread thread) stream)
  40   (if (thread-name thread)
  41       (print-unreadable-object (thread stream :type t :identity t)
  42         (prin1 (thread-name thread) stream))
  43       (print-unreadable-object (thread stream :type t :identity t)
  44         ;; body is empty => there is only one space between type and
  45         ;; identity
  46         ))
  47   thread)
  48
  49 (defun thread-alive-p (thread)
  50   #!+sb-doc
  51   "Check if THREAD is running."
  52   (thread-%alive-p thread))
  53
  54 ;; A thread is eligible for gc iff it has finished and there are no
  55 ;; more references to it. This list is supposed to keep a reference to
  56 ;; all running threads.
  57 (defvar *all-threads* ())
  58 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
  59
  60 (defun list-all-threads ()
  61   #!+sb-doc
  62   "Return a list of the live threads."
  63   (with-mutex (*all-threads-lock*)
  64     (copy-list *all-threads*)))
  65
  66 (declaim (inline current-thread-sap))
  67 (defun current-thread-sap ()
  68   (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
  69
  70 (declaim (inline current-thread-sap-id))
  71 (defun current-thread-sap-id ()
  72   (sap-int
  73    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
  74
  75 (defun init-initial-thread ()
  76   (let ((initial-thread (%make-thread :name "initial thread"
  77                                       :%alive-p t
  78                                       :os-thread (current-thread-sap-id))))
  79     (setq *current-thread* initial-thread)
  80     ;; Either *all-threads* is empty or it contains exactly one thread
  81     ;; in case we are in reinit since saving core with multiple
  82     ;; threads doesn't work.
  83     (setq *all-threads* (list initial-thread))))
  84
  85 ;;;;
  86
  87 #!+sb-thread
  88 (progn
  89   ;; FIXME it would be good to define what a thread id is or isn't
  90   ;; (our current assumption is that it's a fixnum).  It so happens
  91   ;; that on Linux it's a pid, but it might not be on posix thread
  92   ;; implementations.
  93   (define-alien-routine ("create_thread" %create-thread)
  94       unsigned-long (lisp-fun-address unsigned-long))
  95
  96   (define-alien-routine "signal_interrupt_thread"
  97       integer (os-thread unsigned-long))
  98
  99   (define-alien-routine "block_blockable_signals"
 100       void)
 101
 102   (declaim (inline futex-wait futex-wake))
 103
 104   (sb!alien:define-alien-routine "futex_wait"
 105       int (word unsigned-long) (old-value unsigned-long))
 106
 107   (sb!alien:define-alien-routine "futex_wake"
 108       int (word unsigned-long) (n unsigned-long)))
 109
 110 ;;; used by debug-int.lisp to access interrupt contexts
 111 #!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 112 #!-sb-thread
 113 (defun sb!vm::current-thread-offset-sap (n)
 114   (declare (type (unsigned-byte 27) n))
 115   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
 116                (* n sb!vm:n-word-bytes)))
 117
 118 ;;;; spinlocks
 119
 120 (declaim (inline get-spinlock release-spinlock))
 121
 122 ;;; The bare 2 here and below are offsets of the slots in the struct.
 123 ;;; There ought to be some better way to get these numbers
 124 (defun get-spinlock (spinlock)
 125   (declare (optimize (speed 3) (safety 0))
 126            #!-sb-thread
 127            (ignore spinlock new-value))
 128   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
 129   ;; store any value
 130   #!+sb-thread
 131   (loop until
 132         (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)))
 133
 134 (defun release-spinlock (spinlock)
 135   (declare (optimize (speed 3) (safety 0))
 136            #!-sb-thread (ignore spinlock))
 137   ;; %instance-set-conditional cannot compare arbitrary objects
 138   ;; meaningfully, so
 139   ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0)
 140   ;; does not work for bignum thread ids.
 141   #!+sb-thread
 142   (sb!vm::%instance-set spinlock 2 0))
 143
 144 (defmacro with-spinlock ((spinlock) &body body)
 145   (sb!int:with-unique-names (lock)
 146     `(let ((,lock ,spinlock))
 147       (get-spinlock ,lock)
 148       (unwind-protect
 149            (progn ,@body)
 150         (release-spinlock ,lock)))))
 151
 152 ;;;; mutexes
 153
 154 #!+sb-doc
 155 (setf (sb!kernel:fdocumentation 'make-mutex 'function)
 156       "Create a mutex."
 157       (sb!kernel:fdocumentation 'mutex-name 'function)
 158       "The name of the mutex. Setfable."
 159       (sb!kernel:fdocumentation 'mutex-value 'function)
 160       "The value of the mutex. NIL if the mutex is free. Setfable.")
 161
 162 #!+sb-thread
 163 (declaim (inline mutex-value-address))
 164 #!+sb-thread
 165 (defun mutex-value-address (mutex)
 166   (declare (optimize (speed 3)))
 167   (sb!ext:truly-the
 168    sb!vm:word
 169    (+ (sb!kernel:get-lisp-obj-address mutex)
 170       (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
 171
 172 (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
 173   #!+sb-doc
 174   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
 175 value if NIL.  If WAIT-P is non-NIL and the mutex is in use, sleep
 176 until it is available"
 177   (declare (type mutex mutex) (optimize (speed 3)))
 178   (unless new-value
 179     (setq new-value *current-thread*))
 180   #!-sb-thread
 181   (let ((old-value (mutex-value mutex)))
 182     (when (and old-value wait-p)
 183       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
 184               new-value ~S, but has already been acquired (with value ~S)."
 185              mutex wait-p new-value old-value))
 186     (setf (mutex-value mutex) new-value)
 187     t)
 188   #!+sb-thread
 189   (let (old)
 190     (when (eql new-value (mutex-value mutex))
 191       (warn "recursive lock attempt ~S~%" mutex)
 192       (format *debug-io* "Thread: ~A~%" *current-thread*)
 193       (sb!debug:backtrace most-positive-fixnum *debug-io*)
 194       (force-output *debug-io*))
 195     (loop
 196      (unless
 197          (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
 198        (return t))
 199      (unless wait-p (return nil))
 200      (with-pinned-objects (mutex old)
 201        (futex-wait (mutex-value-address mutex)
 202                    (sb!kernel:get-lisp-obj-address old))))))
 203
 204 (defun release-mutex (mutex)
 205   #!+sb-doc
 206   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 207 this mutex."
 208   (declare (type mutex mutex))
 209   (setf (mutex-value mutex) nil)
 210   #!+sb-thread
 211   (futex-wake (mutex-value-address mutex) 1))
 212
 213 ;;;; waitqueues/condition variables
 214
 215 (defstruct (waitqueue (:constructor %make-waitqueue))
 216   #!+sb-doc
 217   "Waitqueue type."
 218   (name nil :type (or null simple-string))
 219   (data nil))
 220
 221 (defun make-waitqueue (&key name)
 222   #!+sb-doc
 223   "Create a waitqueue."
 224   (%make-waitqueue :name name))
 225
 226 #!+sb-doc
 227 (setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
 228       "The name of the waitqueue. Setfable.")
 229
 230 #!+sb-thread
 231 (declaim (inline waitqueue-data-address))
 232 #!+sb-thread
 233 (defun waitqueue-data-address (waitqueue)
 234   (declare (optimize (speed 3)))
 235   (sb!ext:truly-the
 236    sb!vm:word
 237    (+ (sb!kernel:get-lisp-obj-address waitqueue)
 238       (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
 239
 240 (defun condition-wait (queue mutex)
 241   #!+sb-doc
 242   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
 243 thread may subsequently notify us using CONDITION-NOTIFY, at which
 244 time we reacquire MUTEX and return to the caller."
 245   #!-sb-thread (declare (ignore queue))
 246   (assert mutex)
 247   #!-sb-thread (error "Not supported in unithread builds.")
 248   #!+sb-thread
 249   (let ((value (mutex-value mutex)))
 250     (unwind-protect
 251          (let ((me *current-thread*))
 252            ;; XXX we should do something to ensure that the result of this setf
 253            ;; is visible to all CPUs
 254            (setf (waitqueue-data queue) me)
 255            (release-mutex mutex)
 256            ;; Now we go to sleep using futex-wait.  If anyone else
 257            ;; manages to grab MUTEX and call CONDITION-NOTIFY during
 258            ;; this comment, it will change queue->data, and so
 259            ;; futex-wait returns immediately instead of sleeping.
 260            ;; Ergo, no lost wakeup
 261            (with-pinned-objects (queue me)
 262              (futex-wait (waitqueue-data-address queue)
 263                          (sb!kernel:get-lisp-obj-address me))))
 264       ;; If we are interrupted while waiting, we should do these things
 265       ;; before returning.  Ideally, in the case of an unhandled signal,
 266       ;; we should do them before entering the debugger, but this is
 267       ;; better than nothing.
 268       (get-mutex mutex value))))
 269
 270 (defun condition-notify (queue &optional (n 1))
 271   #!+sb-doc
 272   "Notify N threads waiting on QUEUE."
 273   #!-sb-thread (declare (ignore queue n))
 274   #!-sb-thread (error "Not supported in unithread builds.")
 275   #!+sb-thread
 276   (declare (type (and fixnum (integer 1)) n))
 277   #!+sb-thread
 278   (let ((me *current-thread*))
 279     ;; no problem if >1 thread notifies during the comment in
 280     ;; condition-wait: as long as the value in queue-data isn't the
 281     ;; waiting thread's id, it matters not what it is
 282     ;; XXX we should do something to ensure that the result of this setf
 283     ;; is visible to all CPUs
 284     (setf (waitqueue-data queue) me)
 285     (with-pinned-objects (queue)
 286       (futex-wake (waitqueue-data-address queue) n))))
 287
 288 (defun condition-broadcast (queue)
 289   #!+sb-doc
 290   "Notify all threads waiting on QUEUE."
 291   (condition-notify queue most-positive-fixnum))
 292
 293 ;;;; semaphores
 294
 295 (defstruct (semaphore (:constructor %make-semaphore))
 296   #!+sb-doc
 297   "Semaphore type."
 298   (name nil :type (or null simple-string))
 299   (count 0 :type (integer 0))
 300   (mutex (make-mutex))
 301   (queue (make-waitqueue)))
 302
 303 (defun make-semaphore (&key name (count 0))
 304   #!+sb-doc
 305   "Create a semaphore with the supplied COUNT."
 306   (%make-semaphore :name name :count count))
 307
 308 (setf (sb!kernel:fdocumentation 'semaphore-name 'function)
 309       "The name of the semaphore. Setfable.")
 310
 311 (defun wait-on-semaphore (sem)
 312   #!+sb-doc
 313   "Decrement the count of SEM if the count would not be negative. Else
 314 block until the semaphore can be decremented."
 315   ;; a more direct implementation based directly on futexes should be
 316   ;; possible
 317   (with-mutex ((semaphore-mutex sem))
 318     (loop until (> (semaphore-count sem) 0)
 319           do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
 320           finally (decf (semaphore-count sem)))))
 321
 322 (defun signal-semaphore (sem &optional (n 1))
 323   #!+sb-doc
 324   "Increment the count of SEM by N. If there are threads waiting on
 325 this semaphore, then N of them is woken up."
 326   (declare (type (and fixnum (integer 1)) n))
 327   (with-mutex ((semaphore-mutex sem))
 328     (when (= n (incf (semaphore-count sem) n))
 329       (condition-notify (semaphore-queue sem) n))))
 330
 331 ;;;; job control, independent listeners
 332
 333 (defstruct session
 334   (lock (make-mutex :name "session lock"))
 335   (threads nil)
 336   (interactive-threads nil)
 337   (interactive-threads-queue (make-waitqueue)))
 338
 339 (defvar *session* nil)
 340
 341 ;;; the debugger itself tries to acquire the session lock, don't let
 342 ;;; funny situations (like getting a sigint while holding the session
 343 ;;; lock) occur
 344 (defmacro with-session-lock ((session) &body body)
 345   #!-sb-thread (declare (ignore session))
 346   #!-sb-thread
 347   `(locally ,@body)
 348   #!+sb-thread
 349   `(without-interrupts
 350     (with-mutex ((session-lock ,session))
 351       ,@body)))
 352
 353 (defun new-session ()
 354   (make-session :threads (list *current-thread*)
 355                 :interactive-threads (list *current-thread*)))
 356
 357 (defun init-job-control ()
 358   (setf *session* (new-session)))
 359
 360 (defun %delete-thread-from-session (thread session)
 361   (with-session-lock (session)
 362     (setf (session-threads session)
 363           (delete thread (session-threads session))
 364           (session-interactive-threads session)
 365           (delete thread (session-interactive-threads session)))))
 366
 367 (defun call-with-new-session (fn)
 368   (%delete-thread-from-session *current-thread* *session*)
 369   (let ((*session* (new-session)))
 370     (funcall fn)))
 371
 372 (defmacro with-new-session (args &body forms)
 373   (declare (ignore args))               ;for extensibility
 374   (sb!int:with-unique-names (fb-name)
 375     `(labels ((,fb-name () ,@forms))
 376       (call-with-new-session (function ,fb-name)))))
 377
 378 ;;; Remove thread from its session, if it has one.
 379 #!+sb-thread
 380 (defun handle-thread-exit (thread)
 381   (with-mutex (*all-threads-lock*)
 382     (setq *all-threads* (delete thread *all-threads*)))
 383   (when *session*
 384     (%delete-thread-from-session thread *session*)))
 385
 386 (defun terminate-session ()
 387   #!+sb-doc
 388   "Kill all threads in session except for this one.  Does nothing if current
 389 thread is not the foreground thread."
 390   ;; FIXME: threads created in other threads may escape termination
 391   (let ((to-kill
 392          (with-session-lock (*session*)
 393            (and (eq *current-thread*
 394                     (car (session-interactive-threads *session*)))
 395                 (session-threads *session*)))))
 396     ;; do the kill after dropping the mutex; unwind forms in dying
 397     ;; threads may want to do session things
 398     (dolist (thread to-kill)
 399       (unless (eq thread *current-thread*)
 400         ;; terminate the thread but don't be surprised if it has
 401         ;; exited in the meantime
 402         (handler-case (terminate-thread thread)
 403           (interrupt-thread-error ()))))))
 404
 405 ;;; called from top of invoke-debugger
 406 (defun debugger-wait-until-foreground-thread (stream)
 407   "Returns T if thread had been running in background, NIL if it was
 408 interactive."
 409   (declare (ignore stream))
 410   #!-sb-thread nil
 411   #!+sb-thread
 412   (prog1
 413       (with-session-lock (*session*)
 414         (not (member *current-thread*
 415                      (session-interactive-threads *session*))))
 416     (get-foreground)))
 417
 418 (defun get-foreground ()
 419   #!-sb-thread t
 420   #!+sb-thread
 421   (let ((was-foreground t))
 422     (loop
 423      (with-session-lock (*session*)
 424        (let ((int-t (session-interactive-threads *session*)))
 425          (when (eq (car int-t) *current-thread*)
 426            (unless was-foreground
 427              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 428            (return-from get-foreground t))
 429          (setf was-foreground nil)
 430          (unless (member *current-thread* int-t)
 431            (setf (cdr (last int-t))
 432                  (list *current-thread*)))
 433          (condition-wait
 434           (session-interactive-threads-queue *session*)
 435           (session-lock *session*)))))))
 436
 437 (defun release-foreground (&optional next)
 438   #!+sb-doc
 439   "Background this thread.  If NEXT is supplied, arrange for it to
 440 have the foreground next."
 441   #!-sb-thread (declare (ignore next))
 442   #!-sb-thread nil
 443   #!+sb-thread
 444   (with-session-lock (*session*)
 445     (when (rest (session-interactive-threads *session*))
 446       (setf (session-interactive-threads *session*)
 447             (delete *current-thread* (session-interactive-threads *session*))))
 448     (when next
 449       (setf (session-interactive-threads *session*)
 450             (list* next
 451                    (delete next (session-interactive-threads *session*)))))
 452     (condition-broadcast (session-interactive-threads-queue *session*))))
 453
 454 (defun foreground-thread ()
 455   (car (session-interactive-threads *session*)))
 456
 457 (defun make-listener-thread (tty-name)
 458   (assert (probe-file tty-name))
 459   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 460          (out (sb!unix:unix-dup in))
 461          (err (sb!unix:unix-dup in)))
 462     (labels ((thread-repl ()
 463                (sb!unix::unix-setsid)
 464                (let* ((sb!impl::*stdin*
 465                        (make-fd-stream in :input t :buffering :line
 466                                               :dual-channel-p t))
 467                       (sb!impl::*stdout*
 468                        (make-fd-stream out :output t :buffering :line
 469                                               :dual-channel-p t))
 470                       (sb!impl::*stderr*
 471                        (make-fd-stream err :output t :buffering :line
 472                                               :dual-channel-p t))
 473                       (sb!impl::*tty*
 474                        (make-fd-stream err :input t :output t
 475                                               :buffering :line
 476                                               :dual-channel-p t))
 477                       (sb!impl::*descriptor-handlers* nil))
 478                  (with-new-session ()
 479                    (unwind-protect
 480                         (sb!impl::toplevel-repl nil)
 481                      (sb!int:flush-standard-output-streams))))))
 482       (make-thread #'thread-repl))))
 483
 484 ;;;; the beef
 485
 486 (defun make-thread (function &key name)
 487   #!+sb-doc
 488   "Create a new thread of NAME that runs FUNCTION. When the function
 489 returns the thread exits."
 490   #!-sb-thread (declare (ignore function name))
 491   #!-sb-thread (error "Not supported in unithread builds.")
 492   #!+sb-thread
 493   (let* ((thread (%make-thread :name name))
 494          (setup-sem (make-semaphore :name "Thread setup semaphore"))
 495          (real-function (coerce function 'function))
 496          (initial-function
 497           (lambda ()
 498             ;; in time we'll move some of the binding presently done in C
 499             ;; here too
 500             (let ((*current-thread* thread)
 501                   (sb!kernel::*restart-clusters* nil)
 502                   (sb!kernel::*handler-clusters* nil)
 503                   (sb!kernel::*condition-restarts* nil)
 504                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
 505               (setf (thread-os-thread thread) (current-thread-sap-id))
 506               (with-mutex (*all-threads-lock*)
 507                 (push thread *all-threads*))
 508               (with-session-lock (*session*)
 509                 (push thread (session-threads *session*)))
 510               (setf (thread-%alive-p thread) t)
 511               (signal-semaphore setup-sem)
 512               ;; can't use handling-end-of-the-world, because that flushes
 513               ;; output streams, and we don't necessarily have any (or we
 514               ;; could be sharing them)
 515               (catch 'sb!impl::toplevel-catcher
 516                 (catch 'sb!impl::%end-of-the-world
 517                   (with-simple-restart
 518                       (terminate-thread
 519                        (format nil
 520                                "~~@<Terminate this thread (~A)~~@:>"
 521                                *current-thread*))
 522                     (unwind-protect
 523                          (progn
 524                            ;; now that most things have a chance to
 525                            ;; work properly without messing up other
 526                            ;; threads, it's time to enable signals
 527                            (sb!unix::reset-signal-mask)
 528                            (funcall real-function))
 529                       ;; we're going down, can't handle
 530                       ;; interrupts sanely anymore
 531                       (let ((sb!impl::*gc-inhibit* t))
 532                         (block-blockable-signals)
 533                         (setf (thread-%alive-p thread) nil)
 534                         (setf (thread-os-thread thread) nil)
 535                         ;; and remove what can be the last
 536                         ;; reference to this thread
 537                         (handle-thread-exit thread)))))))
 538             (values))))
 539     ;; Keep INITIAL-FUNCTION pinned until the child thread is
 540     ;; initialized properly.
 541     (with-pinned-objects (initial-function)
 542       (let ((os-thread
 543              (%create-thread
 544               (sb!kernel:get-lisp-obj-address initial-function))))
 545         (when (zerop os-thread)
 546           (error "Can't create a new thread"))
 547         (wait-on-semaphore setup-sem)
 548         thread))))
 549
 550 (defun destroy-thread (thread)
 551   #!+sb-doc
 552   "Deprecated. Same as TERMINATE-THREAD."
 553   (terminate-thread thread))
 554
 555 (define-condition interrupt-thread-error (error)
 556   ((thread :reader interrupt-thread-error-thread :initarg :thread))
 557   #!+sb-doc
 558   (:documentation "Interrupting thread failed.")
 559   (:report (lambda (c s)
 560              (format s "Interrupt thread failed: thread ~A has exited."
 561                      (interrupt-thread-error-thread c)))))
 562
 563 #!+sb-doc
 564 (setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
 565       "The thread that was not interrupted.")
 566
 567 (defmacro with-interruptions-lock ((thread) &body body)
 568   `(without-interrupts
 569      (with-mutex ((thread-interruptions-lock ,thread))
 570        ,@body)))
 571
 572 ;; Called from the signal handler.
 573 (defun run-interruption ()
 574   (in-interruption ()
 575    (let ((interruption (with-interruptions-lock (*current-thread*)
 576                          (pop (thread-interruptions *current-thread*)))))
 577      (with-interrupts
 578        (funcall interruption)))))
 579
 580 ;; The order of interrupt execution is peculiar. If thread A
 581 ;; interrupts thread B with I1, I2 and B for some reason receives I1
 582 ;; when FUN2 is already on the list, then it is FUN2 that gets to run
 583 ;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
 584 ;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
 585 ;; just one scenario, and the order of thread interrupt execution is
 586 ;; undefined.
 587 (defun interrupt-thread (thread function)
 588   #!+sb-doc
 589   "Interrupt the live THREAD and make it run FUNCTION. A moderate
 590 degree of care is expected for use of INTERRUPT-THREAD, due to its
 591 nature: if you interrupt a thread that was holding important locks
 592 then do something that turns out to need those locks, you probably
 593 won't like the effect."
 594   #!-sb-thread (declare (ignore thread))
 595   ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
 596   ;; into account
 597   #!-sb-thread
 598   (funcall function)
 599   #!+sb-thread
 600   (if (eq thread *current-thread*)
 601       (funcall function)
 602       (let ((os-thread (thread-os-thread thread)))
 603         (cond ((not os-thread)
 604                (error 'interrupt-thread-error :thread thread))
 605               (t
 606                (with-interruptions-lock (thread)
 607                  (push function (thread-interruptions thread)))
 608                (when (minusp (signal-interrupt-thread os-thread))
 609                  (error 'interrupt-thread-error :thread thread)))))))
 610
 611 (defun terminate-thread (thread)
 612   #!+sb-doc
 613   "Terminate the thread identified by THREAD, by causing it to run
 614 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 615   (interrupt-thread thread 'sb!ext:quit))
 616
 617 ;;; internal use only.  If you think you need to use this, either you
 618 ;;; are an SBCL developer, are doing something that you should discuss
 619 ;;; with an SBCL developer first, or are doing something that you
 620 ;;; should probably discuss with a professional psychiatrist first
 621 #!+sb-thread
 622 (defun thread-sap-for-id (id)
 623   (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
 624     (loop
 625      (when (sap= thread-sap (int-sap 0)) (return nil))
 626      (let ((os-thread (sap-ref-word thread-sap
 627                                     (* sb!vm:n-word-bytes
 628                                        sb!vm::thread-os-thread-slot))))
 629        (when (= os-thread id) (return thread-sap))
 630        (setf thread-sap
 631              (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
 632                                         sb!vm::thread-next-slot)))))))
 633
 634 #!+sb-thread
 635 (defun symbol-value-in-thread (symbol thread-sap)
 636   (let* ((index (sb!vm::symbol-tls-index symbol))
 637          (tl-val (sap-ref-word thread-sap
 638                                (* sb!vm:n-word-bytes index))))
 639     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
 640         (sb!vm::symbol-global-value symbol)
 641         (sb!kernel:make-lisp-obj tl-val))))