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 :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 ;;; Conventional wisdom says that it's a bad idea to use these unless
  31 ;;; you really need to.  Use a lock or a waitqueue instead
  32 (defun suspend-thread (thread-id)
  33   (sb!unix:unix-kill thread-id :sigstop))
  34 (defun resume-thread (thread-id)
  35   (sb!unix:unix-kill thread-id :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 :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 :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
  64 (defun current-thread-id ()
  65   (sb!sys:sap-int
  66    (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
  67
  68 ;;;; iterate over the in-memory threads
  69
  70 (defun mapcar-threads (function)
  71   "Call FUNCTION once for each known thread, giving it the thread structure as argument"
  72   (let ((function (coerce function 'function)))
  73     (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
  74           then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
  75           until (sb!sys:sap= thread (sb!sys:int-sap 0))
  76           collect (funcall function thread))))
  77
  78 ;;;; queues, locks
  79
  80 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  81 (defun get-spinlock (lock offset new-value)
  82   (declare (optimize (speed 3) (safety 0)))
  83   (loop until
  84         (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
  85
  86 (defmacro with-spinlock ((queue) &body body)
  87   (with-unique-names (pid)
  88     `(unwind-protect
  89       (let ((,pid (current-thread-id)))
  90         (get-spinlock ,queue 2 ,pid)
  91         ,@body)
  92       (setf (waitqueue-lock ,queue) 0))))
  93
  94 ;;;; the higher-level locking operations are based on waitqueues
  95
  96 (defstruct waitqueue
  97   (name nil :type (or null simple-base-string))
  98   (lock 0)
  99   (data nil))
 100
 101 (defstruct (mutex (:include waitqueue))
 102   (value nil))
 103
 104 (sb!alien:define-alien-routine "block_sigcont"  void)
 105 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
 106
 107 ;;; this should only be called while holding the queue spinlock.
 108 ;;; it releases the spinlock before sleeping
 109 (defun wait-on-queue (queue &optional lock)
 110   (let ((pid (current-thread-id)))
 111     ;; FIXME what should happen if we get interrupted when we've blocked
 112     ;; the sigcont?  For that matter, can we get interrupted?
 113     (block-sigcont)
 114     (when lock (release-mutex lock))
 115     (sb!sys:without-interrupts
 116      (pushnew pid (waitqueue-data queue)))
 117     (setf (waitqueue-lock queue) 0)
 118     (unblock-sigcont-and-sleep)))
 119
 120 ;;; this should only be called while holding the queue spinlock.  It doesn't
 121 ;;; release it
 122 (defun dequeue (queue)
 123   (let ((pid (current-thread-id)))
 124     (sb!sys:without-interrupts
 125      (setf (waitqueue-data queue)
 126            (delete pid (waitqueue-data queue))))))
 127
 128 ;;; this should probably only be called while holding the queue spinlock.
 129 ;;; not sure
 130 (defun signal-queue-head (queue)
 131   (let ((p (car (waitqueue-data queue))))
 132     (when p (sb!unix:unix-kill p  :sigcont))))
 133
 134 ;;;; mutex
 135
 136 (defun get-mutex (lock &optional new-value (wait-p t))
 137   (declare (type mutex lock))
 138   (let ((pid (current-thread-id)))
 139     (unless new-value (setf new-value pid))
 140     (assert (not (eql new-value (mutex-value lock))))
 141     (get-spinlock lock 2 pid)
 142     (loop
 143      (unless
 144          ;; args are object slot-num old-value new-value
 145          (sb!vm::%instance-set-conditional lock 4 nil new-value)
 146        (dequeue lock)
 147        (setf (waitqueue-lock lock) 0)
 148        (return t))
 149      (unless wait-p
 150        (setf (waitqueue-lock lock) 0)
 151        (return nil))
 152      (wait-on-queue lock nil))))
 153
 154 (defun release-mutex (lock &optional (new-value nil))
 155   (declare (type mutex lock))
 156   ;; we assume the lock is ours to release
 157   (with-spinlock (lock)
 158     (setf (mutex-value lock) new-value)
 159     (signal-queue-head lock)))
 160
 161
 162 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
 163   (with-unique-names (got)
 164     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
 165       (when ,got
 166         (unwind-protect
 167              (progn ,@body)
 168           (release-mutex ,mutex))))))
 169
 170
 171 ;;;; condition variables
 172
 173 (defun condition-wait (queue lock)
 174   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 175 thread may subsequently notify us using CONDITION-NOTIFY, at which
 176 time we reacquire LOCK and return to the caller."
 177   (assert lock)
 178   (let ((value (mutex-value lock)))
 179     (unwind-protect
 180          (progn
 181            (get-spinlock queue 2 (current-thread-id))
 182            (wait-on-queue queue lock))
 183       ;; If we are interrupted while waiting, we should do these things
 184       ;; before returning.  Ideally, in the case of an unhandled signal,
 185       ;; we should do them before entering the debugger, but this is
 186       ;; better than nothing.
 187       (with-spinlock (queue)
 188         (dequeue queue))
 189       (get-mutex lock value))))
 190
 191 (defun condition-notify (queue)
 192   "Notify one of the processes waiting on QUEUE"
 193   (with-spinlock (queue) (signal-queue-head queue)))
 194
 195
 196 ;;;; multiple independent listeners
 197
 198 (defvar *session-lock* nil)
 199
 200 (defun make-listener-thread (tty-name)
 201   (assert (probe-file tty-name))
 202   ;; FIXME probably still need to do some tty stuff to get signals
 203   ;; delivered correctly.
 204   ;; FIXME
 205   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
 206          (out (sb!unix:unix-dup in))
 207          (err (sb!unix:unix-dup in)))
 208     (labels ((thread-repl ()
 209                (sb!unix::unix-setsid)
 210                (let* ((*session-lock*
 211                        (make-mutex :name (format nil "lock for ~A" tty-name)))
 212                       (sb!impl::*stdin*
 213                        (sb!sys:make-fd-stream in :input t :buffering :line))
 214                       (sb!impl::*stdout*
 215                        (sb!sys:make-fd-stream out :output t :buffering :line))
 216                       (sb!impl::*stderr*
 217                        (sb!sys:make-fd-stream err :output t :buffering :line))
 218                       (sb!impl::*tty*
 219                        (sb!sys:make-fd-stream err :input t :output t :buffering :line))
 220                       (sb!impl::*descriptor-handlers* nil))
 221                  (get-mutex *session-lock*)
 222                  (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
 223                  (unwind-protect
 224                       (sb!impl::toplevel-repl nil)
 225                    (sb!int:flush-standard-output-streams)))))
 226       (make-thread #'thread-repl))))
 227
 228 ;;;; job control
 229
 230 (defvar *background-threads-wait-for-debugger* t)
 231 ;;; may be T, NIL, or a function called with a stream and thread id
 232 ;;; as its two arguments, returning NIl or T
 233
 234 ;;; called from top of invoke-debugger
 235 (defun debugger-wait-until-foreground-thread (stream)
 236   "Returns T if thread had been running in background, NIL if it was
 237 already the foreground thread, or transfers control to the first applicable
 238 restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
 239   (let* ((wait-p *background-threads-wait-for-debugger*)
 240          (*background-threads-wait-for-debugger* nil)
 241          (lock *session-lock*))
 242     (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
 243       (when (functionp wait-p)
 244         (setf wait-p
 245               (funcall wait-p stream (CURRENT-THREAD-ID))))
 246       (cond (wait-p (get-foreground))
 247             (t  (invoke-restart (car (compute-restarts))))))))
 248
 249 ;;; install this with
 250 ;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
 251 ;;; One day it will be default
 252 (defun thread-repl-prompt-fun (out-stream)
 253   (let ((lock *session-lock*))
 254     (get-foreground)
 255     (let ((stopped-threads (waitqueue-data lock)))
 256       (when stopped-threads
 257         (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
 258       (sb!impl::repl-prompt-fun out-stream))))
 259
 260 (defun resume-stopped-thread (id)
 261   (let ((pid (current-thread-id))
 262         (lock *session-lock*))
 263     (with-spinlock (lock)
 264       (setf (waitqueue-data lock)
 265             (cons id (delete id  (waitqueue-data lock)))))
 266     (release-foreground)))
 267
 268 (defstruct rwlock
 269   (name nil :type (or null simple-base-string))
 270   (value 0 :type fixnum)
 271   (max-readers nil :type (or fixnum null))
 272   (max-writers 1 :type fixnum))
 273 #+nil
 274 (macrolet
 275     ((make-rwlocking-function (lock-fn unlock-fn increment limit test)
 276        (let ((do-update '(when (eql old-value
 277                                 (sb!vm::%instance-set-conditional
 278                                  lock 2 old-value new-value))
 279                           (return (values t old-value))))
 280              (vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
 281                      old-value
 282                      new-value
 283                      (limit ,limit))))
 284          (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
 285                                   new-value (,v old-value ,increment))))
 286            `(progn
 287              (defun ,lock-fn (lock timeout)
 288                (declare (type rwlock lock))
 289                (let ,vars
 290                  (loop
 291                   ,(do-setfs '+)
 292                   (when ,test
 293                     ,do-update)
 294                   (when (sleep-a-bit timeout) (return nil)) ;expired
 295                   )))
 296              ;; unlock doesn't need timeout or test-in-range
 297              (defun ,unlock-fn (lock)
 298                (declare (type rwlock lock))
 299                (declare (ignorable limit))
 300                (let ,(cdr vars)
 301                  (loop
 302                   ,(do-setfs '-)
 303                   ,do-update))))))))
 304
 305   (make-rwlocking-function %lock-for-reading %unlock-for-reading 1
 306                            (rwlock-max-readers lock)
 307                            (and (>= old-value 0)
 308                                 (or (null limit) (<= new-value limit))))
 309   (make-rwlocking-function %lock-for-writing %unlock-for-writing -1
 310                            (- (rwlock-max-writers lock))
 311                            (and (<= old-value 0)
 312                                 (>= new-value limit))))
 313 #+nil
 314 (defun get-rwlock (lock direction &optional timeout)
 315   (ecase direction
 316     (:read (%lock-for-reading lock timeout))
 317     (:write (%lock-for-writing lock timeout))))
 318 #+nil
 319 (defun free-rwlock (lock direction)
 320   (ecase direction
 321     (:read (%unlock-for-reading lock))
 322     (:write (%unlock-for-writing lock))))
 323
 324 ;;;; beyond this point all is commented.
 325
 326 ;;; Lock-Wait-With-Timeout  --  Internal
 327 ;;;
 328 ;;; Wait with a timeout for the lock to be free and acquire it for the
 329 ;;; *current-process*.
 330 ;;;
 331 #+nil
 332 (defun lock-wait-with-timeout (lock whostate timeout)
 333   (declare (type lock lock))
 334   (process-wait-with-timeout
 335    whostate timeout
 336    #'(lambda ()
 337        (declare (optimize (speed 3)))
 338        #-i486
 339        (unless (lock-process lock)
 340          (setf (lock-process lock) *current-process*))
 341        #+i486
 342        (null (kernel:%instance-set-conditional
 343               lock 2 nil *current-process*)))))
 344
 345 ;;; With-Lock-Held  --  Public
 346 ;;;
 347 #+nil
 348 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
 349                                 &key (wait t) timeout)
 350                           &body body)
 351   "Execute the body with the lock held. If the lock is held by another
 352   process then the current process waits until the lock is released or
 353   an optional timeout is reached. The optional wait timeout is a time in
 354   seconds acceptable to process-wait-with-timeout.  The results of the
 355   body are return upon success and NIL is return if the timeout is
 356   reached. When the wait key is NIL and the lock is held by another
 357   process then NIL is return immediately without processing the body."
 358   (let ((have-lock (gensym)))
 359     `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
 360       (unwind-protect
 361            ,(cond ((and timeout wait)
 362                    `(progn
 363                       (when (and (error-check-lock-p ,lock) ,have-lock)
 364                         (error "Dead lock"))
 365                       (when (or ,have-lock
 366                                  #+i486 (null (kernel:%instance-set-conditional
 367                                                ,lock 2 nil *current-process*))
 368                                  #-i486 (seize-lock ,lock)
 369                                  (if ,timeout
 370                                      (lock-wait-with-timeout
 371                                       ,lock ,whostate ,timeout)
 372                                      (lock-wait ,lock ,whostate)))
 373                         ,@body)))
 374                   (wait
 375                    `(progn
 376                       (when (and (error-check-lock-p ,lock) ,have-lock)
 377                         (error "Dead lock"))
 378                       (unless (or ,have-lock
 379                                  #+i486 (null (kernel:%instance-set-conditional
 380                                                ,lock 2 nil *current-process*))
 381                                  #-i486 (seize-lock ,lock))
 382                         (lock-wait ,lock ,whostate))
 383                       ,@body))
 384                   (t
 385                    `(when (or (and (recursive-lock-p ,lock) ,have-lock)
 386                               #+i486 (null (kernel:%instance-set-conditional
 387                                             ,lock 2 nil *current-process*))
 388                               #-i486 (seize-lock ,lock))
 389                       ,@body)))
 390         (unless ,have-lock
 391           #+i486 (kernel:%instance-set-conditional
 392                   ,lock 2 *current-process* nil)
 393           #-i486 (when (eq (lock-process ,lock) *current-process*)
 394                    (setf (lock-process ,lock) nil)))))))
 395
 396
 397