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