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 (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 (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 (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         (to-sec long) (to-usec unsigned-long))
 168
 169     (sb!alien:define-alien-routine "futex_wake"
 170         int (word unsigned-long) (n unsigned-long))))
 171
 172 ;;; used by debug-int.lisp to access interrupt contexts
 173 #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 174 #!-sb-thread
 175 (defun sb!vm::current-thread-offset-sap (n)
 176   (declare (type (unsigned-byte 27) n))
 177   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
 178                (* n sb!vm:n-word-bytes)))
 179
 180 #!+sb-thread
 181 (defun sb!vm::current-thread-offset-sap (n)
 182   (declare (type (unsigned-byte 27) n))
 183   (sb!vm::current-thread-offset-sap n))
 184
 185 ;;;; spinlocks
 186 (define-structure-slot-compare-and-swap
 187     compare-and-swap-spinlock-value
 188     :structure spinlock
 189     :slot value)
 190
 191 (declaim (inline get-spinlock release-spinlock))
 192
 193 (defun get-spinlock (spinlock)
 194   (declare (optimize (speed 3) (safety 0)))
 195   (let* ((new *current-thread*)
 196          (old (compare-and-swap-spinlock-value spinlock nil new)))
 197     (when old
 198       (when (eq old new)
 199         (error "Recursive lock attempt on ~S." spinlock))
 200       #!+sb-thread
 201       (loop while (compare-and-swap-spinlock-value spinlock nil new))))
 202   t)
 203
 204 (defun release-spinlock (spinlock)
 205   (declare (optimize (speed 3) (safety 0)))
 206   (setf (spinlock-value spinlock) nil)
 207   nil)
 208
 209 ;;;; mutexes
 210
 211 #!+sb-doc
 212 (setf (fdocumentation 'make-mutex 'function)
 213       "Create a mutex."
 214       (fdocumentation 'mutex-name 'function)
 215       "The name of the mutex. Setfable."
 216       (fdocumentation 'mutex-value 'function)
 217       "The value of the mutex. NIL if the mutex is free. Setfable.")
 218
 219 #!+(and sb-thread (not sb-lutex))
 220 (progn
 221   (define-structure-slot-addressor mutex-value-address
 222       :structure mutex
 223       :slot value)
 224   (define-structure-slot-compare-and-swap
 225       compare-and-swap-mutex-value
 226       :structure mutex
 227       :slot value))
 228
 229 (defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t))
 230   #!+sb-doc
 231   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
 232 value if NIL. If WAITP is non-NIL and the mutex is in use, sleep
 233 until it is available."
 234   (declare (type mutex mutex) (optimize (speed 3)))
 235   (/show0 "Entering GET-MUTEX")
 236   (unless new-value
 237     (setq new-value *current-thread*))
 238   #!-sb-thread
 239   (let ((old (mutex-value mutex)))
 240     (when (and old waitp)
 241       (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~
 242               new-value ~S, but has already been acquired (with value ~S)."
 243              mutex waitp new-value old))
 244     (setf (mutex-value mutex) new-value)
 245     t)
 246   #!+sb-thread
 247   (progn
 248     (when (eql new-value (mutex-value mutex))
 249       (warn "recursive lock attempt ~S~%" mutex)
 250       (format *debug-io* "Thread: ~A~%" *current-thread*)
 251       (sb!debug:backtrace most-positive-fixnum *debug-io*)
 252       (force-output *debug-io*))
 253     ;; FIXME: Lutexes do not currently support deadlines, as at least
 254     ;; on Darwin pthread_foo_timedbar functions are not supported:
 255     ;; this means that we probably need to use the Carbon multiprocessing
 256     ;; functions on Darwin.
 257     #!+sb-lutex
 258     (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
 259                    (if waitp
 260                        (%lutex-lock lutex)
 261                        (%lutex-trylock lutex))))
 262       (setf (mutex-value mutex) new-value))
 263     #!-sb-lutex
 264     (let (old)
 265       (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value))
 266                  waitp)
 267         (loop while old
 268               do (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
 269                    (when (= 1 (with-pinned-objects (mutex old)
 270                                 (futex-wait (mutex-value-address mutex)
 271                                             (get-lisp-obj-address old)
 272                                             (or to-sec -1)
 273                                             (or to-usec 0))))
 274                      (signal-deadline)))
 275               (setf old (compare-and-swap-mutex-value mutex nil new-value))))
 276       (not old))))
 277
 278 (defun release-mutex (mutex)
 279   #!+sb-doc
 280   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 281 this mutex."
 282   (declare (type mutex mutex))
 283   (/show0 "Entering RELEASE-MUTEX")
 284   (setf (mutex-value mutex) nil)
 285   #!+sb-thread
 286   (progn
 287     #!+sb-lutex
 288     (with-lutex-address (lutex (mutex-lutex mutex))
 289       (%lutex-unlock lutex))
 290     #!-sb-lutex
 291     (futex-wake (mutex-value-address mutex) 1)))
 292
 293 ;;;; waitqueues/condition variables
 294
 295 (defstruct (waitqueue (:constructor %make-waitqueue))
 296   #!+sb-doc
 297   "Waitqueue type."
 298   (name nil :type (or null simple-string))
 299   #!+(and sb-lutex sb-thread)
 300   (lutex (make-lutex))
 301   #!-sb-lutex
 302   (data nil))
 303
 304 (defun make-waitqueue (&key name)
 305   #!+sb-doc
 306   "Create a waitqueue."
 307   (%make-waitqueue :name name))
 308
 309 #!+sb-doc
 310 (setf (fdocumentation 'waitqueue-name 'function)
 311       "The name of the waitqueue. Setfable.")
 312
 313 #!+(and sb-thread (not sb-lutex))
 314 (define-structure-slot-addressor waitqueue-data-address
 315     :structure waitqueue
 316     :slot data)
 317
 318 (defun condition-wait (queue mutex)
 319   #!+sb-doc
 320   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
 321 thread may subsequently notify us using CONDITION-NOTIFY, at which
 322 time we reacquire MUTEX and return to the caller."
 323   #!-sb-thread (declare (ignore queue))
 324   (assert mutex)
 325   #!-sb-thread (error "Not supported in unithread builds.")
 326   #!+sb-thread
 327   (let ((value (mutex-value mutex)))
 328     (/show0 "CONDITION-WAITing")
 329     #!+sb-lutex
 330     (progn
 331       (setf (mutex-value mutex) nil)
 332       (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
 333         (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
 334           (%lutex-wait queue-lutex-address mutex-lutex-address)))
 335       (setf (mutex-value mutex) value))
 336     #!-sb-lutex
 337     (unwind-protect
 338          (let ((me *current-thread*))
 339            ;; XXX we should do something to ensure that the result of this setf
 340            ;; is visible to all CPUs
 341            (setf (waitqueue-data queue) me)
 342            (release-mutex mutex)
 343            ;; Now we go to sleep using futex-wait.  If anyone else
 344            ;; manages to grab MUTEX and call CONDITION-NOTIFY during
 345            ;; this comment, it will change queue->data, and so
 346            ;; futex-wait returns immediately instead of sleeping.
 347            ;; Ergo, no lost wakeup. We may get spurious wakeups,
 348            ;; but that's ok.
 349            (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
 350              (when (= 1 (with-pinned-objects (queue me)
 351                           (futex-wait (waitqueue-data-address queue)
 352                                       (get-lisp-obj-address me)
 353                                       (or to-sec -1) ;; our way if saying "no timeout"
 354                                       (or to-usec 0))))
 355                (signal-deadline))))
 356       ;; If we are interrupted while waiting, we should do these things
 357       ;; before returning.  Ideally, in the case of an unhandled signal,
 358       ;; we should do them before entering the debugger, but this is
 359       ;; better than nothing.
 360       (get-mutex mutex value))))
 361
 362 (defun condition-notify (queue &optional (n 1))
 363   #!+sb-doc
 364   "Notify N threads waiting on QUEUE."
 365   #!-sb-thread (declare (ignore queue n))
 366   #!-sb-thread (error "Not supported in unithread builds.")
 367   #!+sb-thread
 368   (declare (type (and fixnum (integer 1)) n))
 369   (/show0 "Entering CONDITION-NOTIFY")
 370   #!+sb-thread
 371   (progn
 372     #!+sb-lutex
 373     (with-lutex-address (lutex (waitqueue-lutex queue))
 374       (%lutex-wake lutex n))
 375     ;; no problem if >1 thread notifies during the comment in
 376     ;; condition-wait: as long as the value in queue-data isn't the
 377     ;; waiting thread's id, it matters not what it is
 378     ;; XXX we should do something to ensure that the result of this setf
 379     ;; is visible to all CPUs
 380     #!-sb-lutex
 381     (let ((me *current-thread*))
 382       (progn
 383         (setf (waitqueue-data queue) me)
 384         (with-pinned-objects (queue)
 385           (futex-wake (waitqueue-data-address queue) n))))))
 386
 387 (defun condition-broadcast (queue)
 388   #!+sb-doc
 389   "Notify all threads waiting on QUEUE."
 390   (condition-notify queue
 391                     ;; On a 64-bit platform truncating M-P-F to an int results
 392                     ;; in -1, which wakes up only one thread.
 393                     (ldb (byte 29 0)
 394                          most-positive-fixnum)))
 395
 396 ;;;; semaphores
 397
 398 (defstruct (semaphore (:constructor %make-semaphore))
 399   #!+sb-doc
 400   "Semaphore type."
 401   (name nil :type (or null simple-string))
 402   (count 0 :type (integer 0))
 403   (mutex (make-mutex))
 404   (queue (make-waitqueue)))
 405
 406 (defun make-semaphore (&key name (count 0))
 407   #!+sb-doc
 408   "Create a semaphore with the supplied COUNT."
 409   (%make-semaphore :name name :count count))
 410
 411 (setf (fdocumentation 'semaphore-name 'function)
 412       "The name of the semaphore. Setfable.")
 413
 414 (defun wait-on-semaphore (sem)
 415   #!+sb-doc
 416   "Decrement the count of SEM if the count would not be negative. Else
 417 block until the semaphore can be decremented."
 418   ;; a more direct implementation based directly on futexes should be
 419   ;; possible
 420   (with-mutex ((semaphore-mutex sem))
 421     (loop until (> (semaphore-count sem) 0)
 422           do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
 423           finally (decf (semaphore-count sem)))))
 424
 425 (defun signal-semaphore (sem &optional (n 1))
 426   #!+sb-doc
 427   "Increment the count of SEM by N. If there are threads waiting on
 428 this semaphore, then N of them is woken up."
 429   (declare (type (and fixnum (integer 1)) n))
 430   (with-mutex ((semaphore-mutex sem))
 431     (when (= n (incf (semaphore-count sem) n))
 432       (condition-notify (semaphore-queue sem) n))))
 433
 434 ;;;; job control, independent listeners
 435
 436 (defstruct session
 437   (lock (make-mutex :name "session lock"))
 438   (threads nil)
 439   (interactive-threads nil)
 440   (interactive-threads-queue (make-waitqueue)))
 441
 442 (defvar *session* nil)
 443
 444 ;;; the debugger itself tries to acquire the session lock, don't let
 445 ;;; funny situations (like getting a sigint while holding the session
 446 ;;; lock) occur
 447 (defmacro with-session-lock ((session) &body body)
 448   #!-sb-thread (declare (ignore session))
 449   #!-sb-thread
 450   `(locally ,@body)
 451   #!+sb-thread
 452   `(without-interrupts
 453      (with-mutex ((session-lock ,session))
 454        ,@body)))
 455
 456 (defun new-session ()
 457   (make-session :threads (list *current-thread*)
 458                 :interactive-threads (list *current-thread*)))
 459
 460 (defun init-job-control ()
 461   (/show0 "Entering INIT-JOB-CONTROL")
 462   (setf *session* (new-session))
 463   (/show0 "Exiting INIT-JOB-CONTROL"))
 464
 465 (defun %delete-thread-from-session (thread session)
 466   (with-session-lock (session)
 467     (setf (session-threads session)
 468           (delete thread (session-threads session))
 469           (session-interactive-threads session)
 470           (delete thread (session-interactive-threads session)))))
 471
 472 (defun call-with-new-session (fn)
 473   (%delete-thread-from-session *current-thread* *session*)
 474   (let ((*session* (new-session)))
 475     (funcall fn)))
 476
 477 (defmacro with-new-session (args &body forms)
 478   (declare (ignore args))               ;for extensibility
 479   (sb!int:with-unique-names (fb-name)
 480     `(labels ((,fb-name () ,@forms))
 481       (call-with-new-session (function ,fb-name)))))
 482
 483 ;;; Remove thread from its session, if it has one.
 484 #!+sb-thread
 485 (defun handle-thread-exit (thread)
 486   (/show0 "HANDLING THREAD EXIT")
 487   ;; We're going down, can't handle interrupts sanely anymore.
 488   ;; GC remains enabled.
 489   (block-deferrable-signals)
 490   ;; Lisp-side cleanup
 491   (with-all-threads-lock
 492     (setf (thread-%alive-p thread) nil)
 493     (setf (thread-os-thread thread) nil)
 494     (setq *all-threads* (delete thread *all-threads*))
 495     (when *session*
 496       (%delete-thread-from-session thread *session*)))
 497   #!+sb-lutex
 498   (without-gcing
 499     (/show0 "FREEING MUTEX LUTEX")
 500     (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
 501       (%lutex-destroy lutex))))
 502
 503 (defun terminate-session ()
 504   #!+sb-doc
 505   "Kill all threads in session except for this one.  Does nothing if current
 506 thread is not the foreground thread."
 507   ;; FIXME: threads created in other threads may escape termination
 508   (let ((to-kill
 509          (with-session-lock (*session*)
 510            (and (eq *current-thread*
 511                     (car (session-interactive-threads *session*)))
 512                 (session-threads *session*)))))
 513     ;; do the kill after dropping the mutex; unwind forms in dying
 514     ;; threads may want to do session things
 515     (dolist (thread to-kill)
 516       (unless (eq thread *current-thread*)
 517         ;; terminate the thread but don't be surprised if it has
 518         ;; exited in the meantime
 519         (handler-case (terminate-thread thread)
 520           (interrupt-thread-error ()))))))
 521
 522 ;;; called from top of invoke-debugger
 523 (defun debugger-wait-until-foreground-thread (stream)
 524   "Returns T if thread had been running in background, NIL if it was
 525 interactive."
 526   (declare (ignore stream))
 527   #!-sb-thread nil
 528   #!+sb-thread
 529   (prog1
 530       (with-session-lock (*session*)
 531         (not (member *current-thread*
 532                      (session-interactive-threads *session*))))
 533     (get-foreground)))
 534
 535 (defun get-foreground ()
 536   #!-sb-thread t
 537   #!+sb-thread
 538   (let ((was-foreground t))
 539     (loop
 540      (/show0 "Looping in GET-FOREGROUND")
 541      (with-session-lock (*session*)
 542        (let ((int-t (session-interactive-threads *session*)))
 543          (when (eq (car int-t) *current-thread*)
 544            (unless was-foreground
 545              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 546            (return-from get-foreground t))
 547          (setf was-foreground nil)
 548          (unless (member *current-thread* int-t)
 549            (setf (cdr (last int-t))
 550                  (list *current-thread*)))
 551          (condition-wait
 552           (session-interactive-threads-queue *session*)
 553           (session-lock *session*)))))))
 554
 555 (defun release-foreground (&optional next)
 556   #!+sb-doc
 557   "Background this thread.  If NEXT is supplied, arrange for it to
 558 have the foreground next."
 559   #!-sb-thread (declare (ignore next))
 560   #!-sb-thread nil
 561   #!+sb-thread
 562   (with-session-lock (*session*)
 563     (when (rest (session-interactive-threads *session*))
 564       (setf (session-interactive-threads *session*)
 565             (delete *current-thread* (session-interactive-threads *session*))))
 566     (when next
 567       (setf (session-interactive-threads *session*)
 568             (list* next
 569                    (delete next (session-interactive-threads *session*)))))
 570     (condition-broadcast (session-interactive-threads-queue *session*))))
 571
 572 (defun foreground-thread ()
 573   (car (session-interactive-threads *session*)))
 574
 575 (defun make-listener-thread (tty-name)
 576   (assert (probe-file tty-name))
 577   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 578          (out (sb!unix:unix-dup in))
 579          (err (sb!unix:unix-dup in)))
 580     (labels ((thread-repl ()
 581                (sb!unix::unix-setsid)
 582                (let* ((sb!impl::*stdin*
 583                        (make-fd-stream in :input t :buffering :line
 584                                        :dual-channel-p t))
 585                       (sb!impl::*stdout*
 586                        (make-fd-stream out :output t :buffering :line
 587                                               :dual-channel-p t))
 588                       (sb!impl::*stderr*
 589                        (make-fd-stream err :output t :buffering :line
 590                                               :dual-channel-p t))
 591                       (sb!impl::*tty*
 592                        (make-fd-stream err :input t :output t
 593                                               :buffering :line
 594                                               :dual-channel-p t))
 595                       (sb!impl::*descriptor-handlers* nil))
 596                  (with-new-session ()
 597                    (unwind-protect
 598                         (sb!impl::toplevel-repl nil)
 599                      (sb!int:flush-standard-output-streams))))))
 600       (make-thread #'thread-repl))))
 601
 602 ;;;; the beef
 603
 604 (defun make-thread (function &key name)
 605   #!+sb-doc
 606   "Create a new thread of NAME that runs FUNCTION. When the function
 607 returns the thread exits. The return values of FUNCTION are kept
 608 around and can be retrieved by JOIN-THREAD."
 609   #!-sb-thread (declare (ignore function name))
 610   #!-sb-thread (error "Not supported in unithread builds.")
 611   #!+sb-thread
 612   (let* ((thread (%make-thread :name name))
 613          (setup-sem (make-semaphore :name "Thread setup semaphore"))
 614          (real-function (coerce function 'function))
 615          (initial-function
 616           (lambda ()
 617             ;; In time we'll move some of the binding presently done in C
 618             ;; here too.
 619             ;;
 620             ;; KLUDGE: Here we have a magic list of variables that are
 621             ;; not thread-safe for one reason or another.  As people
 622             ;; report problems with the thread safety of certain
 623             ;; variables, (e.g. "*print-case* in multiple threads
 624             ;; broken", sbcl-devel 2006-07-14), we add a few more
 625             ;; bindings here.  The Right Thing is probably some variant
 626             ;; of Allegro's *cl-default-special-bindings*, as that is at
 627             ;; least accessible to users to secure their own libraries.
 628             ;;   --njf, 2006-07-15
 629             (let ((*current-thread* thread)
 630                   (*restart-clusters* nil)
 631                   (*handler-clusters* nil)
 632                   (*condition-restarts* nil)
 633                   (sb!impl::*step-out* nil)
 634                   ;; internal printer variables
 635                   (sb!impl::*previous-case* nil)
 636                   (sb!impl::*previous-readtable-case* nil)
 637                   (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
 638                   (sb!impl::*zap-array-data-temp* (vector))    ;
 639                   (sb!impl::*internal-symbol-output-fun* nil)
 640                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
 641               (setf (thread-os-thread thread) (current-thread-sap-id))
 642               (with-mutex ((thread-result-lock thread))
 643                 (with-all-threads-lock
 644                   (push thread *all-threads*))
 645                 (with-session-lock (*session*)
 646                   (push thread (session-threads *session*)))
 647                 (setf (thread-%alive-p thread) t)
 648                 (signal-semaphore setup-sem)
 649                 ;; can't use handling-end-of-the-world, because that flushes
 650                 ;; output streams, and we don't necessarily have any (or we
 651                 ;; could be sharing them)
 652                 (catch 'sb!impl::toplevel-catcher
 653                   (catch 'sb!impl::%end-of-the-world
 654                     (with-simple-restart
 655                         (terminate-thread
 656                          (format nil
 657                                  "~~@<Terminate this thread (~A)~~@:>"
 658                                  *current-thread*))
 659                       (unwind-protect
 660                            (progn
 661                              ;; now that most things have a chance to
 662                              ;; work properly without messing up other
 663                              ;; threads, it's time to enable signals
 664                              (sb!unix::reset-signal-mask)
 665                              (setf (thread-result thread)
 666                                    (cons t
 667                                          (multiple-value-list
 668                                           (funcall real-function)))))
 669                         (handle-thread-exit thread)))))))
 670             (values))))
 671     ;; Keep INITIAL-FUNCTION pinned until the child thread is
 672     ;; initialized properly.
 673     (with-pinned-objects (initial-function)
 674       (let ((os-thread
 675              (%create-thread
 676               (get-lisp-obj-address initial-function))))
 677         (when (zerop os-thread)
 678           (error "Can't create a new thread"))
 679         (wait-on-semaphore setup-sem)
 680         thread))))
 681
 682 (define-condition join-thread-error (error)
 683   ((thread :reader join-thread-error-thread :initarg :thread))
 684   #!+sb-doc
 685   (:documentation "Joining thread failed.")
 686   (:report (lambda (c s)
 687              (format s "Joining thread failed: thread ~A ~
 688                         has not returned normally."
 689                      (join-thread-error-thread c)))))
 690
 691 #!+sb-doc
 692 (setf (fdocumentation 'join-thread-error-thread 'function)
 693       "The thread that we failed to join.")
 694
 695 (defun join-thread (thread &key (default nil defaultp))
 696   #!+sb-doc
 697   "Suspend current thread until THREAD exits. Returns the result
 698 values of the thread function. If the thread does not exit normally,
 699 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
 700   (with-mutex ((thread-result-lock thread))
 701     (cond ((car (thread-result thread))
 702            (values-list (cdr (thread-result thread))))
 703           (defaultp
 704            default)
 705           (t
 706            (error 'join-thread-error :thread thread)))))
 707
 708 (defun destroy-thread (thread)
 709   #!+sb-doc
 710   "Deprecated. Same as TERMINATE-THREAD."
 711   (terminate-thread thread))
 712
 713 (define-condition interrupt-thread-error (error)
 714   ((thread :reader interrupt-thread-error-thread :initarg :thread))
 715   #!+sb-doc
 716   (:documentation "Interrupting thread failed.")
 717   (:report (lambda (c s)
 718              (format s "Interrupt thread failed: thread ~A has exited."
 719                      (interrupt-thread-error-thread c)))))
 720
 721 #!+sb-doc
 722 (setf (fdocumentation 'interrupt-thread-error-thread 'function)
 723       "The thread that was not interrupted.")
 724
 725 (defmacro with-interruptions-lock ((thread) &body body)
 726   `(without-interrupts
 727      (with-mutex ((thread-interruptions-lock ,thread))
 728        ,@body)))
 729
 730 ;; Called from the signal handler in C.
 731 (defun run-interruption ()
 732   (in-interruption ()
 733     (loop
 734        (let ((interruption (with-interruptions-lock (*current-thread*)
 735                              (pop (thread-interruptions *current-thread*)))))
 736          (if interruption
 737              ;; This is safe because it's the IN-INTERRUPTION that
 738              ;; has disabled interrupts.
 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   (flet ((interrupt-self ()
 759            ;; *IN-INTERRUPTION* is true IFF we're being called as an
 760            ;; interruption without an intervening WITHOUT-INTERRUPTS,
 761            ;; in which case it is safe to enable interrupts. Otherwise
 762            ;; interrupts are either already enabled, or there is an outer
 763            ;; WITHOUT-INTERRUPTS we know nothing about, which makes it
 764            ;; unsafe to enable interrupts.
 765            (if *in-interruption*
 766                (with-interrupts (funcall function))
 767                (funcall function))))
 768     #!-sb-thread
 769     (interrupt-self)
 770     #!+sb-thread
 771     (if (eq thread *current-thread*)
 772         (interrupt-self)
 773         (let ((os-thread (thread-os-thread thread)))
 774           (cond ((not os-thread)
 775                  (error 'interrupt-thread-error :thread thread))
 776                 (t
 777                  (with-interruptions-lock (thread)
 778                    (push function (thread-interruptions thread)))
 779                  (when (minusp (signal-interrupt-thread os-thread))
 780                    (error 'interrupt-thread-error :thread thread))))))))
 781
 782 (defun terminate-thread (thread)
 783   #!+sb-doc
 784   "Terminate the thread identified by THREAD, by causing it to run
 785 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 786   (interrupt-thread thread 'sb!ext:quit))
 787
 788 ;;; internal use only.  If you think you need to use this, either you
 789 ;;; are an SBCL developer, are doing something that you should discuss
 790 ;;; with an SBCL developer first, or are doing something that you
 791 ;;; should probably discuss with a professional psychiatrist first
 792 #!+sb-thread
 793 (defun thread-sap-for-id (id)
 794   (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
 795     (loop
 796      (when (sap= thread-sap (int-sap 0)) (return nil))
 797      (let ((os-thread (sap-ref-word thread-sap
 798                                     (* sb!vm:n-word-bytes
 799                                        sb!vm::thread-os-thread-slot))))
 800        (when (= os-thread id) (return thread-sap))
 801        (setf thread-sap
 802              (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
 803                                         sb!vm::thread-next-slot)))))))
 804
 805 #!+sb-thread
 806 (defun symbol-value-in-thread (symbol thread-sap)
 807   (let* ((index (sb!vm::symbol-tls-index symbol))
 808          (tl-val (sap-ref-word thread-sap
 809                                (* sb!vm:n-word-bytes index))))
 810     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
 811         (sb!vm::symbol-global-value symbol)
 812         (make-lisp-obj tl-val))))
 813
 814 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
 815   (sb!vm::locked-symbol-global-value-add symbol-name delta))
 816
 817 ;;; Stepping
 818
 819 (defun thread-stepping ()
 820   (make-lisp-obj
 821    (sap-ref-word (current-thread-sap)
 822                  (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
 823
 824 (defun (setf thread-stepping) (value)
 825   (setf (sap-ref-word (current-thread-sap)
 826                       (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
 827         (get-lisp-obj-address value)))