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