1 ;;;; support for threads in the target machine
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!THREAD")
14 ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
15 ;;; necessary because threads are only supported with the conservative
16 ;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
17 ;;; are treated as references.
19 ;;; set the doc here because in early-thread FDOCUMENTATION is not
22 (setf (sb!kernel:fdocumentation '*current-thread* 'variable)
23 "Bound in each thread to the thread itself.")
25 (defstruct (thread (:constructor %make-thread))
27 "Thread type. Do not rely on threads being structs as it may change
33 (interruptions-lock (make-mutex :name "thread interruptions lock")))
36 (setf (sb!kernel:fdocumentation 'thread-name 'function)
37 "The name of the thread. Setfable.")
39 (def!method print-object ((thread thread) stream)
40 (if (thread-name thread)
41 (print-unreadable-object (thread stream :type t :identity t)
42 (prin1 (thread-name thread) stream))
43 (print-unreadable-object (thread stream :type t :identity t)
44 ;; body is empty => there is only one space between type and
49 (defun thread-alive-p (thread)
51 "Check if THREAD is running."
52 (thread-%alive-p thread))
54 ;; A thread is eligible for gc iff it has finished and there are no
55 ;; more references to it. This list is supposed to keep a reference to
56 ;; all running threads.
57 (defvar *all-threads* ())
58 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
60 (defun list-all-threads ()
62 "Return a list of the live threads."
63 (with-mutex (*all-threads-lock*)
64 (copy-list *all-threads*)))
66 (declaim (inline current-thread-sap))
67 (defun current-thread-sap ()
68 (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
70 (declaim (inline current-thread-sap-id))
71 (defun current-thread-sap-id ()
73 (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
75 (defun init-initial-thread ()
76 (let ((initial-thread (%make-thread :name "initial thread"
78 :os-thread (current-thread-sap-id))))
79 (setq *current-thread* initial-thread)
80 ;; Either *all-threads* is empty or it contains exactly one thread
81 ;; in case we are in reinit since saving core with multiple
82 ;; threads doesn't work.
83 (setq *all-threads* (list initial-thread))))
89 ;; FIXME it would be good to define what a thread id is or isn't
90 ;; (our current assumption is that it's a fixnum). It so happens
91 ;; that on Linux it's a pid, but it might not be on posix thread
93 (define-alien-routine ("create_thread" %create-thread)
94 unsigned-long (lisp-fun-address unsigned-long))
96 (define-alien-routine "signal_interrupt_thread"
97 integer (os-thread unsigned-long))
99 (define-alien-routine "block_blockable_signals"
102 (declaim (inline futex-wait futex-wake))
104 (sb!alien:define-alien-routine "futex_wait"
105 int (word unsigned-long) (old-value unsigned-long))
107 (sb!alien:define-alien-routine "futex_wake"
108 int (word unsigned-long) (n unsigned-long)))
110 ;;; used by debug-int.lisp to access interrupt contexts
111 #!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
113 (defun sb!vm::current-thread-offset-sap (n)
114 (declare (type (unsigned-byte 27) n))
115 (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
116 (* n sb!vm:n-word-bytes)))
123 (name nil :type (or null simple-string))
126 (declaim (inline get-spinlock release-spinlock))
128 ;;; The bare 2 here and below are offsets of the slots in the struct.
129 ;;; There ought to be some better way to get these numbers
130 (defun get-spinlock (spinlock new-value)
131 (declare (optimize (speed 3) (safety 0))
133 (ignore spinlock new-value))
134 ;; %instance-set-conditional can test for 0 (which is a fixnum) and
138 (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
140 (defun release-spinlock (spinlock)
141 (declare (optimize (speed 3) (safety 0))
142 #!-sb-thread (ignore spinlock))
143 ;; %instance-set-conditional cannot compare arbitrary objects
145 ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0)
146 ;; does not work for bignum thread ids.
148 (sb!vm::%instance-set spinlock 2 0))
150 (defmacro with-spinlock ((spinlock) &body body)
151 (sb!int:with-unique-names (lock)
152 `(let ((,lock ,spinlock))
153 (get-spinlock ,lock *current-thread*)
156 (release-spinlock ,lock)))))
163 (name nil :type (or null simple-string))
167 (setf (sb!kernel:fdocumentation 'make-mutex 'function)
169 (sb!kernel:fdocumentation 'mutex-name 'function)
170 "The name of the mutex. Setfable."
171 (sb!kernel:fdocumentation 'mutex-value 'function)
172 "The value of the mutex. NIL if the mutex is free. Setfable.")
175 (declaim (inline mutex-value-address))
177 (defun mutex-value-address (mutex)
178 (declare (optimize (speed 3)))
181 (+ (sb!kernel:get-lisp-obj-address mutex)
182 (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
184 (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
186 "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
187 value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep
188 until it is available"
189 (declare (type mutex mutex) (optimize (speed 3)))
191 (setq new-value *current-thread*))
193 (let ((old-value (mutex-value mutex)))
194 (when (and old-value wait-p)
195 (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
196 new-value ~S, but has already been acquired (with value ~S)."
197 mutex wait-p new-value old-value))
198 (setf (mutex-value mutex) new-value)
202 (when (eql new-value (mutex-value mutex))
203 (warn "recursive lock attempt ~S~%" mutex)
204 (format *debug-io* "Thread: ~A~%" *current-thread*)
205 (sb!debug:backtrace most-positive-fixnum *debug-io*)
206 (force-output *debug-io*))
209 (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
211 (unless wait-p (return nil))
212 (with-pinned-objects (mutex old)
213 (futex-wait (mutex-value-address mutex)
214 (sb!kernel:get-lisp-obj-address old))))))
216 (defun release-mutex (mutex)
218 "Release MUTEX by setting it to NIL. Wake up threads waiting for
220 (declare (type mutex mutex))
221 (setf (mutex-value mutex) nil)
223 (futex-wake (mutex-value-address mutex) 1))
225 ;;;; waitqueues/condition variables
227 (defstruct (waitqueue (:constructor %make-waitqueue))
230 (name nil :type (or null simple-string))
233 (defun make-waitqueue (&key name)
235 "Create a waitqueue."
236 (%make-waitqueue :name name))
239 (setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
240 "The name of the waitqueue. Setfable.")
243 (declaim (inline waitqueue-data-address))
245 (defun waitqueue-data-address (waitqueue)
246 (declare (optimize (speed 3)))
249 (+ (sb!kernel:get-lisp-obj-address waitqueue)
250 (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
252 (defun condition-wait (queue mutex)
254 "Atomically release MUTEX and enqueue ourselves on QUEUE. Another
255 thread may subsequently notify us using CONDITION-NOTIFY, at which
256 time we reacquire MUTEX and return to the caller."
257 #!-sb-thread (declare (ignore queue))
259 #!-sb-thread (error "Not supported in unithread builds.")
261 (let ((value (mutex-value mutex)))
263 (let ((me *current-thread*))
264 ;; XXX we should do something to ensure that the result of this setf
265 ;; is visible to all CPUs
266 (setf (waitqueue-data queue) me)
267 (release-mutex mutex)
268 ;; Now we go to sleep using futex-wait. If anyone else
269 ;; manages to grab MUTEX and call CONDITION-NOTIFY during
270 ;; this comment, it will change queue->data, and so
271 ;; futex-wait returns immediately instead of sleeping.
272 ;; Ergo, no lost wakeup
273 (with-pinned-objects (queue me)
274 (futex-wait (waitqueue-data-address queue)
275 (sb!kernel:get-lisp-obj-address me))))
276 ;; If we are interrupted while waiting, we should do these things
277 ;; before returning. Ideally, in the case of an unhandled signal,
278 ;; we should do them before entering the debugger, but this is
279 ;; better than nothing.
280 (get-mutex mutex value))))
282 (defun condition-notify (queue &optional (n 1))
284 "Notify N threads waiting on QUEUE."
285 #!-sb-thread (declare (ignore queue n))
286 #!-sb-thread (error "Not supported in unithread builds.")
288 (declare (type (and fixnum (integer 1)) n))
290 (let ((me *current-thread*))
291 ;; no problem if >1 thread notifies during the comment in
292 ;; condition-wait: as long as the value in queue-data isn't the
293 ;; waiting thread's id, it matters not what it is
294 ;; XXX we should do something to ensure that the result of this setf
295 ;; is visible to all CPUs
296 (setf (waitqueue-data queue) me)
297 (with-pinned-objects (queue)
298 (futex-wake (waitqueue-data-address queue) n))))
300 (defun condition-broadcast (queue)
302 "Notify all threads waiting on QUEUE."
303 (condition-notify queue most-positive-fixnum))
307 (defstruct (semaphore (:constructor %make-semaphore))
310 (name nil :type (or null simple-string))
311 (count 0 :type (integer 0))
313 (queue (make-waitqueue)))
315 (defun make-semaphore (&key name (count 0))
317 "Create a semaphore with the supplied COUNT."
318 (%make-semaphore :name name :count count))
320 (setf (sb!kernel:fdocumentation 'semaphore-name 'function)
321 "The name of the semaphore. Setfable.")
323 (defun wait-on-semaphore (sem)
325 "Decrement the count of SEM if the count would not be negative. Else
326 block until the semaphore can be decremented."
327 ;; a more direct implementation based directly on futexes should be
329 (with-mutex ((semaphore-mutex sem))
330 (loop until (> (semaphore-count sem) 0)
331 do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
332 finally (decf (semaphore-count sem)))))
334 (defun signal-semaphore (sem &optional (n 1))
336 "Increment the count of SEM by N. If there are threads waiting on
337 this semaphore, then N of them is woken up."
338 (declare (type (and fixnum (integer 1)) n))
339 (with-mutex ((semaphore-mutex sem))
340 (when (= n (incf (semaphore-count sem) n))
341 (condition-notify (semaphore-queue sem) n))))
343 ;;;; job control, independent listeners
346 (lock (make-mutex :name "session lock"))
348 (interactive-threads nil)
349 (interactive-threads-queue (make-waitqueue)))
351 (defvar *session* nil)
353 ;;; the debugger itself tries to acquire the session lock, don't let
354 ;;; funny situations (like getting a sigint while holding the session
356 (defmacro with-session-lock ((session) &body body)
357 #!-sb-thread (declare (ignore session))
362 (with-mutex ((session-lock ,session))
365 (defun new-session ()
366 (make-session :threads (list *current-thread*)
367 :interactive-threads (list *current-thread*)))
369 (defun init-job-control ()
370 (setf *session* (new-session)))
372 (defun %delete-thread-from-session (thread session)
373 (with-session-lock (session)
374 (setf (session-threads session)
375 (delete thread (session-threads session))
376 (session-interactive-threads session)
377 (delete thread (session-interactive-threads session)))))
379 (defun call-with-new-session (fn)
380 (%delete-thread-from-session *current-thread* *session*)
381 (let ((*session* (new-session)))
384 (defmacro with-new-session (args &body forms)
385 (declare (ignore args)) ;for extensibility
386 (sb!int:with-unique-names (fb-name)
387 `(labels ((,fb-name () ,@forms))
388 (call-with-new-session (function ,fb-name)))))
390 ;;; Remove thread from its session, if it has one.
392 (defun handle-thread-exit (thread)
393 (with-mutex (*all-threads-lock*)
394 (setq *all-threads* (delete thread *all-threads*)))
396 (%delete-thread-from-session thread *session*)))
398 (defun terminate-session ()
400 "Kill all threads in session except for this one. Does nothing if current
401 thread is not the foreground thread."
402 ;; FIXME: threads created in other threads may escape termination
404 (with-session-lock (*session*)
405 (and (eq *current-thread*
406 (car (session-interactive-threads *session*)))
407 (session-threads *session*)))))
408 ;; do the kill after dropping the mutex; unwind forms in dying
409 ;; threads may want to do session things
410 (dolist (thread to-kill)
411 (unless (eq thread *current-thread*)
412 ;; terminate the thread but don't be surprised if it has
413 ;; exited in the meantime
414 (handler-case (terminate-thread thread)
415 (interrupt-thread-error ()))))))
417 ;;; called from top of invoke-debugger
418 (defun debugger-wait-until-foreground-thread (stream)
419 "Returns T if thread had been running in background, NIL if it was
421 (declare (ignore stream))
425 (with-session-lock (*session*)
426 (not (member *current-thread*
427 (session-interactive-threads *session*))))
430 (defun get-foreground ()
433 (let ((was-foreground t))
435 (with-session-lock (*session*)
436 (let ((int-t (session-interactive-threads *session*)))
437 (when (eq (car int-t) *current-thread*)
438 (unless was-foreground
439 (format *query-io* "Resuming thread ~A~%" *current-thread*))
440 (return-from get-foreground t))
441 (setf was-foreground nil)
442 (unless (member *current-thread* int-t)
443 (setf (cdr (last int-t))
444 (list *current-thread*)))
446 (session-interactive-threads-queue *session*)
447 (session-lock *session*)))))))
449 (defun release-foreground (&optional next)
451 "Background this thread. If NEXT is supplied, arrange for it to
452 have the foreground next."
453 #!-sb-thread (declare (ignore next))
456 (with-session-lock (*session*)
457 (when (rest (session-interactive-threads *session*))
458 (setf (session-interactive-threads *session*)
459 (delete *current-thread* (session-interactive-threads *session*))))
461 (setf (session-interactive-threads *session*)
463 (delete next (session-interactive-threads *session*)))))
464 (condition-broadcast (session-interactive-threads-queue *session*))))
466 (defun foreground-thread ()
467 (car (session-interactive-threads *session*)))
469 (defun make-listener-thread (tty-name)
470 (assert (probe-file tty-name))
471 (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
472 (out (sb!unix:unix-dup in))
473 (err (sb!unix:unix-dup in)))
474 (labels ((thread-repl ()
475 (sb!unix::unix-setsid)
476 (let* ((sb!impl::*stdin*
477 (make-fd-stream in :input t :buffering :line
480 (make-fd-stream out :output t :buffering :line
483 (make-fd-stream err :output t :buffering :line
486 (make-fd-stream err :input t :output t
489 (sb!impl::*descriptor-handlers* nil))
492 (sb!impl::toplevel-repl nil)
493 (sb!int:flush-standard-output-streams))))))
494 (make-thread #'thread-repl))))
498 (defun make-thread (function &key name)
500 "Create a new thread of NAME that runs FUNCTION. When the function
501 returns the thread exits."
502 #!-sb-thread (declare (ignore function name))
503 #!-sb-thread (error "Not supported in unithread builds.")
505 (let* ((thread (%make-thread :name name))
506 (setup-sem (make-semaphore :name "Thread setup semaphore"))
507 (real-function (coerce function 'function))
510 ;; in time we'll move some of the binding presently done in C
512 (let ((*current-thread* thread)
513 (sb!kernel::*restart-clusters* nil)
514 (sb!kernel::*handler-clusters* nil)
515 (sb!kernel::*condition-restarts* nil)
516 (sb!impl::*descriptor-handlers* nil)) ; serve-event
517 (setf (thread-os-thread thread) (current-thread-sap-id))
518 (with-mutex (*all-threads-lock*)
519 (push thread *all-threads*))
520 (with-session-lock (*session*)
521 (push thread (session-threads *session*)))
522 (setf (thread-%alive-p thread) t)
523 (signal-semaphore setup-sem)
524 ;; can't use handling-end-of-the-world, because that flushes
525 ;; output streams, and we don't necessarily have any (or we
526 ;; could be sharing them)
527 (catch 'sb!impl::toplevel-catcher
528 (catch 'sb!impl::%end-of-the-world
532 "~~@<Terminate this thread (~A)~~@:>"
536 ;; now that most things have a chance to
537 ;; work properly without messing up other
538 ;; threads, it's time to enable signals
539 (sb!unix::reset-signal-mask)
540 (funcall real-function))
541 ;; we're going down, can't handle
542 ;; interrupts sanely anymore
543 (let ((sb!impl::*gc-inhibit* t))
544 (block-blockable-signals)
545 (setf (thread-%alive-p thread) nil)
546 (setf (thread-os-thread thread) nil)
547 ;; and remove what can be the last
548 ;; reference to this thread
549 (handle-thread-exit thread)))))))
551 ;; Keep INITIAL-FUNCTION pinned until the child thread is
552 ;; initialized properly.
553 (with-pinned-objects (initial-function)
556 (sb!kernel:get-lisp-obj-address initial-function))))
557 (when (zerop os-thread)
558 (error "Can't create a new thread"))
559 (wait-on-semaphore setup-sem)
562 (defun destroy-thread (thread)
564 "Deprecated. Same as TERMINATE-THREAD."
565 (terminate-thread thread))
567 (define-condition interrupt-thread-error (error)
568 ((thread :reader interrupt-thread-error-thread :initarg :thread))
570 (:documentation "Interrupting thread failed.")
571 (:report (lambda (c s)
572 (format s "Interrupt thread failed: thread ~A has exited."
573 (interrupt-thread-error-thread c)))))
576 (setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
577 "The thread that was not interrupted.")
579 (defmacro with-interruptions-lock ((thread) &body body)
581 (with-mutex ((thread-interruptions-lock ,thread))
584 ;; Called from the signal handler.
585 (defun run-interruption ()
587 (let ((interruption (with-interruptions-lock (*current-thread*)
588 (pop (thread-interruptions *current-thread*)))))
590 (funcall interruption)))))
592 ;; The order of interrupt execution is peculiar. If thread A
593 ;; interrupts thread B with I1, I2 and B for some reason receives I1
594 ;; when FUN2 is already on the list, then it is FUN2 that gets to run
595 ;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
596 ;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
597 ;; just one scenario, and the order of thread interrupt execution is
599 (defun interrupt-thread (thread function)
601 "Interrupt the live THREAD and make it run FUNCTION. A moderate
602 degree of care is expected for use of INTERRUPT-THREAD, due to its
603 nature: if you interrupt a thread that was holding important locks
604 then do something that turns out to need those locks, you probably
605 won't like the effect."
606 #!-sb-thread (declare (ignore thread))
607 ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
612 (if (eq thread *current-thread*)
614 (let ((os-thread (thread-os-thread thread)))
615 (cond ((not os-thread)
616 (error 'interrupt-thread-error :thread thread))
618 (with-interruptions-lock (thread)
619 (push function (thread-interruptions thread)))
620 (when (minusp (signal-interrupt-thread os-thread))
621 (error 'interrupt-thread-error :thread thread)))))))
623 (defun terminate-thread (thread)
625 "Terminate the thread identified by THREAD, by causing it to run
626 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
627 (interrupt-thread thread 'sb!ext:quit))
629 ;;; internal use only. If you think you need to use this, either you
630 ;;; are an SBCL developer, are doing something that you should discuss
631 ;;; with an SBCL developer first, or are doing something that you
632 ;;; should probably discuss with a professional psychiatrist first
634 (defun thread-sap-for-id (id)
635 (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
637 (when (sap= thread-sap (int-sap 0)) (return nil))
638 (let ((os-thread (sap-ref-word thread-sap
639 (* sb!vm:n-word-bytes
640 sb!vm::thread-os-thread-slot))))
641 (when (= os-thread id) (return thread-sap))
643 (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
644 sb!vm::thread-next-slot)))))))
647 (defun symbol-value-in-thread (symbol thread-sap)
648 (let* ((index (sb!vm::symbol-tls-index symbol))
649 (tl-val (sap-ref-word thread-sap
650 (* sb!vm:n-word-bytes index))))
651 (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
652 (sb!vm::symbol-global-value symbol)
653 (sb!kernel:make-lisp-obj tl-val))))