src/code/target-multithread.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 (define-alien-routine ("create_thread" %create-thread)
  15     system-area-pointer
  16   (lisp-fun-address unsigned-long))
  17
  18 (define-alien-routine reap-dead-thread void
  19   (thread-sap system-area-pointer))
  20
  21 (defvar *session* nil)
  22
  23 ;;;; queues, locks
  24
  25 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  26 (declaim (inline get-spinlock release-spinlock))
  27
  28 (defun get-spinlock (lock offset new-value)
  29   (declare (optimize (speed 3) (safety 0)))
  30   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
  31   ;; store any value
  32   (loop until
  33        (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
  34
  35 (defun release-spinlock (lock offset)
  36   (declare (optimize (speed 3) (safety 0)))
  37   ;; %instance-set-conditional cannot compare arbitrary objects
  38   ;; meaningfully, so
  39   ;; (sb!vm::%instance-set-conditional lock offset our-value 0)
  40   ;; does not work for bignum thread ids.
  41   (sb!vm::%instance-set lock offset 0))
  42
  43 (defmacro with-spinlock ((queue) &body body)
  44   `(unwind-protect
  45     (progn
  46       (get-spinlock ,queue 2 *current-thread*)
  47       ,@body)
  48     (release-spinlock ,queue 2)))
  49
  50
  51 ;;;; the higher-level locking operations are based on waitqueues
  52
  53 (declaim (inline waitqueue-data-address mutex-value-address))
  54
  55 (defstruct waitqueue
  56   (name nil :type (or null simple-string))
  57   (lock 0)
  58   (data nil))
  59
  60 ;;; The bare 4 here and 5 below are offsets of the slots in the struct.
  61 ;;; There ought to be some better way to get these numbers
  62 (defun waitqueue-data-address (lock)
  63   (declare (optimize (speed 3)))
  64   (sb!ext:truly-the
  65    (unsigned-byte 32)
  66    (+ (sb!kernel:get-lisp-obj-address lock)
  67       (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
  68
  69 (defstruct (mutex (:include waitqueue))
  70   (value nil))
  71
  72 (defun mutex-value-address (lock)
  73   (declare (optimize (speed 3)))
  74   (sb!ext:truly-the
  75    (unsigned-byte 32)
  76    (+ (sb!kernel:get-lisp-obj-address lock)
  77       (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
  78
  79 (declaim (inline futex-wait futex-wake))
  80 (sb!alien:define-alien-routine
  81     "futex_wait" int (word unsigned-long) (old-value unsigned-long))
  82 (sb!alien:define-alien-routine
  83     "futex_wake" int (word unsigned-long) (n unsigned-long))
  84
  85
  86 ;;;; mutex
  87
  88 (defun get-mutex (lock &optional new-value (wait-p t))
  89   "Acquire LOCK, setting it to NEW-VALUE or some suitable default value
  90 if NIL.  If WAIT-P is non-NIL and the lock is in use, sleep until it
  91 is available"
  92   (declare (type mutex lock) (optimize (speed 3)))
  93   (let (old)
  94     (unless new-value (setf new-value *current-thread*))
  95     (when (eql new-value (mutex-value lock))
  96       (warn "recursive lock attempt ~S~%" lock)
  97       (format *debug-io* "Thread: ~A~%" *current-thread*)
  98       (sb!debug:backtrace most-positive-fixnum *debug-io*)
  99       (force-output *debug-io*))
 100     (loop
 101      (unless
 102          (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value))
 103        (return t))
 104      (unless wait-p (return nil))
 105      (futex-wait (mutex-value-address lock)
 106                  (sb!kernel:get-lisp-obj-address old)))))
 107
 108 (defun release-mutex (lock)
 109   (declare (type mutex lock))
 110   (setf (mutex-value lock) nil)
 111   (futex-wake (mutex-value-address lock) 1))
 112
 113 ;;;; condition variables
 114
 115 (defun condition-wait (queue lock)
 116   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 117 thread may subsequently notify us using CONDITION-NOTIFY, at which
 118 time we reacquire LOCK and return to the caller."
 119   (assert lock)
 120   (let ((value (mutex-value lock)))
 121     (unwind-protect
 122          (let ((me *current-thread*))
 123            ;; XXX we should do something to ensure that the result of this setf
 124            ;; is visible to all CPUs
 125            (setf (waitqueue-data queue) me)
 126            (release-mutex lock)
 127            ;; Now we go to sleep using futex-wait.  If anyone else
 128            ;; manages to grab LOCK and call CONDITION-NOTIFY during
 129            ;; this comment, it will change queue->data, and so
 130            ;; futex-wait returns immediately instead of sleeping.
 131            ;; Ergo, no lost wakeup
 132            (futex-wait (waitqueue-data-address queue)
 133                        (sb!kernel:get-lisp-obj-address me)))
 134       ;; If we are interrupted while waiting, we should do these things
 135       ;; before returning.  Ideally, in the case of an unhandled signal,
 136       ;; we should do them before entering the debugger, but this is
 137       ;; better than nothing.
 138       (get-mutex lock value))))
 139
 140 (defun condition-notify (queue)
 141   "Notify one of the processes waiting on QUEUE"
 142   (let ((me *current-thread*))
 143     ;; no problem if >1 thread notifies during the comment in
 144     ;; condition-wait: as long as the value in queue-data isn't the
 145     ;; waiting thread's id, it matters not what it is
 146     ;; XXX we should do something to ensure that the result of this setf
 147     ;; is visible to all CPUs
 148     (setf (waitqueue-data queue) me)
 149     (futex-wake (waitqueue-data-address queue) 1)))
 150
 151 (defun condition-broadcast (queue)
 152   (let ((me *current-thread*))
 153     (setf (waitqueue-data queue) me)
 154     (futex-wake (waitqueue-data-address queue) (ash 1 30))))
 155
 156 (defun make-thread (function &key name)
 157   ;;   ;; don't let them interrupt us because the child is waiting for setup-p
 158   ;;   (sb!sys:without-interrupts
 159   (let* ((thread (%make-thread :name name))
 160          (setup-p nil)
 161          (real-function (coerce function 'function))
 162          (thread-sap
 163           (%create-thread
 164            (sb!kernel:get-lisp-obj-address
 165             (lambda ()
 166               ;; FIXME: use semaphores?
 167               (loop until setup-p)
 168               ;; in time we'll move some of the binding presently done in C
 169               ;; here too
 170               (let ((*current-thread* thread)
 171                     (sb!kernel::*restart-clusters* nil)
 172                     (sb!kernel::*handler-clusters* nil)
 173                     (sb!kernel::*condition-restarts* nil)
 174                     (sb!impl::*descriptor-handlers* nil) ; serve-event
 175                     (sb!impl::*available-buffers* nil)) ;for fd-stream
 176                 ;; can't use handling-end-of-the-world, because that flushes
 177                 ;; output streams, and we don't necessarily have any (or we
 178                 ;; could be sharing them)
 179                 (unwind-protect
 180                      (catch 'sb!impl::toplevel-catcher
 181                        (catch 'sb!impl::%end-of-the-world
 182                          (with-simple-restart
 183                              (terminate-thread
 184                               (format nil "~~@<Terminate this thread (~A)~~@:>"
 185                                       *current-thread*))
 186                            ;; now that most things have a chance to work
 187                            ;; properly without messing up other threads, it's
 188                            ;; time to enable signals
 189                            (sb!unix::reset-signal-mask)
 190                            (unwind-protect
 191                                 (funcall real-function)
 192                              ;; we're going down, can't handle
 193                              ;; interrupts sanely anymore
 194                              (sb!unix::block-blockable-signals)))))
 195                   ;; mark the thread dead, so that the gc does not
 196                   ;; wait for it to handle sig-stop-for-gc
 197                   (%set-thread-state thread :dead)
 198                   ;; and remove what can be the last reference to
 199                   ;; the thread object
 200                   (handle-thread-exit thread)
 201                   0))
 202               (values))))))
 203     (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
 204       (error "Can't create a new thread"))
 205     (setf (thread-%sap thread) thread-sap)
 206     (with-mutex (*all-threads-lock*)
 207       (push thread *all-threads*))
 208     (with-mutex ((session-lock *session*))
 209       (push thread (session-threads *session*)))
 210     (setq setup-p t)
 211     (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
 212     thread))
 213
 214 (defun destroy-thread (thread)
 215   "Deprecated. Soon to be removed or reimplemented using pthread_cancel."
 216   (terminate-thread thread))
 217
 218 ;;; a moderate degree of care is expected for use of interrupt-thread,
 219 ;;; due to its nature: if you interrupt a thread that was holding
 220 ;;; important locks then do something that turns out to need those
 221 ;;; locks, you probably won't like the effect.
 222
 223 (define-condition interrupt-thread-error (error)
 224   ((thread :reader interrupt-thread-error-thread :initarg :thread)
 225    (errno :reader interrupt-thread-error-errno :initarg :errno))
 226   (:report (lambda (c s)
 227              (format s "interrupt thread ~A failed (~A: ~A)"
 228                      (interrupt-thread-error-thread c)
 229                      (interrupt-thread-error-errno c)
 230                      (strerror (interrupt-thread-error-errno c))))))
 231
 232 (defun interrupt-thread (thread function)
 233   "Interrupt THREAD and make it run FUNCTION."
 234   (let ((function (coerce function 'function)))
 235     (multiple-value-bind (res err)
 236         (sb!unix::syscall ("interrupt_thread"
 237                            system-area-pointer  sb!alien:unsigned-long)
 238                           thread
 239                           (thread-%sap thread)
 240                           (sb!kernel:get-lisp-obj-address function))
 241       (unless res
 242         (error 'interrupt-thread-error :thread thread :errno err)))))
 243
 244 (defun terminate-thread (thread)
 245   "Terminate the thread identified by THREAD, by causing it to run
 246 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 247   (interrupt-thread thread 'sb!ext:quit))
 248
 249 ;;; internal use only.  If you think you need to use this, either you
 250 ;;; are an SBCL developer, are doing something that you should discuss
 251 ;;; with an SBCL developer first, or are doing something that you
 252 ;;; should probably discuss with a professional psychiatrist first
 253 (defun symbol-value-in-thread (symbol thread)
 254   (let ((thread-sap (thread-%sap thread)))
 255     (let* ((index (sb!vm::symbol-tls-index symbol))
 256            (tl-val (sb!sys:sap-ref-word thread-sap
 257                                         (* sb!vm:n-word-bytes index))))
 258       (if (eql tl-val sb!vm::unbound-marker-widetag)
 259           (sb!vm::symbol-global-value symbol)
 260           (sb!kernel:make-lisp-obj tl-val)))))
 261
 262 ;;;; job control, independent listeners
 263
 264 (defstruct session
 265   (lock (make-mutex :name "session lock"))
 266   (threads nil)
 267   (interactive-threads nil)
 268   (interactive-threads-queue (make-waitqueue)))
 269
 270 (defun new-session ()
 271   (make-session :threads (list *current-thread*)
 272                 :interactive-threads (list *current-thread*)))
 273
 274 (defun init-job-control ()
 275   (setf *session* (new-session)))
 276
 277 (defun %delete-thread-from-session (thread session)
 278   (with-mutex ((session-lock session))
 279     (setf (session-threads session)
 280           (delete thread (session-threads session))
 281           (session-interactive-threads session)
 282           (delete thread (session-interactive-threads session)))))
 283
 284 (defun call-with-new-session (fn)
 285   (%delete-thread-from-session *current-thread* *session*)
 286   (let ((*session* (new-session)))
 287     (funcall fn)))
 288
 289 (defmacro with-new-session (args &body forms)
 290   (declare (ignore args))               ;for extensibility
 291   (sb!int:with-unique-names (fb-name)
 292     `(labels ((,fb-name () ,@forms))
 293       (call-with-new-session (function ,fb-name)))))
 294
 295 ;;; Remove thread from its session, if it has one.
 296 (defun handle-thread-exit (thread)
 297   (with-mutex (*all-threads-lock*)
 298     (setq *all-threads* (delete thread *all-threads*)))
 299   (when *session*
 300     (%delete-thread-from-session thread *session*)))
 301
 302 (defun terminate-session ()
 303   "Kill all threads in session except for this one.  Does nothing if current
 304 thread is not the foreground thread"
 305   ;; FIXME: threads created in other threads may escape termination
 306   (let ((to-kill
 307          (with-mutex ((session-lock *session*))
 308            (and (eq *current-thread*
 309                     (car (session-interactive-threads *session*)))
 310                 (session-threads *session*)))))
 311     ;; do the kill after dropping the mutex; unwind forms in dying
 312     ;; threads may want to do session things
 313     (dolist (thread to-kill)
 314       (unless (eq thread *current-thread*)
 315         ;; terminate the thread but don't be surprised if it has
 316         ;; exited in the meantime
 317         (handler-case (terminate-thread thread)
 318           (interrupt-thread-error ()))))))
 319
 320 ;;; called from top of invoke-debugger
 321 (defun debugger-wait-until-foreground-thread (stream)
 322   "Returns T if thread had been running in background, NIL if it was
 323 interactive."
 324   (declare (ignore stream))
 325   (prog1
 326       (with-mutex ((session-lock *session*))
 327         (not (member *current-thread*
 328                      (session-interactive-threads *session*))))
 329     (get-foreground)))
 330
 331 (defun get-foreground ()
 332   (let ((was-foreground t))
 333     (loop
 334      (with-mutex ((session-lock *session*))
 335        (let ((int-t (session-interactive-threads *session*)))
 336          (when (eq (car int-t) *current-thread*)
 337            (unless was-foreground
 338              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 339            (return-from get-foreground t))
 340          (setf was-foreground nil)
 341          (unless (member *current-thread* int-t)
 342            (setf (cdr (last int-t))
 343                  (list *current-thread*)))
 344          (condition-wait
 345           (session-interactive-threads-queue *session*)
 346           (session-lock *session*)))))))
 347
 348 (defun release-foreground (&optional next)
 349   "Background this thread.  If NEXT is supplied, arrange for it to
 350 have the foreground next"
 351   (with-mutex ((session-lock *session*))
 352     (setf (session-interactive-threads *session*)
 353           (delete *current-thread* (session-interactive-threads *session*)))
 354     (when next
 355       (setf (session-interactive-threads *session*)
 356             (list* next
 357                    (delete next (session-interactive-threads *session*)))))
 358     (condition-broadcast (session-interactive-threads-queue *session*))))
 359
 360 (defun foreground-thread ()
 361   (car (session-interactive-threads *session*)))
 362
 363 (defun make-listener-thread (tty-name)
 364   (assert (probe-file tty-name))
 365   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 366          (out (sb!unix:unix-dup in))
 367          (err (sb!unix:unix-dup in)))
 368     (labels ((thread-repl ()
 369                (sb!unix::unix-setsid)
 370                (let* ((sb!impl::*stdin*
 371                        (sb!sys:make-fd-stream in :input t :buffering :line
 372                                               :dual-channel-p t))
 373                       (sb!impl::*stdout*
 374                        (sb!sys:make-fd-stream out :output t :buffering :line
 375                                               :dual-channel-p t))
 376                       (sb!impl::*stderr*
 377                        (sb!sys:make-fd-stream err :output t :buffering :line
 378                                               :dual-channel-p t))
 379                       (sb!impl::*tty*
 380                        (sb!sys:make-fd-stream err :input t :output t
 381                                               :buffering :line
 382                                               :dual-channel-p t))
 383                       (sb!impl::*descriptor-handlers* nil))
 384                  (with-new-session ()
 385                    (unwind-protect
 386                         (sb!impl::toplevel-repl nil)
 387                      (sb!int:flush-standard-output-streams))))))
 388       (make-thread #'thread-repl))))