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