src/code/target-thread.lisp

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