src/code/target-thread.lisp

   1 (in-package "SB!THREAD")
   2
   3 (sb!alien::define-alien-routine ("create_thread" %create-thread)
   4      sb!alien:unsigned-long
   5   (lisp-fun-address sb!alien:unsigned-long))
   6
   7 (defun make-thread (function)
   8   (let ((real-function (coerce function 'function)))
   9     (%create-thread
  10      (sb!kernel:get-lisp-obj-address
  11       (lambda ()
  12         ;; in time we'll move some of the binding presently done in C
  13         ;; here too
  14         (let ((sb!kernel::*restart-clusters* nil)
  15               (sb!impl::*descriptor-handlers* nil); serve-event
  16               (sb!impl::*available-buffers* nil)) ;for fd-stream
  17           ;; can't use handling-end-of-the-world, because that flushes
  18           ;; output streams, and we don't necessarily have any (or we
  19           ;; could be sharing them)
  20           (sb!sys:enable-interrupt sb!unix:sigint :ignore)
  21           (sb!unix:unix-exit
  22            (catch 'sb!impl::%end-of-the-world
  23              (with-simple-restart
  24                  (destroy-thread
  25                   (format nil "~~@<Destroy this thread (~A)~~@:>"
  26                           (current-thread-id)))
  27                (funcall real-function))
  28              0))))))))
  29
  30 ;;; Really, you don't want to use these: they'll get into trouble with
  31 ;;; garbage collection.  Use a lock or a waitqueue instead
  32 (defun suspend-thread (thread-id)
  33   (sb!unix:unix-kill thread-id sb!unix:sigstop))
  34 (defun resume-thread (thread-id)
  35   (sb!unix:unix-kill thread-id sb!unix:sigcont))
  36 ;;; Note warning about cleanup forms
  37 (defun destroy-thread (thread-id)
  38   "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
  39   (sb!unix:unix-kill thread-id sb!unix:sigterm)
  40   ;; may have been stopped for some reason, so now wake it up to
  41   ;; deliver the TERM
  42   (sb!unix:unix-kill thread-id sb!unix:sigcont))
  43
  44
  45 ;;; a moderate degree of care is expected for use of interrupt-thread,
  46 ;;; due to its nature: if you interrupt a thread that was holding
  47 ;;; important locks then do something that turns out to need those
  48 ;;; locks, you probably won't like the effect.  Used with thought
  49 ;;; though, it's a good deal gentler than the last-resort functions above
  50
  51 (defun interrupt-thread (thread function)
  52   "Interrupt THREAD and make it run FUNCTION.  "
  53   (sb!unix::syscall* ("interrupt_thread"
  54                       sb!alien:unsigned-long  sb!alien:unsigned-long)
  55                      thread
  56                      thread (sb!kernel:get-lisp-obj-address
  57                              (coerce function 'function))))
  58 (defun terminate-thread (thread-id)
  59   "Terminate the thread identified by THREAD-ID, by causing it to run
  60 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
  61   (interrupt-thread thread-id 'sb!ext:quit))
  62
  63 (declaim (inline current-thread-id))
  64 (defun current-thread-id ()
  65   (logand
  66    (sb!sys:sap-int
  67     (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
  68    ;; KLUDGE pids are 16 bit really.  Avoid boxing the return value
  69    (1- (ash 1 16))))
  70
  71 ;;;; iterate over the in-memory threads
  72
  73 (defun mapcar-threads (function)
  74   "Call FUNCTION once for each known thread, giving it the thread structure as argument"
  75   (let ((function (coerce function 'function)))
  76     (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
  77           then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
  78           until (sb!sys:sap= thread (sb!sys:int-sap 0))
  79           collect (funcall function thread))))
  80
  81 ;;;; queues, locks
  82
  83 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  84 (declaim (inline get-spinlock release-spinlock))
  85
  86 (defun get-spinlock (lock offset new-value)
  87   (declare (optimize (speed 3) (safety 0)))
  88   (loop until
  89         (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
  90
  91 ;; this should do nothing if we didn't own the lock, so safe to use in
  92 ;; unwind-protect cleanups when lock acquisition failed for some reason
  93 (defun release-spinlock (lock offset our-value)
  94   (declare (optimize (speed 3) (safety 0)))
  95   (sb!vm::%instance-set-conditional lock offset our-value 0))
  96
  97 (defmacro with-spinlock ((queue) &body body)
  98   (with-unique-names (pid)
  99     `(let ((,pid (current-thread-id)))
 100        (unwind-protect
 101             (progn
 102               (get-spinlock ,queue 2 ,pid)
 103               ,@body)
 104          (release-spinlock ,queue 2 ,pid)))))
 105
 106
 107 ;;;; the higher-level locking operations are based on waitqueues
 108
 109 (defstruct waitqueue
 110   (name nil :type (or null simple-base-string))
 111   (lock 0)
 112   (data nil))
 113
 114 (defstruct (mutex (:include waitqueue))
 115   (value nil))
 116
 117 (sb!alien:define-alien-routine "block_sigcont"  void)
 118 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
 119
 120
 121 ;;; this should only be called while holding the queue spinlock.
 122 ;;; it releases the spinlock before sleeping
 123 (defun wait-on-queue (queue &optional lock)
 124   (let ((pid (current-thread-id)))
 125     (block-sigcont)
 126     (when lock (release-mutex lock))
 127     (sb!sys:without-interrupts
 128      (pushnew pid (waitqueue-data queue)))
 129     (setf (waitqueue-lock queue) 0)
 130     (unblock-sigcont-and-sleep)))
 131
 132 ;;; this should only be called while holding the queue spinlock.  It doesn't
 133 ;;; release it
 134 (defun dequeue (queue)
 135   (let ((pid (current-thread-id)))
 136     (sb!sys:without-interrupts
 137      (setf (waitqueue-data queue)
 138            (delete pid (waitqueue-data queue))))))
 139
 140 ;;; this should only be called while holding the queue spinlock.
 141 (defun signal-queue-head (queue)
 142   (let ((p (car (waitqueue-data queue))))
 143     (when p (sb!unix:unix-kill p  sb!unix::sig-dequeue))))
 144
 145 ;;;; mutex
 146
 147 (defun get-mutex (lock &optional new-value (wait-p t))
 148   (declare (type mutex lock)
 149            (optimize (speed 3)))
 150   (let ((pid (current-thread-id)))
 151     (unless new-value (setf new-value pid))
 152     (assert (not (eql new-value (mutex-value lock))))
 153     (get-spinlock lock 2 pid)
 154     (loop
 155      (unless
 156          ;; args are object slot-num old-value new-value
 157          (sb!vm::%instance-set-conditional lock 4 nil new-value)
 158        (dequeue lock)
 159        (setf (waitqueue-lock lock) 0)
 160        (return t))
 161      (unless wait-p
 162        (setf (waitqueue-lock lock) 0)
 163        (return nil))
 164      (wait-on-queue lock nil))))
 165
 166 (defun release-mutex (lock &optional (new-value nil))
 167   (declare (type mutex lock))
 168   ;; we assume the lock is ours to release
 169   (with-spinlock (lock)
 170     (setf (mutex-value lock) new-value)
 171     (signal-queue-head lock)))
 172
 173
 174 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
 175   (with-unique-names (got)
 176     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
 177       (when ,got
 178         (unwind-protect
 179              (progn ,@body)
 180           (release-mutex ,mutex))))))
 181
 182
 183 ;;;; condition variables
 184
 185 (defun condition-wait (queue lock)
 186   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 187 thread may subsequently notify us using CONDITION-NOTIFY, at which
 188 time we reacquire LOCK and return to the caller."
 189   (assert lock)
 190   (let ((value (mutex-value lock)))
 191     (unwind-protect
 192          (progn
 193            (get-spinlock queue 2 (current-thread-id))
 194            (wait-on-queue queue lock))
 195       ;; If we are interrupted while waiting, we should do these things
 196       ;; before returning.  Ideally, in the case of an unhandled signal,
 197       ;; we should do them before entering the debugger, but this is
 198       ;; better than nothing.
 199       (with-spinlock (queue)
 200         (dequeue queue))
 201       (get-mutex lock value))))
 202
 203 (defun condition-notify (queue)
 204   "Notify one of the processes waiting on QUEUE"
 205   (with-spinlock (queue) (signal-queue-head queue)))
 206
 207
 208 ;;;; multiple independent listeners
 209
 210 (defvar *session-lock* nil)
 211
 212 (defun make-listener-thread (tty-name)
 213   (assert (probe-file tty-name))
 214   ;; FIXME probably still need to do some tty stuff to get signals
 215   ;; delivered correctly.
 216   ;; FIXME
 217   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 218          (out (sb!unix:unix-dup in))
 219          (err (sb!unix:unix-dup in)))
 220     (labels ((thread-repl ()
 221                (sb!unix::unix-setsid)
 222                (let* ((*session-lock*
 223                        (make-mutex :name (format nil "lock for ~A" tty-name)))
 224                       (sb!impl::*stdin*
 225                        (sb!sys:make-fd-stream in :input t :buffering :line))
 226                       (sb!impl::*stdout*
 227                        (sb!sys:make-fd-stream out :output t :buffering :line))
 228                       (sb!impl::*stderr*
 229                        (sb!sys:make-fd-stream err :output t :buffering :line))
 230                       (sb!impl::*tty*
 231                        (sb!sys:make-fd-stream err :input t :output t :buffering :line))
 232                       (sb!impl::*descriptor-handlers* nil))
 233                  (get-mutex *session-lock*)
 234                  (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
 235                  (unwind-protect
 236                       (sb!impl::toplevel-repl nil)
 237                    (sb!int:flush-standard-output-streams)))))
 238       (make-thread #'thread-repl))))
 239
 240 ;;;; job control
 241
 242 (defvar *background-threads-wait-for-debugger* t)
 243 ;;; may be T, NIL, or a function called with a stream and thread id
 244 ;;; as its two arguments, returning NIl or T
 245
 246 ;;; called from top of invoke-debugger
 247 (defun debugger-wait-until-foreground-thread (stream)
 248   "Returns T if thread had been running in background, NIL if it was
 249 already the foreground thread, or transfers control to the first applicable
 250 restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
 251   (let* ((wait-p *background-threads-wait-for-debugger*)
 252          (*background-threads-wait-for-debugger* nil)
 253          (lock *session-lock*))
 254     (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
 255       (when (functionp wait-p)
 256         (setf wait-p
 257               (funcall wait-p stream (CURRENT-THREAD-ID))))
 258       (cond (wait-p (get-foreground))
 259             (t  (invoke-restart (car (compute-restarts))))))))
 260
 261 ;;; install this with
 262 ;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
 263 ;;; One day it will be default
 264 (defun thread-repl-prompt-fun (out-stream)
 265   (let ((lock *session-lock*))
 266     (get-foreground)
 267     (let ((stopped-threads (waitqueue-data lock)))
 268       (when stopped-threads
 269         (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
 270       (sb!impl::repl-prompt-fun out-stream))))
 271
 272 (defun resume-stopped-thread (id)
 273   (let ((lock *session-lock*))
 274     (with-spinlock (lock)
 275       (setf (waitqueue-data lock)
 276             (cons id (delete id  (waitqueue-data lock)))))
 277     (release-foreground)))
 278
 279 (defstruct rwlock
 280   (name nil :type (or null simple-base-string))
 281   (value 0 :type fixnum)
 282   (max-readers nil :type (or fixnum null))
 283   (max-writers 1 :type fixnum))
 284 #+nil
 285 (macrolet
 286     ((make-rwlocking-function (lock-fn unlock-fn increment limit test)
 287        (let ((do-update '(when (eql old-value
 288                                 (sb!vm::%instance-set-conditional
 289                                  lock 2 old-value new-value))
 290                           (return (values t old-value))))
 291              (vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
 292                      old-value
 293                      new-value
 294                      (limit ,limit))))
 295          (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
 296                                   new-value (,v old-value ,increment))))
 297            `(progn
 298              (defun ,lock-fn (lock timeout)
 299                (declare (type rwlock lock))
 300                (let ,vars
 301                  (loop
 302                   ,(do-setfs '+)
 303                   (when ,test
 304                     ,do-update)
 305                   (when (sleep-a-bit timeout) (return nil)) ;expired
 306                   )))
 307              ;; unlock doesn't need timeout or test-in-range
 308              (defun ,unlock-fn (lock)
 309                (declare (type rwlock lock))
 310                (declare (ignorable limit))
 311                (let ,(cdr vars)
 312                  (loop
 313                   ,(do-setfs '-)
 314                   ,do-update))))))))
 315
 316   (make-rwlocking-function %lock-for-reading %unlock-for-reading 1
 317                            (rwlock-max-readers lock)
 318                            (and (>= old-value 0)
 319                                 (or (null limit) (<= new-value limit))))
 320   (make-rwlocking-function %lock-for-writing %unlock-for-writing -1
 321                            (- (rwlock-max-writers lock))
 322                            (and (<= old-value 0)
 323                                 (>= new-value limit))))
 324 #+nil
 325 (defun get-rwlock (lock direction &optional timeout)
 326   (ecase direction
 327     (:read (%lock-for-reading lock timeout))
 328     (:write (%lock-for-writing lock timeout))))
 329 #+nil
 330 (defun free-rwlock (lock direction)
 331   (ecase direction
 332     (:read (%unlock-for-reading lock))
 333     (:write (%unlock-for-writing lock))))
 334
 335 ;;;; beyond this point all is commented.
 336
 337 ;;; Lock-Wait-With-Timeout  --  Internal
 338 ;;;
 339 ;;; Wait with a timeout for the lock to be free and acquire it for the
 340 ;;; *current-process*.
 341 ;;;
 342 #+nil
 343 (defun lock-wait-with-timeout (lock whostate timeout)
 344   (declare (type lock lock))
 345   (process-wait-with-timeout
 346    whostate timeout
 347    #'(lambda ()
 348        (declare (optimize (speed 3)))
 349        #-i486
 350        (unless (lock-process lock)
 351          (setf (lock-process lock) *current-process*))
 352        #+i486
 353        (null (kernel:%instance-set-conditional
 354               lock 2 nil *current-process*)))))
 355
 356 ;;; With-Lock-Held  --  Public
 357 ;;;
 358 #+nil
 359 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
 360                                 &key (wait t) timeout)
 361                           &body body)
 362   "Execute the body with the lock held. If the lock is held by another
 363   process then the current process waits until the lock is released or
 364   an optional timeout is reached. The optional wait timeout is a time in
 365   seconds acceptable to process-wait-with-timeout.  The results of the
 366   body are return upon success and NIL is return if the timeout is
 367   reached. When the wait key is NIL and the lock is held by another
 368   process then NIL is return immediately without processing the body."
 369   (let ((have-lock (gensym)))
 370     `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
 371       (unwind-protect
 372            ,(cond ((and timeout wait)
 373                    `(progn
 374                       (when (and (error-check-lock-p ,lock) ,have-lock)
 375                         (error "Dead lock"))
 376                       (when (or ,have-lock
 377                                  #+i486 (null (kernel:%instance-set-conditional
 378                                                ,lock 2 nil *current-process*))
 379                                  #-i486 (seize-lock ,lock)
 380                                  (if ,timeout
 381                                      (lock-wait-with-timeout
 382                                       ,lock ,whostate ,timeout)
 383                                      (lock-wait ,lock ,whostate)))
 384                         ,@body)))
 385                   (wait
 386                    `(progn
 387                       (when (and (error-check-lock-p ,lock) ,have-lock)
 388                         (error "Dead lock"))
 389                       (unless (or ,have-lock
 390                                  #+i486 (null (kernel:%instance-set-conditional
 391                                                ,lock 2 nil *current-process*))
 392                                  #-i486 (seize-lock ,lock))
 393                         (lock-wait ,lock ,whostate))
 394                       ,@body))
 395                   (t
 396                    `(when (or (and (recursive-lock-p ,lock) ,have-lock)
 397                               #+i486 (null (kernel:%instance-set-conditional
 398                                             ,lock 2 nil *current-process*))
 399                               #-i486 (seize-lock ,lock))
 400                       ,@body)))
 401         (unless ,have-lock
 402           #+i486 (kernel:%instance-set-conditional
 403                   ,lock 2 *current-process* nil)
 404           #-i486 (when (eq (lock-process ,lock) *current-process*)
 405                    (setf (lock-process ,lock) nil)))))))
 406
 407
 408