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