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::%end-of-the-world
 181                        (with-simple-restart
 182                            (terminate-thread
 183                             (format nil "~~@<Terminate this thread (~A)~~@:>"
 184                                     *current-thread*))
 185                          ;; now that most things have a chance to work
 186                          ;; properly without messing up other threads, it's
 187                          ;; time to enable signals
 188                          (sb!unix::reset-signal-mask)
 189                          (unwind-protect
 190                               (funcall real-function)
 191                            ;; we're going down, can't handle
 192                            ;; interrupts sanely anymore
 193                            (sb!unix::block-blockable-signals))))
 194                   ;; mark the thread dead, so that the gc does not
 195                   ;; wait for it to handle sig-stop-for-gc
 196                   (%set-thread-state thread :dead)
 197                   ;; and remove what can be the last reference to
 198                   ;; the thread object
 199                   (handle-thread-exit thread)
 200                   0))
 201               (values))))))
 202     (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
 203       (error "Can't create a new thread"))
 204     (setf (thread-%sap thread) thread-sap)
 205     (with-mutex (*all-threads-lock*)
 206       (push thread *all-threads*))
 207     (with-mutex ((session-lock *session*))
 208       (push thread (session-threads *session*)))
 209     (setq setup-p t)
 210     (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
 211     thread))
 212
 213 (defun destroy-thread (thread)
 214   "Deprecated. Soon to be removed or reimplemented using pthread_cancel."
 215   (terminate-thread thread))
 216
 217 ;;; a moderate degree of care is expected for use of interrupt-thread,
 218 ;;; due to its nature: if you interrupt a thread that was holding
 219 ;;; important locks then do something that turns out to need those
 220 ;;; locks, you probably won't like the effect.
 221
 222 (define-condition interrupt-thread-error (error)
 223   ((thread :reader interrupt-thread-error-thread :initarg :thread)
 224    (errno :reader interrupt-thread-error-errno :initarg :errno))
 225   (:report (lambda (c s)
 226              (format s "interrupt thread ~A failed (~A: ~A)"
 227                      (interrupt-thread-error-thread c)
 228                      (interrupt-thread-error-errno c)
 229                      (strerror (interrupt-thread-error-errno c))))))
 230
 231 (defun interrupt-thread (thread function)
 232   "Interrupt THREAD and make it run FUNCTION."
 233   (let ((function (coerce function 'function)))
 234     (multiple-value-bind (res err)
 235         (sb!unix::syscall ("interrupt_thread"
 236                            system-area-pointer  sb!alien:unsigned-long)
 237                           thread
 238                           (thread-%sap thread)
 239                           (sb!kernel:get-lisp-obj-address function))
 240       (unless res
 241         (error 'interrupt-thread-error :thread thread :errno err)))))
 242
 243 (defun terminate-thread (thread)
 244   "Terminate the thread identified by THREAD, by causing it to run
 245 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 246   (interrupt-thread thread 'sb!ext:quit))
 247
 248 ;;; internal use only.  If you think you need to use this, either you
 249 ;;; are an SBCL developer, are doing something that you should discuss
 250 ;;; with an SBCL developer first, or are doing something that you
 251 ;;; should probably discuss with a professional psychiatrist first
 252 (defun symbol-value-in-thread (symbol thread)
 253   (let ((thread-sap (thread-%sap thread)))
 254     (let* ((index (sb!vm::symbol-tls-index symbol))
 255            (tl-val (sb!sys:sap-ref-word thread-sap
 256                                         (* sb!vm:n-word-bytes index))))
 257       (if (eql tl-val sb!vm::unbound-marker-widetag)
 258           (sb!vm::symbol-global-value symbol)
 259           (sb!kernel:make-lisp-obj tl-val)))))
 260
 261 ;;;; job control, independent listeners
 262
 263 (defstruct session
 264   (lock (make-mutex :name "session lock"))
 265   (threads nil)
 266   (interactive-threads nil)
 267   (interactive-threads-queue (make-waitqueue)))
 268
 269 (defun new-session ()
 270   (make-session :threads (list *current-thread*)
 271                 :interactive-threads (list *current-thread*)))
 272
 273 (defun init-job-control ()
 274   (setf *session* (new-session)))
 275
 276 (defun %delete-thread-from-session (thread session)
 277   (with-mutex ((session-lock session))
 278     (setf (session-threads session)
 279           (delete thread (session-threads session))
 280           (session-interactive-threads session)
 281           (delete thread (session-interactive-threads session)))))
 282
 283 (defun call-with-new-session (fn)
 284   (%delete-thread-from-session *current-thread* *session*)
 285   (let ((*session* (new-session)))
 286     (funcall fn)))
 287
 288 (defmacro with-new-session (args &body forms)
 289   (declare (ignore args))               ;for extensibility
 290   (sb!int:with-unique-names (fb-name)
 291     `(labels ((,fb-name () ,@forms))
 292       (call-with-new-session (function ,fb-name)))))
 293
 294 ;;; Remove thread from its session, if it has one.
 295 (defun handle-thread-exit (thread)
 296   (with-mutex (*all-threads-lock*)
 297     (setq *all-threads* (delete thread *all-threads*)))
 298   (when *session*
 299     (%delete-thread-from-session thread *session*)))
 300
 301 (defun terminate-session ()
 302   "Kill all threads in session except for this one.  Does nothing if current
 303 thread is not the foreground thread"
 304   ;; FIXME: threads created in other threads may escape termination
 305   (let ((to-kill
 306          (with-mutex ((session-lock *session*))
 307            (and (eq *current-thread*
 308                     (car (session-interactive-threads *session*)))
 309                 (session-threads *session*)))))
 310     ;; do the kill after dropping the mutex; unwind forms in dying
 311     ;; threads may want to do session things
 312     (dolist (thread to-kill)
 313       (unless (eq thread *current-thread*)
 314         ;; terminate the thread but don't be surprised if it has
 315         ;; exited in the meantime
 316         (handler-case (terminate-thread thread)
 317           (interrupt-thread-error ()))))))
 318
 319 ;;; called from top of invoke-debugger
 320 (defun debugger-wait-until-foreground-thread (stream)
 321   "Returns T if thread had been running in background, NIL if it was
 322 interactive."
 323   (declare (ignore stream))
 324   (prog1
 325       (with-mutex ((session-lock *session*))
 326         (not (member *current-thread*
 327                      (session-interactive-threads *session*))))
 328     (get-foreground)))
 329
 330 (defun get-foreground ()
 331   (let ((was-foreground t))
 332     (loop
 333      (with-mutex ((session-lock *session*))
 334        (let ((int-t (session-interactive-threads *session*)))
 335          (when (eq (car int-t) *current-thread*)
 336            (unless was-foreground
 337              (format *query-io* "Resuming thread ~A~%" *current-thread*))
 338            (return-from get-foreground t))
 339          (setf was-foreground nil)
 340          (unless (member *current-thread* int-t)
 341            (setf (cdr (last int-t))
 342                  (list *current-thread*)))
 343          (condition-wait
 344           (session-interactive-threads-queue *session*)
 345           (session-lock *session*)))))))
 346
 347 (defun release-foreground (&optional next)
 348   "Background this thread.  If NEXT is supplied, arrange for it to
 349 have the foreground next"
 350   (with-mutex ((session-lock *session*))
 351     (setf (session-interactive-threads *session*)
 352           (delete *current-thread* (session-interactive-threads *session*)))
 353     (when next
 354       (setf (session-interactive-threads *session*)
 355             (list* next
 356                    (delete next (session-interactive-threads *session*)))))
 357     (condition-broadcast (session-interactive-threads-queue *session*))))
 358
 359 (defun foreground-thread ()
 360   (car (session-interactive-threads *session*)))
 361
 362 (defun make-listener-thread (tty-name)
 363   (assert (probe-file tty-name))
 364   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 365          (out (sb!unix:unix-dup in))
 366          (err (sb!unix:unix-dup in)))
 367     (labels ((thread-repl ()
 368                (sb!unix::unix-setsid)
 369                (let* ((sb!impl::*stdin*
 370                        (sb!sys:make-fd-stream in :input t :buffering :line
 371                                               :dual-channel-p t))
 372                       (sb!impl::*stdout*
 373                        (sb!sys:make-fd-stream out :output t :buffering :line
 374                                               :dual-channel-p t))
 375                       (sb!impl::*stderr*
 376                        (sb!sys:make-fd-stream err :output t :buffering :line
 377                                               :dual-channel-p t))
 378                       (sb!impl::*tty*
 379                        (sb!sys:make-fd-stream err :input t :output t
 380                                               :buffering :line
 381                                               :dual-channel-p t))
 382                       (sb!impl::*descriptor-handlers* nil))
 383                  (with-new-session ()
 384                    (unwind-protect
 385                         (sb!impl::toplevel-repl nil)
 386                      (sb!int:flush-standard-output-streams))))))
 387       (make-thread #'thread-repl))))