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