src/code/target-thread.lisp

   1 (in-package "SB!THREAD")
   2
   3 ;;; FIXME it would be good to define what a thread id is or isn't (our
   4 ;;; current assumption is that it's a fixnum).  It so happens that on
   5 ;;; Linux it's a pid, but it might not be on posix thread implementations
   6
   7 (sb!alien::define-alien-routine ("create_thread" %create-thread)
   8      sb!alien:unsigned-long
   9   (lisp-fun-address sb!alien:unsigned-long))
  10
  11 (sb!alien::define-alien-routine "signal_thread_to_dequeue"
  12     sb!alien:unsigned-int
  13   (thread-pid sb!alien:unsigned-long))
  14
  15 (defvar *session* nil)
  16
  17 (defun make-thread (function)
  18   (let* ((real-function (coerce function 'function))
  19          (tid
  20           (%create-thread
  21            (sb!kernel:get-lisp-obj-address
  22             (lambda ()
  23               ;; in time we'll move some of the binding presently done in C
  24               ;; here too
  25               (let ((sb!kernel::*restart-clusters* nil)
  26                     (sb!impl::*descriptor-handlers* nil) ; serve-event
  27                     (sb!impl::*available-buffers* nil)) ;for fd-stream
  28                 ;; can't use handling-end-of-the-world, because that flushes
  29                 ;; output streams, and we don't necessarily have any (or we
  30                 ;; could be sharing them)
  31                 (sb!sys:enable-interrupt sb!unix:sigint :ignore)
  32                 (sb!unix:unix-exit
  33                  (catch 'sb!impl::%end-of-the-world
  34                    (with-simple-restart
  35                        (destroy-thread
  36                         (format nil "~~@<Destroy this thread (~A)~~@:>"
  37                                 (current-thread-id)))
  38                      (funcall real-function))
  39                    0))))))))
  40     (with-mutex ((session-lock *session*))
  41       (pushnew tid (session-threads *session*)))
  42     tid))
  43
  44 ;;; Really, you don't want to use these: they'll get into trouble with
  45 ;;; garbage collection.  Use a lock or a waitqueue instead
  46 (defun suspend-thread (thread-id)
  47   (sb!unix:unix-kill thread-id sb!unix:sigstop))
  48 (defun resume-thread (thread-id)
  49   (sb!unix:unix-kill thread-id sb!unix:sigcont))
  50 ;;; Note warning about cleanup forms
  51 (defun destroy-thread (thread-id)
  52   "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
  53   (sb!unix:unix-kill thread-id sb!unix:sigterm)
  54   ;; may have been stopped for some reason, so now wake it up to
  55   ;; deliver the TERM
  56   (sb!unix:unix-kill thread-id sb!unix:sigcont))
  57
  58
  59 ;;; a moderate degree of care is expected for use of interrupt-thread,
  60 ;;; due to its nature: if you interrupt a thread that was holding
  61 ;;; important locks then do something that turns out to need those
  62 ;;; locks, you probably won't like the effect.  Used with thought
  63 ;;; though, it's a good deal gentler than the last-resort functions above
  64
  65 (defun interrupt-thread (thread function)
  66   "Interrupt THREAD and make it run FUNCTION.  "
  67   (sb!unix::syscall* ("interrupt_thread"
  68                       sb!alien:unsigned-long  sb!alien:unsigned-long)
  69                      thread
  70                      thread (sb!kernel:get-lisp-obj-address
  71                              (coerce function 'function))))
  72 (defun terminate-thread (thread-id)
  73   "Terminate the thread identified by THREAD-ID, by causing it to run
  74 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
  75   (interrupt-thread thread-id 'sb!ext:quit))
  76
  77 (declaim (inline current-thread-id))
  78 (defun current-thread-id ()
  79   (logand
  80    (sb!sys:sap-int
  81     (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
  82    ;; KLUDGE pids are 16 bit really.  Avoid boxing the return value
  83    (1- (ash 1 16))))
  84
  85 ;;;; iterate over the in-memory threads
  86
  87 (defun mapcar-threads (function)
  88   "Call FUNCTION once for each known thread, giving it the thread structure as argument"
  89   (let ((function (coerce function 'function)))
  90     (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
  91           then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
  92           until (sb!sys:sap= thread (sb!sys:int-sap 0))
  93           collect (funcall function thread))))
  94
  95 ;;;; queues, locks
  96
  97 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  98 (declaim (inline get-spinlock release-spinlock))
  99
 100 (defun get-spinlock (lock offset new-value)
 101   (declare (optimize (speed 3) (safety 0)))
 102   (loop until
 103         (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
 104
 105 ;; this should do nothing if we didn't own the lock, so safe to use in
 106 ;; unwind-protect cleanups when lock acquisition failed for some reason
 107 (defun release-spinlock (lock offset our-value)
 108   (declare (optimize (speed 3) (safety 0)))
 109   (sb!vm::%instance-set-conditional lock offset our-value 0))
 110
 111 (defmacro with-spinlock ((queue) &body body)
 112   (with-unique-names (pid)
 113     `(let ((,pid (current-thread-id)))
 114        (unwind-protect
 115             (progn
 116               (get-spinlock ,queue 2 ,pid)
 117               ,@body)
 118          (release-spinlock ,queue 2 ,pid)))))
 119
 120
 121 ;;;; the higher-level locking operations are based on waitqueues
 122
 123 (declaim (inline waitqueue-data-address mutex-value-address))
 124
 125 (defstruct waitqueue
 126   (name nil :type (or null simple-base-string))
 127   (lock 0)
 128   (data nil))
 129
 130 ;;; The bare 4 here and 5 below are offsets of the slots in the struct.
 131 ;;; There ought to be some better way to get these numbers
 132 (defun waitqueue-data-address (lock)
 133   (declare (optimize (speed 3)))
 134   (sb!ext:truly-the
 135    (unsigned-byte 32)
 136    (+ (sb!kernel:get-lisp-obj-address lock)
 137       (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
 138
 139 (defstruct (mutex (:include waitqueue))
 140   (value nil))
 141
 142 (defun mutex-value-address (lock)
 143   (declare (optimize (speed 3)))
 144   (sb!ext:truly-the
 145    (unsigned-byte 32)
 146    (+ (sb!kernel:get-lisp-obj-address lock)
 147       (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
 148
 149 (sb!alien:define-alien-routine "block_sigcont"  void)
 150 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
 151
 152 #!+sb-futex
 153 (declaim (inline futex-wait futex-wake))
 154 #!+sb-futex
 155 (sb!alien:define-alien-routine
 156     "futex_wait" int (word unsigned-long) (old-value unsigned-long))
 157 #!+sb-futex
 158 (sb!alien:define-alien-routine
 159     "futex_wake" int (word unsigned-long) (n unsigned-long))
 160
 161 ;;; this should only be called while holding the queue spinlock.
 162 ;;; it releases the spinlock before sleeping
 163 (defun wait-on-queue (queue &optional lock)
 164   (let ((pid (current-thread-id)))
 165     (block-sigcont)
 166     (when lock (release-mutex lock))
 167     (sb!sys:without-interrupts
 168      (pushnew pid (waitqueue-data queue)))
 169     (setf (waitqueue-lock queue) 0)
 170     (unblock-sigcont-and-sleep)))
 171
 172 ;;; this should only be called while holding the queue spinlock.  It doesn't
 173 ;;; release it
 174 (defun dequeue (queue)
 175   (let ((pid (current-thread-id)))
 176     (sb!sys:without-interrupts
 177      (setf (waitqueue-data queue)
 178            (delete pid (waitqueue-data queue))))))
 179
 180 ;;; this should only be called while holding the queue spinlock.
 181 (defun signal-queue-head (queue)
 182   (let ((p (car (waitqueue-data queue))))
 183     (when p (signal-thread-to-dequeue p))))
 184
 185 ;;;; mutex
 186
 187 ;;; i suspect there may be a race still in this: the futex version requires
 188 ;;; the old mutex value before sleeping, so how do we get away without it
 189 (defun get-mutex (lock &optional new-value (wait-p t))
 190   (declare (type mutex lock) (optimize (speed 3)))
 191   (let ((pid (current-thread-id)))
 192     (unless new-value (setf new-value pid))
 193     (assert (not (eql new-value (mutex-value lock))))
 194     (get-spinlock lock 2 pid)
 195     (loop
 196      (unless
 197          ;; args are object slot-num old-value new-value
 198          (sb!vm::%instance-set-conditional lock 4 nil new-value)
 199        (dequeue lock)
 200        (setf (waitqueue-lock lock) 0)
 201        (return t))
 202      (unless wait-p
 203        (setf (waitqueue-lock lock) 0)
 204        (return nil))
 205      (wait-on-queue lock nil))))
 206
 207 #!+sb-futex
 208 (defun get-mutex/futex (lock &optional new-value (wait-p t))
 209   (declare (type mutex lock)  (optimize (speed 3)))
 210   (let ((pid (current-thread-id))
 211         old)
 212     (unless new-value (setf new-value pid))
 213     (assert (not (eql new-value (mutex-value lock))))
 214     (loop
 215      (unless
 216          (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value))
 217        (return t))
 218      (unless wait-p (return nil))
 219      (futex-wait (mutex-value-address lock)
 220                  (sb!kernel:get-lisp-obj-address old)))))
 221
 222 (defun release-mutex (lock &optional (new-value nil))
 223   (declare (type mutex lock))
 224   ;; we assume the lock is ours to release
 225   (with-spinlock (lock)
 226     (setf (mutex-value lock) new-value)
 227     (signal-queue-head lock)))
 228
 229 #!+sb-futex
 230 (defun release-mutex/futex (lock)
 231   (declare (type mutex lock))
 232   (setf (mutex-value lock) nil)
 233   (futex-wake (mutex-value-address lock) 1))
 234
 235
 236 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
 237   (with-unique-names (got)
 238     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
 239       (when ,got
 240         (unwind-protect
 241              (progn ,@body)
 242           (release-mutex ,mutex))))))
 243
 244
 245 ;;;; condition variables
 246
 247 (defun condition-wait (queue lock)
 248   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 249 thread may subsequently notify us using CONDITION-NOTIFY, at which
 250 time we reacquire LOCK and return to the caller."
 251   (assert lock)
 252   (let ((value (mutex-value lock)))
 253     (unwind-protect
 254          (progn
 255            (get-spinlock queue 2 (current-thread-id))
 256            (wait-on-queue queue lock))
 257       ;; If we are interrupted while waiting, we should do these things
 258       ;; before returning.  Ideally, in the case of an unhandled signal,
 259       ;; we should do them before entering the debugger, but this is
 260       ;; better than nothing.
 261       (with-spinlock (queue)
 262         (dequeue queue))
 263       (get-mutex lock value))))
 264
 265 #!+sb-futex
 266 (defun condition-wait/futex (queue lock)
 267   (assert lock)
 268   (let ((value (mutex-value lock)))
 269     (unwind-protect
 270          (let ((me (current-thread-id)))
 271            ;; XXX we should do something to ensure that the result of this setf
 272            ;; is visible to all CPUs
 273            (setf (waitqueue-data queue) me)
 274            (release-mutex lock)
 275            ;; Now we go to sleep using futex-wait.  If anyone else
 276            ;; manages to grab LOCK and call CONDITION-NOTIFY during
 277            ;; this comment, it will change queue->data, and so
 278            ;; futex-wait returns immediately instead of sleeping.
 279            ;; Ergo, no lost wakeup
 280            (futex-wait (waitqueue-data-address queue)
 281                        (sb!kernel:get-lisp-obj-address me)))
 282       ;; If we are interrupted while waiting, we should do these things
 283       ;; before returning.  Ideally, in the case of an unhandled signal,
 284       ;; we should do them before entering the debugger, but this is
 285       ;; better than nothing.
 286       (get-mutex lock value))))
 287
 288
 289 (defun condition-notify (queue)
 290   "Notify one of the processes waiting on QUEUE"
 291   (with-spinlock (queue) (signal-queue-head queue)))
 292
 293 #!+sb-futex
 294 (defun condition-notify/futex (queue)
 295   "Notify one of the processes waiting on QUEUE."
 296   (let ((me (current-thread-id)))
 297     ;; no problem if >1 thread notifies during the comment in
 298     ;; condition-wait: as long as the value in queue-data isn't the
 299     ;; waiting thread's id, it matters not what it is
 300     ;; XXX we should do something to ensure that the result of this setf
 301     ;; is visible to all CPUs
 302     (setf (waitqueue-data queue) me)
 303     (futex-wake (waitqueue-data-address queue) 1)))
 304
 305 #!+sb-futex
 306 (defun condition-broadcast/futex (queue)
 307   (let ((me (current-thread-id)))
 308     (setf (waitqueue-data queue) me)
 309     (futex-wake (waitqueue-data-address queue) (ash 1 30))))
 310
 311 (defun condition-broadcast (queue)
 312   "Notify all of the processes waiting on QUEUE."
 313   (with-spinlock (queue)
 314     (map nil #'signal-thread-to-dequeue (waitqueue-data queue))))
 315
 316 ;;; Futexes may be available at compile time but not runtime, so we
 317 ;;; default to not using them unless os_init says they're available
 318 (defun maybe-install-futex-functions ()
 319   #!+sb-futex
 320   (unless (zerop (extern-alien "linux_supports_futex" int))
 321     (setf (fdefinition 'get-mutex) #'get-mutex/futex
 322           (fdefinition 'release-mutex) #'release-mutex/futex
 323           (fdefinition 'condition-wait) #'condition-wait/futex
 324           (fdefinition 'condition-broadcast) #'condition-broadcast/futex
 325           (fdefinition 'condition-notify) #'condition-notify/futex)
 326     t))
 327
 328 ;;;; job control, independent listeners
 329
 330 (defstruct session
 331   (lock (make-mutex))
 332   (threads nil)
 333   (interactive-threads nil)
 334   (interactive-threads-queue (make-waitqueue)))
 335
 336 (defun new-session ()
 337   (let ((tid (current-thread-id)))
 338     (make-session :threads (list tid)
 339                   :interactive-threads (list tid))))
 340
 341 (defun init-job-control ()
 342   (setf *session* (new-session)))
 343
 344 (defun call-with-new-session (fn)
 345   (let ((tid (current-thread-id)))
 346     (with-mutex ((session-lock *session*))
 347       (setf (session-threads *session*)
 348             (delete tid (session-threads *session*))
 349             (session-interactive-threads *session*)
 350             (delete tid (session-interactive-threads *session*))))
 351     (let ((*session* (new-session)))
 352       (funcall fn))))
 353
 354 (defmacro with-new-session (args &body forms)
 355   (declare (ignore args))               ;for extensibility
 356   (sb!int:with-unique-names (fb-name)
 357     `(labels ((,fb-name () ,@forms))
 358       (call-with-new-session (function ,fb-name)))))
 359
 360 (defun terminate-session ()
 361   "Kill all threads in session exept for this one.  Does nothing if current
 362 thread is not the foreground thread"
 363   (let* ((tid (current-thread-id))
 364          (to-kill
 365           (with-mutex ((session-lock *session*))
 366             (and (eql tid (car (session-interactive-threads *session*)))
 367                  (session-threads *session*)))))
 368     ;; do the kill after dropping the mutex; unwind forms in dying
 369     ;; threads may want to do session things
 370     (dolist (p to-kill)
 371       (unless (eql p tid) (terminate-thread p)))))
 372
 373 ;;; called from top of invoke-debugger
 374 (defun debugger-wait-until-foreground-thread (stream)
 375   "Returns T if thread had been running in background, NIL if it was
 376 interactive."
 377   (prog1
 378       (with-mutex ((session-lock *session*))
 379         (not (member (current-thread-id)
 380                      (session-interactive-threads *session*))))
 381     (get-foreground)))
 382
 383 (defun thread-repl-prompt-fun (out-stream)
 384   (get-foreground)
 385   (let ((stopped-threads (cdr (session-interactive-threads *session*))))
 386     (when stopped-threads
 387       (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
 388     (sb!impl::repl-prompt-fun out-stream)))
 389
 390 (defun get-foreground ()
 391   (loop
 392    (with-mutex ((session-lock *session*))
 393      (let ((tid (current-thread-id)))
 394        (when (eql (car (session-interactive-threads *session*)) tid)
 395          (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
 396          (return-from get-foreground t))
 397        (unless (member tid *interactive-threads*)
 398          (setf (cdr (last (session-interactive-threads *session*)))
 399                (list tid)))
 400        (condition-wait
 401         (session-interactive-threads-queue *session*)
 402         (session-lock *session*))))))
 403
 404 (defun release-foreground (&optional next)
 405   "Background this thread.  If NEXT is supplied, arrange for it to have the foreground next"
 406   (with-mutex ((session-lock *session*))
 407     (let ((tid (current-thread-id)))
 408       (setf (session-interactive-threads *session*)
 409             (delete tid *interactive-threads*))
 410       (sb!sys:enable-interrupt sb!unix:sigint :ignore)
 411       (when next
 412         (setf (session-interactive-threads *session*)
 413               (list* next
 414                      (delete next (session-interactive-threads *session*)))))
 415       (condition-broadcast (session-interactive-threads-queue *session*)))))
 416
 417 (defun make-listener-thread (tty-name)
 418   (assert (probe-file tty-name))
 419   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 420          (out (sb!unix:unix-dup in))
 421          (err (sb!unix:unix-dup in)))
 422     (labels ((thread-repl ()
 423                (sb!unix::unix-setsid)
 424                (let* ((sb!impl::*stdin*
 425                        (sb!sys:make-fd-stream in :input t :buffering :line))
 426                       (sb!impl::*stdout*
 427                        (sb!sys:make-fd-stream out :output t :buffering :line))
 428                       (sb!impl::*stderr*
 429                        (sb!sys:make-fd-stream err :output t :buffering :line))
 430                       (sb!impl::*tty*
 431                        (sb!sys:make-fd-stream err :input t :output t :buffering :line))
 432                       (sb!impl::*descriptor-handlers* nil))
 433                  (with-new-session ()
 434                    (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
 435                    (unwind-protect
 436                         (sb!impl::toplevel-repl nil)
 437                      (sb!int:flush-standard-output-streams))))))
 438       (make-thread #'thread-repl))))