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