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   (print-unreadable-object (thread stream :type t :identity t)
  43     (let* ((cookie (list thread))
  44            (info (if (thread-alive-p thread)
  45                      :running
  46                      (multiple-value-list
  47                       (join-thread thread :default cookie))))
  48            (state (if (eq :running info)
  49                       info
  50                       (if (eq cookie (car info))
  51                           :aborted
  52                           :finished)))
  53            (values (when (eq :finished state) info)))
  54       (format stream
  55               "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
  56               (thread-name thread)
  57               (eq :finished state)
  58               state
  59               values))))
  60
  61 (defun thread-alive-p (thread)
  62   #!+sb-doc
  63   "Check if THREAD is running."
  64   (thread-%alive-p thread))
  65
  66 ;; A thread is eligible for gc iff it has finished and there are no
  67 ;; more references to it. This list is supposed to keep a reference to
  68 ;; all running threads.
  69 (defvar *all-threads* ())
  70 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
  71
  72 (defvar *default-alloc-signal* nil)
  73
  74 (defmacro with-all-threads-lock (&body body)
  75   `(with-system-mutex (*all-threads-lock*)
  76      ,@body))
  77
  78 (defun list-all-threads ()
  79   #!+sb-doc
  80   "Return a list of the live threads."
  81   (with-all-threads-lock
  82     (copy-list *all-threads*)))
  83
  84 (declaim (inline current-thread-sap))
  85 (defun current-thread-sap ()
  86   (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
  87
  88 (declaim (inline current-thread-os-thread))
  89 (defun current-thread-os-thread ()
  90   #!+sb-thread
  91   (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))
  92   #!-sb-thread
  93   0)
  94
  95 (defun init-initial-thread ()
  96   (/show0 "Entering INIT-INITIAL-THREAD")
  97   (let ((initial-thread (%make-thread :name "initial thread"
  98                                       :%alive-p t
  99                                       :os-thread (current-thread-os-thread))))
 100     (setq *current-thread* initial-thread)
 101     ;; Either *all-threads* is empty or it contains exactly one thread
 102     ;; in case we are in reinit since saving core with multiple
 103     ;; threads doesn't work.
 104     (setq *all-threads* (list initial-thread))))
 105 \f
 106
 107 ;;;; Aliens, low level stuff
 108
 109 (define-alien-routine "kill_safely"
 110     integer
 111   (os-thread #!-alpha unsigned-long #!+alpha unsigned-int)
 112   (signal int))
 113
 114 #!+sb-thread
 115 (progn
 116   ;; FIXME it would be good to define what a thread id is or isn't
 117   ;; (our current assumption is that it's a fixnum).  It so happens
 118   ;; that on Linux it's a pid, but it might not be on posix thread
 119   ;; implementations.
 120   (define-alien-routine ("create_thread" %create-thread)
 121       unsigned-long (lisp-fun-address unsigned-long))
 122
 123   (define-alien-routine "block_deferrable_signals"
 124       void)
 125
 126   #!+sb-lutex
 127   (progn
 128     (declaim (inline %lutex-init %lutex-wait %lutex-wake
 129                      %lutex-lock %lutex-unlock))
 130
 131     (define-alien-routine ("lutex_init" %lutex-init)
 132         int (lutex unsigned-long))
 133
 134     (define-alien-routine ("lutex_wait" %lutex-wait)
 135         int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
 136
 137     (define-alien-routine ("lutex_wake" %lutex-wake)
 138         int (lutex unsigned-long) (n int))
 139
 140     (define-alien-routine ("lutex_lock" %lutex-lock)
 141         int (lutex unsigned-long))
 142
 143     (define-alien-routine ("lutex_trylock" %lutex-trylock)
 144         int (lutex unsigned-long))
 145
 146     (define-alien-routine ("lutex_unlock" %lutex-unlock)
 147         int (lutex unsigned-long))
 148
 149     (define-alien-routine ("lutex_destroy" %lutex-destroy)
 150         int (lutex unsigned-long))
 151
 152     ;; FIXME: Defining a whole bunch of alien-type machinery just for
 153     ;; passing primitive lutex objects directly to foreign functions
 154     ;; doesn't seem like fun right now. So instead we just manually
 155     ;; pin the lutex, get its address, and let the callee untag it.
 156     (defmacro with-lutex-address ((name lutex) &body body)
 157       `(let ((,name ,lutex))
 158          (with-pinned-objects (,name)
 159            (let ((,name (get-lisp-obj-address ,name)))
 160              ,@body))))
 161
 162     (defun make-lutex ()
 163       (/show0 "Entering MAKE-LUTEX")
 164       ;; Suppress GC until the lutex has been properly registered with
 165       ;; the GC.
 166       (without-gcing
 167         (let ((lutex (sb!vm::%make-lutex)))
 168           (/show0 "LUTEX=..")
 169           (/hexstr lutex)
 170           (with-lutex-address (lutex lutex)
 171             (%lutex-init lutex))
 172           lutex))))
 173
 174   #!-sb-lutex
 175   (progn
 176     (declaim (inline futex-wait %futex-wait futex-wake))
 177
 178     (define-alien-routine ("futex_wait" %futex-wait)
 179         int (word unsigned-long) (old-value unsigned-long)
 180         (to-sec long) (to-usec unsigned-long))
 181
 182     (defun futex-wait (word old to-sec to-usec)
 183       (with-interrupts
 184         (%futex-wait word old to-sec to-usec)))
 185
 186     (define-alien-routine "futex_wake"
 187         int (word unsigned-long) (n unsigned-long))))
 188
 189 ;;; used by debug-int.lisp to access interrupt contexts
 190 #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 191 #!-sb-thread
 192 (defun sb!vm::current-thread-offset-sap (n)
 193   (declare (type (unsigned-byte 27) n))
 194   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
 195                (* n sb!vm:n-word-bytes)))
 196
 197 #!+sb-thread
 198 (defun sb!vm::current-thread-offset-sap (n)
 199   (declare (type (unsigned-byte 27) n))
 200   (sb!vm::current-thread-offset-sap n))
 201 \f
 202
 203 ;;;; Spinlocks
 204
 205 (declaim (inline get-spinlock release-spinlock))
 206
 207 ;;; Should always be called with interrupts disabled.
 208 (defun get-spinlock (spinlock)
 209   (declare (optimize (speed 3) (safety 0)))
 210   (let* ((new *current-thread*)
 211          (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
 212     (when old
 213       (when (eq old new)
 214         (error "Recursive lock attempt on ~S." spinlock))
 215       #!+sb-thread
 216       (flet ((cas ()
 217                (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
 218                    (thread-yield)
 219                    (return-from get-spinlock t))))
 220         (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
 221             ;; If interrupts are disabled, but we are allowed to
 222             ;; enabled them, check for pending interrupts every once
 223             ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make
 224             ;; sure that deferrables are unblocked by doing an empty
 225             ;; WITH-INTERRUPTS once.
 226             (progn
 227               (with-interrupts)
 228               (loop
 229                (loop repeat 128 do (cas)) ; 128 is arbitrary here
 230                (sb!unix::%check-interrupts)))
 231             (loop (cas)))))
 232     t))
 233
 234 (defun release-spinlock (spinlock)
 235   (declare (optimize (speed 3) (safety 0)))
 236   ;; On x86 and x86-64 we can get away with no memory barriers, (see
 237   ;; Linux kernel mailing list "spin_unlock optimization(i386)"
 238   ;; thread, summary at
 239   ;; http://kt.iserv.nl/kernel-traffic/kt19991220_47.html#1.
 240   ;;
 241   ;; If the compiler may reorder this with other instructions, insert
 242   ;; compiler barrier here.
 243   ;;
 244   ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems,
 245   ;; neither on most non-x86 architectures (but we don't have threads
 246   ;; on those).
 247   (setf (spinlock-value spinlock) nil))
 248 \f
 249
 250 ;;;; Mutexes
 251
 252 #!+sb-doc
 253 (setf (fdocumentation 'make-mutex 'function)
 254       "Create a mutex."
 255       (fdocumentation 'mutex-name 'function)
 256       "The name of the mutex. Setfable.")
 257
 258 #!+(and sb-thread (not sb-lutex))
 259 (progn
 260   (define-structure-slot-addressor mutex-state-address
 261       :structure mutex
 262       :slot state)
 263   ;; Important: current code assumes these are fixnums or other
 264   ;; lisp objects that don't need pinning.
 265   (defconstant +lock-free+ 0)
 266   (defconstant +lock-taken+ 1)
 267   (defconstant +lock-contested+ 2))
 268
 269 (defun mutex-owner (mutex)
 270   "Current owner of the mutex, NIL if the mutex is free. Naturally,
 271 this is racy by design (another thread may acquire the mutex after
 272 this function returns), it is intended for informative purposes. For
 273 testing whether the current thread is holding a mutex see
 274 HOLDING-MUTEX-P."
 275   ;; Make sure to get the current value.
 276   (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
 277
 278 (defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t))
 279   #!+sb-doc
 280   "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
 281 NEW-OWNER is NIL, it defaults to the current thread. If WAITP is
 282 non-NIL and the mutex is in use, sleep until it is available.
 283
 284 Note: using GET-MUTEX to assign a MUTEX to another thread then the
 285 current one is not recommended, and liable to be deprecated.
 286
 287 GET-MUTEX is not interrupt safe. The correct way to call it is:
 288
 289  (WITHOUT-INTERRUPTS
 290    ...
 291    (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...))
 292    ...)
 293
 294 WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the
 295 call while the mutex is in an inconsistent state while
 296 ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep.
 297
 298 It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX
 299 directly."
 300   (declare (type mutex mutex) (optimize (speed 3))
 301            #!-sb-thread (ignore waitp))
 302   (unless new-owner
 303     (setq new-owner *current-thread*))
 304   (let ((old (mutex-%owner mutex)))
 305     (when (eq new-owner old)
 306       (error "Recursive lock attempt ~S." mutex))
 307     #!-sb-thread
 308     (when old
 309       (error "Strange deadlock on ~S in an unithreaded build?" mutex)))
 310   #!-sb-thread
 311   (setf (mutex-%owner mutex) new-owner)
 312   #!+sb-thread
 313   (progn
 314     ;; FIXME: Lutexes do not currently support deadlines, as at least
 315     ;; on Darwin pthread_foo_timedbar functions are not supported:
 316     ;; this means that we probably need to use the Carbon multiprocessing
 317     ;; functions on Darwin.
 318     ;;
 319     ;; FIXME: This is definitely not interrupt safe: what happens if
 320     ;; we get hit (1) during the lutex calls (ok, they may be safe,
 321     ;; but has that been checked?) (2) after the lutex call, but
 322     ;; before setting the mutex owner.
 323     #!+sb-lutex
 324     (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
 325                    (if waitp
 326                        (with-interrupts (%lutex-lock lutex))
 327                        (%lutex-trylock lutex))))
 328       (setf (mutex-%owner mutex) new-owner)
 329       t)
 330     #!-sb-lutex
 331     ;; This is a direct tranlation of the Mutex 2 algorithm from
 332     ;; "Futexes are Tricky" by Ulrich Drepper.
 333     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
 334                                         +lock-free+
 335                                         +lock-taken+)))
 336       (unless (or (eql +lock-free+ old) (not waitp))
 337         (tagbody
 338          :retry
 339            (when (or (eql +lock-contested+ old)
 340                      (not (eql +lock-free+
 341                                (sb!ext:compare-and-swap (mutex-state mutex)
 342                                                         +lock-taken+
 343                                                         +lock-contested+))))
 344              ;; Wait on the contested lock.
 345              (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
 346                (when (= 1 (with-pinned-objects (mutex)
 347                             (futex-wait (mutex-state-address mutex)
 348                                         (get-lisp-obj-address +lock-contested+)
 349                                         (or to-sec -1)
 350                                         (or to-usec 0))))
 351                  (signal-deadline))))
 352            (setf old (sb!ext:compare-and-swap (mutex-state mutex)
 353                                               +lock-free+
 354                                               +lock-contested+))
 355            ;; Did we get it?
 356            (unless (eql +lock-free+ old)
 357              (go :retry))))
 358       (cond ((eql +lock-free+ old)
 359              (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
 360                                                   nil new-owner)))
 361                (when prev
 362                  (bug "Old owner in free mutex: ~S" prev))
 363                t))
 364             (waitp
 365              (bug "Failed to acquire lock with WAITP."))))))
 366
 367 (defun release-mutex (mutex)
 368   #!+sb-doc
 369   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 370 this mutex.
 371
 372 RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
 373 around calls to it.
 374
 375 Signals a WARNING if current thread is not the current owner of the
 376 mutex."
 377   (declare (type mutex mutex))
 378   ;; Order matters: set owner to NIL before releasing state.
 379   (let* ((self *current-thread*)
 380          (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
 381     (unless  (eql self old-owner)
 382       (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)
 383       (setf (mutex-%owner mutex) nil)))
 384   #!+sb-thread
 385   (progn
 386     #!+sb-lutex
 387     (with-lutex-address (lutex (mutex-lutex mutex))
 388       (%lutex-unlock lutex))
 389     #!-sb-lutex
 390     ;; FIXME: once ATOMIC-INCF supports struct slots with word sized
 391     ;; unsigned-byte type this can be used:
 392     ;;
 393     ;;     (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1)))
 394     ;;       (unless (eql old +lock-free+)
 395     ;;         (setf (mutex-state mutex) +lock-free+)
 396     ;;         (with-pinned-objects (mutex)
 397     ;;           (futex-wake (mutex-state-address mutex) 1))))
 398     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
 399                                         +lock-taken+ +lock-free+)))
 400       (when (eql old +lock-contested+)
 401         (sb!ext:compare-and-swap (mutex-state mutex)
 402                                  +lock-contested+ +lock-free+)
 403         (with-pinned-objects (mutex)
 404           (futex-wake (mutex-state-address mutex) 1))))
 405     nil))
 406 \f
 407
 408 ;;;; Waitqueues/condition variables
 409
 410 (defstruct (waitqueue (:constructor %make-waitqueue))
 411   #!+sb-doc
 412   "Waitqueue type."
 413   (name nil :type (or null simple-string))
 414   #!+(and sb-lutex sb-thread)
 415   (lutex (make-lutex))
 416   #!-sb-lutex
 417   (data nil))
 418
 419 (defun make-waitqueue (&key name)
 420   #!+sb-doc
 421   "Create a waitqueue."
 422   (%make-waitqueue :name name))
 423
 424 #!+sb-doc
 425 (setf (fdocumentation 'waitqueue-name 'function)
 426       "The name of the waitqueue. Setfable.")
 427
 428 #!+(and sb-thread (not sb-lutex))
 429 (define-structure-slot-addressor waitqueue-data-address
 430     :structure waitqueue
 431     :slot data)
 432
 433 (defun condition-wait (queue mutex)
 434   #!+sb-doc
 435   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
 436 thread may subsequently notify us using CONDITION-NOTIFY, at which
 437 time we reacquire MUTEX and return to the caller."
 438   #!-sb-thread (declare (ignore queue))
 439   (assert mutex)
 440   #!-sb-thread (error "Not supported in unithread builds.")
 441   #!+sb-thread
 442   (let ((me *current-thread*))
 443     (assert (eq me (mutex-%owner mutex)))
 444     (/show0 "CONDITION-WAITing")
 445     #!+sb-lutex
 446     ;; Need to disable interrupts so that we don't miss setting the
 447     ;; owner on our way out. (pthread_cond_wait handles the actual
 448     ;; re-acquisition.)
 449     (without-interrupts
 450       (unwind-protect
 451            (progn
 452              (setf (mutex-%owner mutex) nil)
 453              (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
 454                (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
 455                  (with-local-interrupts
 456                    (%lutex-wait queue-lutex-address mutex-lutex-address)))))
 457         (setf (mutex-%owner mutex) me)))
 458     #!-sb-lutex
 459     ;; Need to disable interrupts so that we don't miss grabbing the
 460     ;; mutex on our way out.
 461     (without-interrupts
 462       (unwind-protect
 463            (let ((me *current-thread*))
 464              ;; This setf becomes visible to other CPUS due to the
 465              ;; usual memory barrier semantics of lock
 466              ;; acquire/release.
 467              (setf (waitqueue-data queue) me)
 468              (release-mutex mutex)
 469              ;; Now we go to sleep using futex-wait. If anyone else
 470              ;; manages to grab MUTEX and call CONDITION-NOTIFY during
 471              ;; this comment, it will change queue->data, and so
 472              ;; futex-wait returns immediately instead of sleeping.
 473              ;; Ergo, no lost wakeup. We may get spurious wakeups, but
 474              ;; that's ok.
 475              (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
 476                (when (= 1 (with-pinned-objects (queue me)
 477                             (allow-with-interrupts
 478                               (futex-wait (waitqueue-data-address queue)
 479                                           (get-lisp-obj-address me)
 480                                           ;; our way if saying "no
 481                                           ;; timeout":
 482                                           (or to-sec -1)
 483                                           (or to-usec 0)))))
 484                  (signal-deadline))))
 485         ;; If we are interrupted while waiting, we should do these
 486         ;; things before returning. Ideally, in the case of an
 487         ;; unhandled signal, we should do them before entering the
 488         ;; debugger, but this is better than nothing.
 489         (get-mutex mutex)))))
 490
 491 (defun condition-notify (queue &optional (n 1))
 492   #!+sb-doc
 493   "Notify N threads waiting on QUEUE. The same mutex that is used in
 494 the correspoinding condition-wait must be held by this thread during
 495 this call."
 496   #!-sb-thread (declare (ignore queue n))
 497   #!-sb-thread (error "Not supported in unithread builds.")
 498   #!+sb-thread
 499   (declare (type (and fixnum (integer 1)) n))
 500   (/show0 "Entering CONDITION-NOTIFY")
 501   #!+sb-thread
 502   (progn
 503     #!+sb-lutex
 504     (with-lutex-address (lutex (waitqueue-lutex queue))
 505       (%lutex-wake lutex n))
 506     ;; no problem if >1 thread notifies during the comment in
 507     ;; condition-wait: as long as the value in queue-data isn't the
 508     ;; waiting thread's id, it matters not what it is
 509     ;; XXX we should do something to ensure that the result of this setf
 510     ;; is visible to all CPUs
 511     #!-sb-lutex
 512     (let ((me *current-thread*))
 513       (progn
 514         (setf (waitqueue-data queue) me)
 515         (with-pinned-objects (queue)
 516           (futex-wake (waitqueue-data-address queue) n))))))
 517
 518 (defun condition-broadcast (queue)
 519   #!+sb-doc
 520   "Notify all threads waiting on QUEUE."
 521   (condition-notify queue
 522                     ;; On a 64-bit platform truncating M-P-F to an int
 523                     ;; results in -1, which wakes up only one thread.
 524                     (ldb (byte 29 0)
 525                          most-positive-fixnum)))
 526 \f
 527
 528 ;;;; Semaphores
 529
 530 (defstruct (semaphore (:constructor %make-semaphore (name %count)))
 531   #!+sb-doc
 532   "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT
 533 should be considered an implementation detail, and may change in the
 534 future."
 535   (name nil :type (or null simple-string))
 536   (%count 0 :type (integer 0))
 537   (waitcount 0 :type (integer 0))
 538   (mutex (make-mutex))
 539   (queue (make-waitqueue)))
 540
 541 (setf (fdocumentation 'semaphore-name 'function)
 542       "The name of the semaphore INSTANCE. Setfable.")
 543
 544 (declaim (inline semaphore-count))
 545 (defun semaphore-count (instance)
 546   "Returns the current count of the semaphore INSTANCE."
 547   (semaphore-%count instance))
 548
 549 (defun make-semaphore (&key name (count 0))
 550   #!+sb-doc
 551   "Create a semaphore with the supplied COUNT and NAME."
 552   (%make-semaphore name count))
 553
 554 (defun wait-on-semaphore (semaphore)
 555   #!+sb-doc
 556   "Decrement the count of SEMAPHORE if the count would not be
 557 negative. Else blocks until the semaphore can be decremented."
 558   ;; A more direct implementation based directly on futexes should be
 559   ;; possible.
 560   ;;
 561   ;; We need to disable interrupts so that we don't forget to
 562   ;; decrement the waitcount (which would happen if an asynch
 563   ;; interrupt should catch us on our way out from the loop.)
 564   (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
 565     ;; Quick check: is it positive? If not, enter the wait loop.
 566     (let ((count (semaphore-%count semaphore)))
 567       (if (plusp count)
 568           (setf (semaphore-%count semaphore) (1- count))
 569           (unwind-protect
 570                (progn
 571                  (incf (semaphore-waitcount semaphore))
 572                  (loop until (plusp (setf count (semaphore-%count semaphore)))
 573                        do (condition-wait (semaphore-queue semaphore)
 574                                           (semaphore-mutex semaphore)))
 575                  (setf (semaphore-%count semaphore) (1- count)))
 576             (decf (semaphore-waitcount semaphore)))))))
 577
 578 (defun signal-semaphore (semaphore &optional (n 1))
 579   #!+sb-doc
 580   "Increment the count of SEMAPHORE by N. If there are threads waiting
 581 on this semaphore, then N of them is woken up."
 582   (declare (type (integer 1) n))
 583   ;; Need to disable interrupts so that we don't lose a wakeup after
 584   ;; we have incremented the count.
 585   (with-system-mutex ((semaphore-mutex semaphore))
 586     (let ((waitcount (semaphore-waitcount semaphore))
 587           (count (incf (semaphore-%count semaphore) n)))
 588       (when (plusp waitcount)
 589         (condition-notify (semaphore-queue semaphore) (min waitcount count))))))
 590 \f
 591
 592 ;;;; Job control, independent listeners
 593
 594 (defstruct session
 595   (lock (make-mutex :name "session lock"))
 596   (threads nil)
 597   (interactive-threads nil)
 598   (interactive-threads-queue (make-waitqueue)))
 599
 600 (defvar *session* nil)
 601
 602 ;;; The debugger itself tries to acquire the session lock, don't let
 603 ;;; funny situations (like getting a sigint while holding the session
 604 ;;; lock) occur. At the same time we need to allow interrupts while
 605 ;;; *waiting* for the session lock for things like GET-FOREGROUND to
 606 ;;; be interruptible.
 607 ;;;
 608 ;;; Take care: we sometimes need to obtain the session lock while
 609 ;;; holding on to *ALL-THREADS-LOCK*, so we must _never_ obtain it
 610 ;;; _after_ getting a session lock! (Deadlock risk.)
 611 ;;;
 612 ;;; FIXME: It would be good to have ordered locks to ensure invariants
 613 ;;; like the above.
 614 (defmacro with-session-lock ((session) &body body)
 615   `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t)
 616      ,@body))
 617
 618 (defun new-session ()
 619   (make-session :threads (list *current-thread*)
 620                 :interactive-threads (list *current-thread*)))
 621
 622 (defun init-job-control ()
 623   (/show0 "Entering INIT-JOB-CONTROL")
 624   (setf *session* (new-session))
 625   (/show0 "Exiting INIT-JOB-CONTROL"))
 626
 627 (defun %delete-thread-from-session (thread session)
 628   (with-session-lock (session)
 629     (setf (session-threads session)
 630           (delete thread (session-threads session))
 631           (session-interactive-threads session)
 632           (delete thread (session-interactive-threads session)))))
 633
 634 (defun call-with-new-session (fn)
 635   (%delete-thread-from-session *current-thread* *session*)
 636   (let ((*session* (new-session)))
 637     (funcall fn)))
 638
 639 (defmacro with-new-session (args &body forms)
 640   (declare (ignore args))               ;for extensibility
 641   (sb!int:with-unique-names (fb-name)
 642     `(labels ((,fb-name () ,@forms))
 643       (call-with-new-session (function ,fb-name)))))
 644
 645 ;;; Remove thread from its session, if it has one.
 646 #!+sb-thread
 647 (defun handle-thread-exit (thread)
 648   (/show0 "HANDLING THREAD EXIT")
 649   ;; Lisp-side cleanup
 650   (with-all-threads-lock
 651     (setf (thread-%alive-p thread) nil)
 652     (setf (thread-os-thread thread) nil)
 653     (setq *all-threads* (delete thread *all-threads*))
 654     (when *session*
 655       (%delete-thread-from-session thread *session*)))
 656   #!+sb-lutex
 657   (without-gcing
 658     (/show0 "FREEING MUTEX LUTEX")
 659     (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
 660       (%lutex-destroy lutex))))
 661
 662 (defun terminate-session ()
 663   #!+sb-doc
 664   "Kill all threads in session except for this one.  Does nothing if current
 665 thread is not the foreground thread."
 666   ;; FIXME: threads created in other threads may escape termination
 667   (let ((to-kill
 668          (with-session-lock (*session*)
 669            (and (eq *current-thread*
 670                     (car (session-interactive-threads *session*)))
 671                 (session-threads *session*)))))
 672     ;; do the kill after dropping the mutex; unwind forms in dying
 673     ;; threads may want to do session things
 674     (dolist (thread to-kill)
 675       (unless (eq thread *current-thread*)
 676         ;; terminate the thread but don't be surprised if it has
 677         ;; exited in the meantime
 678         (handler-case (terminate-thread thread)
 679           (interrupt-thread-error ()))))))
 680
 681 ;;; called from top of invoke-debugger
 682 (defun debugger-wait-until-foreground-thread (stream)
 683   "Returns T if thread had been running in background, NIL if it was
 684 interactive."
 685   (declare (ignore stream))
 686   #!-sb-thread nil
 687   #!+sb-thread
 688   (prog1
 689       (with-session-lock (*session*)
 690         (not (member *current-thread*
 691                      (session-interactive-threads *session*))))
 692     (get-foreground)))
 693
 694 (defun get-foreground ()
 695   #!-sb-thread t
 696   #!+sb-thread
 697   (let ((was-foreground t))
 698     (loop
 699      (/show0 "Looping in GET-FOREGROUND")
 700      (with-session-lock (*session*)
 701        (let ((int-t (session-interactive-threads *session*)))
 702          (when (eq (car int-t) *current-thread*)
 703            (unless was-foreground
 704              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 705            (return-from get-foreground t))
 706          (setf was-foreground nil)
 707          (unless (member *current-thread* int-t)
 708            (setf (cdr (last int-t))
 709                  (list *current-thread*)))
 710          (condition-wait
 711           (session-interactive-threads-queue *session*)
 712           (session-lock *session*)))))))
 713
 714 (defun release-foreground (&optional next)
 715   #!+sb-doc
 716   "Background this thread.  If NEXT is supplied, arrange for it to
 717 have the foreground next."
 718   #!-sb-thread (declare (ignore next))
 719   #!-sb-thread nil
 720   #!+sb-thread
 721   (with-session-lock (*session*)
 722     (when (rest (session-interactive-threads *session*))
 723       (setf (session-interactive-threads *session*)
 724             (delete *current-thread* (session-interactive-threads *session*))))
 725     (when next
 726       (setf (session-interactive-threads *session*)
 727             (list* next
 728                    (delete next (session-interactive-threads *session*)))))
 729     (condition-broadcast (session-interactive-threads-queue *session*))))
 730
 731 (defun foreground-thread ()
 732   (car (session-interactive-threads *session*)))
 733
 734 (defun make-listener-thread (tty-name)
 735   (assert (probe-file tty-name))
 736   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 737          (out (sb!unix:unix-dup in))
 738          (err (sb!unix:unix-dup in)))
 739     (labels ((thread-repl ()
 740                (sb!unix::unix-setsid)
 741                (let* ((sb!impl::*stdin*
 742                        (make-fd-stream in :input t :buffering :line
 743                                        :dual-channel-p t))
 744                       (sb!impl::*stdout*
 745                        (make-fd-stream out :output t :buffering :line
 746                                               :dual-channel-p t))
 747                       (sb!impl::*stderr*
 748                        (make-fd-stream err :output t :buffering :line
 749                                               :dual-channel-p t))
 750                       (sb!impl::*tty*
 751                        (make-fd-stream err :input t :output t
 752                                               :buffering :line
 753                                               :dual-channel-p t))
 754                       (sb!impl::*descriptor-handlers* nil))
 755                  (with-new-session ()
 756                    (unwind-protect
 757                         (sb!impl::toplevel-repl nil)
 758                      (sb!int:flush-standard-output-streams))))))
 759       (make-thread #'thread-repl))))
 760 \f
 761
 762 ;;;; The beef
 763
 764 (defun make-thread (function &key name)
 765   #!+sb-doc
 766   "Create a new thread of NAME that runs FUNCTION. When the function
 767 returns the thread exits. The return values of FUNCTION are kept
 768 around and can be retrieved by JOIN-THREAD."
 769   #!-sb-thread (declare (ignore function name))
 770   #!-sb-thread (error "Not supported in unithread builds.")
 771   #!+sb-thread
 772   (let* ((thread (%make-thread :name name))
 773          (setup-sem (make-semaphore :name "Thread setup semaphore"))
 774          (real-function (coerce function 'function))
 775          (initial-function
 776           (lambda ()
 777             ;; In time we'll move some of the binding presently done in C
 778             ;; here too.
 779             ;;
 780             ;; KLUDGE: Here we have a magic list of variables that are
 781             ;; not thread-safe for one reason or another.  As people
 782             ;; report problems with the thread safety of certain
 783             ;; variables, (e.g. "*print-case* in multiple threads
 784             ;; broken", sbcl-devel 2006-07-14), we add a few more
 785             ;; bindings here.  The Right Thing is probably some variant
 786             ;; of Allegro's *cl-default-special-bindings*, as that is at
 787             ;; least accessible to users to secure their own libraries.
 788             ;;   --njf, 2006-07-15
 789             ;;
 790             ;; As it is, this lambda must not cons until we are ready
 791             ;; to run GC. Be very careful.
 792             (let* ((*current-thread* thread)
 793                    (*restart-clusters* nil)
 794                    (*handler-clusters* (sb!kernel::initial-handler-clusters))
 795                    (*condition-restarts* nil)
 796                    (sb!impl::*deadline* nil)
 797                    (sb!impl::*step-out* nil)
 798                    ;; internal printer variables
 799                    (sb!impl::*previous-case* nil)
 800                    (sb!impl::*previous-readtable-case* nil)
 801                    (empty (vector))
 802                    (sb!impl::*merge-sort-temp-vector* empty)
 803                    (sb!impl::*zap-array-data-temp* empty)
 804                    (sb!impl::*internal-symbol-output-fun* nil)
 805                    (sb!impl::*descriptor-handlers* nil)) ; serve-event
 806               ;; Binding from C
 807               (setf sb!vm:*alloc-signal* *default-alloc-signal*)
 808               (setf (thread-os-thread thread) (current-thread-os-thread))
 809               (with-mutex ((thread-result-lock thread))
 810                 (with-all-threads-lock
 811                   (push thread *all-threads*))
 812                 (with-session-lock (*session*)
 813                   (push thread (session-threads *session*)))
 814                 (setf (thread-%alive-p thread) t)
 815                 (signal-semaphore setup-sem)
 816                 ;; can't use handling-end-of-the-world, because that flushes
 817                 ;; output streams, and we don't necessarily have any (or we
 818                 ;; could be sharing them)
 819                 (catch 'sb!impl::toplevel-catcher
 820                   (catch 'sb!impl::%end-of-the-world
 821                     (with-simple-restart
 822                         (terminate-thread
 823                          (format nil
 824                                  "~~@<Terminate this thread (~A)~~@:>"
 825                                  *current-thread*))
 826                       (without-interrupts
 827                         (unwind-protect
 828                              (with-local-interrupts
 829                                ;; Now that most things have a chance
 830                                ;; to work properly without messing up
 831                                ;; other threads, it's time to enable
 832                                ;; signals.
 833                                (sb!unix::unblock-deferrable-signals)
 834                                (setf (thread-result thread)
 835                                      (cons t
 836                                            (multiple-value-list
 837                                             (funcall real-function))))
 838                                ;; Try to block deferrables. An
 839                                ;; interrupt may unwind it, but for a
 840                                ;; normal exit it prevents interrupt
 841                                ;; loss.
 842                                (block-deferrable-signals))
 843                           ;; We're going down, can't handle interrupts
 844                           ;; sanely anymore. GC remains enabled.
 845                           (block-deferrable-signals)
 846                           ;; We don't want to run interrupts in a dead
 847                           ;; thread when we leave WITHOUT-INTERRUPTS.
 848                           ;; This potentially causes important
 849                           ;; interupts to be lost: SIGINT comes to
 850                           ;; mind.
 851                           (setq *interrupt-pending* nil)
 852                           (handle-thread-exit thread))))))))
 853             (values))))
 854     ;; If the starting thread is stopped for gc before it signals the
 855     ;; semaphore then we'd be stuck.
 856     (assert (not *gc-inhibit*))
 857     ;; Keep INITIAL-FUNCTION pinned until the child thread is
 858     ;; initialized properly. Wrap the whole thing in
 859     ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
 860     ;; thread.
 861     (without-interrupts
 862       (with-pinned-objects (initial-function)
 863         (let ((os-thread
 864                (%create-thread
 865                 (get-lisp-obj-address initial-function))))
 866           (when (zerop os-thread)
 867             (error "Can't create a new thread"))
 868           (wait-on-semaphore setup-sem)
 869           thread)))))
 870
 871 (define-condition join-thread-error (error)
 872   ((thread :reader join-thread-error-thread :initarg :thread))
 873   #!+sb-doc
 874   (:documentation "Joining thread failed.")
 875   (:report (lambda (c s)
 876              (format s "Joining thread failed: thread ~A ~
 877                         has not returned normally."
 878                      (join-thread-error-thread c)))))
 879
 880 #!+sb-doc
 881 (setf (fdocumentation 'join-thread-error-thread 'function)
 882       "The thread that we failed to join.")
 883
 884 (defun join-thread (thread &key (default nil defaultp))
 885   #!+sb-doc
 886   "Suspend current thread until THREAD exits. Returns the result
 887 values of the thread function. If the thread does not exit normally,
 888 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
 889   (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
 890     (cond ((car (thread-result thread))
 891            (return-from join-thread
 892              (values-list (cdr (thread-result thread)))))
 893           (defaultp
 894            (return-from join-thread default))))
 895   (error 'join-thread-error :thread thread))
 896
 897 (defun destroy-thread (thread)
 898   #!+sb-doc
 899   "Deprecated. Same as TERMINATE-THREAD."
 900   (terminate-thread thread))
 901
 902 (define-condition interrupt-thread-error (error)
 903   ((thread :reader interrupt-thread-error-thread :initarg :thread))
 904   #!+sb-doc
 905   (:documentation "Interrupting thread failed.")
 906   (:report (lambda (c s)
 907              (format s "Interrupt thread failed: thread ~A has exited."
 908                      (interrupt-thread-error-thread c)))))
 909
 910 #!+sb-doc
 911 (setf (fdocumentation 'interrupt-thread-error-thread 'function)
 912       "The thread that was not interrupted.")
 913
 914 (defmacro with-interruptions-lock ((thread) &body body)
 915   `(with-system-mutex ((thread-interruptions-lock ,thread))
 916      ,@body))
 917
 918 ;;; Called from the signal handler.
 919 (defun run-interruption ()
 920   (let ((interruption (with-interruptions-lock (*current-thread*)
 921                         (pop (thread-interruptions *current-thread*)))))
 922     ;; If there is more to do, then resignal and let the normal
 923     ;; interrupt deferral mechanism take care of the rest. From the
 924     ;; OS's point of view the signal we are in the handler for is no
 925     ;; longer pending, so the signal will not be lost.
 926     (when (thread-interruptions *current-thread*)
 927       (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe))
 928     (when interruption
 929       (funcall interruption))))
 930
 931 (defun interrupt-thread (thread function)
 932   #!+sb-doc
 933   "Interrupt the live THREAD and make it run FUNCTION. A moderate
 934 degree of care is expected for use of INTERRUPT-THREAD, due to its
 935 nature: if you interrupt a thread that was holding important locks
 936 then do something that turns out to need those locks, you probably
 937 won't like the effect. FUNCTION runs with interrupts disabled, but
 938 WITH-INTERRUPTS is allowed in it. Keep in mind that many things may
 939 enable interrupts (GET-MUTEX when contended, for instance) so the
 940 first thing to do is usually a WITH-INTERRUPTS or a
 941 WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are
 942 run in same the order they were sent."
 943   (let ((os-thread (thread-os-thread thread)))
 944     (cond ((not os-thread)
 945            (error 'interrupt-thread-error :thread thread))
 946           (t
 947            (with-interruptions-lock (thread)
 948              ;; Append to the end of the interruptions queue. It's
 949              ;; O(N), but it does not hurt to slow interruptors down a
 950              ;; bit when the queue gets long.
 951              (setf (thread-interruptions thread)
 952                    (append (thread-interruptions thread)
 953                            (list (lambda ()
 954                                    (without-interrupts
 955                                      (allow-with-interrupts
 956                                        (funcall function))))))))
 957            (when (minusp (kill-safely os-thread sb!unix:sigpipe))
 958              (error 'interrupt-thread-error :thread thread))))))
 959
 960 (defun terminate-thread (thread)
 961   #!+sb-doc
 962   "Terminate the thread identified by THREAD, by causing it to run
 963 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 964   (interrupt-thread thread 'sb!ext:quit))
 965
 966 (define-alien-routine "thread_yield" int)
 967
 968 #!+sb-doc
 969 (setf (fdocumentation 'thread-yield 'function)
 970       "Yield the processor to other threads.")
 971
 972 ;;; internal use only.  If you think you need to use these, either you
 973 ;;; are an SBCL developer, are doing something that you should discuss
 974 ;;; with an SBCL developer first, or are doing something that you
 975 ;;; should probably discuss with a professional psychiatrist first
 976 #!+sb-thread
 977 (progn
 978   (defun %thread-sap (thread)
 979     (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))
 980           (target (thread-os-thread thread)))
 981       (loop
 982         (when (sap= thread-sap (int-sap 0)) (return nil))
 983         (let ((os-thread (sap-ref-word thread-sap
 984                                        (* sb!vm:n-word-bytes
 985                                           sb!vm::thread-os-thread-slot))))
 986           (when (= os-thread target) (return thread-sap))
 987           (setf thread-sap
 988                 (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
 989                                            sb!vm::thread-next-slot)))))))
 990
 991   (defun %symbol-value-in-thread (symbol thread)
 992     (tagbody
 993        ;; Prevent the dead from dying completely while we look for the
 994        ;; TLS area...
 995        (with-all-threads-lock
 996          (if (thread-alive-p thread)
 997              (let* ((offset (* sb!vm:n-word-bytes
 998                                (sb!vm::symbol-tls-index symbol)))
 999                     (tl-val (sap-ref-word (%thread-sap thread) offset)))
1000                (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
1001                    (go :unbound)
1002                    (return-from %symbol-value-in-thread
1003                      (values (make-lisp-obj tl-val) t))))
1004              (return-from %symbol-value-in-thread (values nil nil))))
1005      :unbound
1006        (error "Cannot read thread-local symbol value: ~S unbound in ~S"
1007               symbol thread)))
1008
1009   (defun %set-symbol-value-in-thread (symbol thread value)
1010     (tagbody
1011        (with-pinned-objects (value)
1012          ;; Prevent the dead from dying completely while we look for
1013          ;; the TLS area...
1014          (with-all-threads-lock
1015            (if (thread-alive-p thread)
1016                (let* ((offset (* sb!vm:n-word-bytes
1017                                  (sb!vm::symbol-tls-index symbol)))
1018                       (sap (%thread-sap thread))
1019                       (tl-val (sap-ref-word sap offset)))
1020                  (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
1021                      (go :unbound)
1022                      (setf (sap-ref-word sap offset)
1023                            (get-lisp-obj-address value)))
1024                  (return-from %set-symbol-value-in-thread (values value t)))
1025                (return-from %set-symbol-value-in-thread (values nil nil)))))
1026      :unbound
1027        (error "Cannot set thread-local symbol value: ~S unbound in ~S"
1028               symbol thread))))
1029
1030 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
1031   (sb!vm::locked-symbol-global-value-add symbol-name delta))
1032 \f
1033
1034 ;;;; Stepping
1035
1036 (defun thread-stepping ()
1037   (make-lisp-obj
1038    (sap-ref-word (current-thread-sap)
1039                  (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
1040
1041 (defun (setf thread-stepping) (value)
1042   (setf (sap-ref-word (current-thread-sap)
1043                       (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
1044         (get-lisp-obj-address value)))