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