1 (in-package "SB!THREAD")
3 (sb!alien::define-alien-routine ("create_thread" %create-thread)
5 (lisp-fun-address sb!alien:unsigned-long))
7 (defun make-thread (function)
8 (let ((real-function (coerce function 'function)))
10 (sb!kernel:get-lisp-obj-address
12 ;; in time we'll move some of the binding presently done in C
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)
22 (catch 'sb!impl::%end-of-the-world
25 (format nil "~~@<Destroy this thread (~A)~~@:>"
27 (funcall real-function))
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
42 (sb!unix:unix-kill thread-id :sigcont))
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
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)
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))
64 (defun current-thread-id ()
66 (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
68 ;;;; iterate over the in-memory threads
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))))
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)))
84 (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
86 (defmacro with-spinlock ((queue) &body body)
87 (with-unique-names (pid)
89 (let ((,pid (current-thread-id)))
90 (get-spinlock ,queue 2 ,pid)
92 (setf (waitqueue-lock ,queue) 0))))
94 ;;;; the higher-level locking operations are based on waitqueues
97 (name nil :type (or null simple-base-string))
101 (defstruct (mutex (:include waitqueue))
104 (sb!alien:define-alien-routine "block_sigcont" void)
105 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void)
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?
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)))
120 ;;; this should only be called while holding the queue spinlock. It doesn't
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))))))
128 ;;; this should probably only be called while holding the queue spinlock.
130 (defun signal-queue-head (queue)
131 (let ((p (car (waitqueue-data queue))))
132 (when p (sb!unix:unix-kill p :sigcont))))
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)
144 ;; args are object slot-num old-value new-value
145 (sb!vm::%instance-set-conditional lock 4 nil new-value)
147 (setf (waitqueue-lock lock) 0)
150 (setf (waitqueue-lock lock) 0)
152 (wait-on-queue lock nil))))
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)))
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)))
168 (release-mutex ,mutex))))))
171 ;;;; condition variables
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."
178 (let ((value (mutex-value lock)))
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)
189 (get-mutex lock value))))
191 (defun condition-notify (queue)
192 "Notify one of the processes waiting on QUEUE"
193 (with-spinlock (queue) (signal-queue-head queue)))
196 ;;;; multiple independent listeners
198 (defvar *session-lock* nil)
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.
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)))
213 (sb!sys:make-fd-stream in :input t :buffering :line))
215 (sb!sys:make-fd-stream out :output t :buffering :line))
217 (sb!sys:make-fd-stream err :output t :buffering :line))
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)
224 (sb!impl::toplevel-repl nil)
225 (sb!int:flush-standard-output-streams)))))
226 (make-thread #'thread-repl))))
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
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)
245 (funcall wait-p stream (CURRENT-THREAD-ID))))
246 (cond (wait-p (get-foreground))
247 (t (invoke-restart (car (compute-restarts))))))))
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*))
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))))
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)))
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))
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)))
284 (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
285 new-value (,v old-value ,increment))))
287 (defun ,lock-fn (lock timeout)
288 (declare (type rwlock lock))
294 (when (sleep-a-bit timeout) (return nil)) ;expired
296 ;; unlock doesn't need timeout or test-in-range
297 (defun ,unlock-fn (lock)
298 (declare (type rwlock lock))
299 (declare (ignorable limit))
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))))
314 (defun get-rwlock (lock direction &optional timeout)
316 (:read (%lock-for-reading lock timeout))
317 (:write (%lock-for-writing lock timeout))))
319 (defun free-rwlock (lock direction)
321 (:read (%unlock-for-reading lock))
322 (:write (%unlock-for-writing lock))))
324 ;;;; beyond this point all is commented.
326 ;;; Lock-Wait-With-Timeout -- Internal
328 ;;; Wait with a timeout for the lock to be free and acquire it for the
329 ;;; *current-process*.
332 (defun lock-wait-with-timeout (lock whostate timeout)
333 (declare (type lock lock))
334 (process-wait-with-timeout
337 (declare (optimize (speed 3)))
339 (unless (lock-process lock)
340 (setf (lock-process lock) *current-process*))
342 (null (kernel:%instance-set-conditional
343 lock 2 nil *current-process*)))))
345 ;;; With-Lock-Held -- Public
348 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
349 &key (wait t) timeout)
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*)))
361 ,(cond ((and timeout wait)
363 (when (and (error-check-lock-p ,lock) ,have-lock)
366 #+i486 (null (kernel:%instance-set-conditional
367 ,lock 2 nil *current-process*))
368 #-i486 (seize-lock ,lock)
370 (lock-wait-with-timeout
371 ,lock ,whostate ,timeout)
372 (lock-wait ,lock ,whostate)))
376 (when (and (error-check-lock-p ,lock) ,have-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))
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))
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)))))))