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