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 ;;; set the doc here because in early-thread FDOCUMENTATION is not
17 (setf (sb!kernel
:fdocumentation
'*current-thread
* 'variable
)
18 "Bound in each thread to the thread itself.")
20 (defstruct (thread (:constructor %make-thread
))
22 "Thread type. Do not rely on threads being structs as it may change
28 (setf (sb!kernel
:fdocumentation
'thread-name
'function
)
29 "The name of the thread. Setfable.")
31 (def!method print-object
((thread thread
) stream
)
32 (if (thread-name thread
)
33 (print-unreadable-object (thread stream
:type t
:identity t
)
34 (prin1 (thread-name thread
) stream
))
35 (print-unreadable-object (thread stream
:type t
:identity t
)
36 ;; body is empty => there is only one space between type and
41 (defun thread-state (thread)
44 (sb!sys
:sap-ref-sap
(thread-%sap thread
)
45 (* sb
!vm
::thread-state-slot
46 sb
!vm
::n-word-bytes
)))))
48 (#.
(sb!vm
:fixnumize
0) :starting
)
49 (#.
(sb!vm
:fixnumize
1) :running
)
50 (#.
(sb!vm
:fixnumize
2) :suspended
)
51 (#.
(sb!vm
:fixnumize
3) :dead
))))
53 (defun thread-alive-p (thread)
55 "Check if THREAD is running."
56 (not (eq :dead
(thread-state thread
))))
58 ;; A thread is eligible for gc iff it has finished and there are no
59 ;; more references to it. This list is supposed to keep a reference to
60 ;; all running threads.
61 (defvar *all-threads
* ())
62 (defvar *all-threads-lock
* (make-mutex :name
"all threads lock"))
64 (defun list-all-threads ()
66 "Return a list of the live threads."
67 (with-mutex (*all-threads-lock
*)
68 (copy-list *all-threads
*)))
70 (declaim (inline current-thread-sap
))
71 (defun current-thread-sap ()
72 (sb!vm
::current-thread-offset-sap sb
!vm
::thread-this-slot
))
74 (declaim (inline current-thread-sap-id
))
75 (defun current-thread-sap-id ()
77 (sb!vm
::current-thread-offset-sap sb
!vm
::thread-os-thread-slot
)))
79 (defun init-initial-thread ()
80 (let ((initial-thread (%make-thread
:name
"initial thread"
81 :%sap
(current-thread-sap))))
82 (setq *current-thread
* initial-thread
)
83 ;; Either *all-threads* is empty or it contains exactly one thread
84 ;; in case we are in reinit since saving core with multiple
85 ;; threads doesn't work.
86 (setq *all-threads
* (list initial-thread
))))
92 (define-alien-routine ("create_thread" %create-thread
)
94 (lisp-fun-address unsigned-long
))
96 (define-alien-routine "block_deferrable_signals_and_inhibit_gc"
99 (define-alien-routine reap-dead-thread void
100 (thread-sap system-area-pointer
))
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 (sb!sys
: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
(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)))
190 (unless new-value
(setf new-value
*current-thread
*))
192 (let ((old-value (mutex-value mutex
)))
193 (when (and old-value wait-p
)
194 (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
195 new-value ~S, but has already been acquired (with value ~S)."
196 mutex wait-p new-value old-value
))
197 (setf (mutex-value mutex
) new-value
)
201 (when (eql new-value
(mutex-value mutex
))
202 (warn "recursive lock attempt ~S~%" mutex
)
203 (format *debug-io
* "Thread: ~A~%" *current-thread
*)
204 (sb!debug
:backtrace most-positive-fixnum
*debug-io
*)
205 (force-output *debug-io
*))
208 (setf old
(sb!vm
::%instance-set-conditional mutex
2 nil new-value
))
210 (unless wait-p
(return nil
))
211 (futex-wait (mutex-value-address mutex
)
212 (sb!kernel
:get-lisp-obj-address old
)))))
214 (defun release-mutex (mutex)
216 "Release MUTEX by setting it to NIL. Wake up threads waiting for
218 (declare (type mutex mutex
))
219 (setf (mutex-value mutex
) nil
)
221 (futex-wake (mutex-value-address mutex
) 1))
223 ;;;; waitqueues/condition variables
225 (defstruct (waitqueue (:constructor %make-waitqueue
))
228 (name nil
:type
(or null simple-string
))
231 (defun make-waitqueue (&key name
)
233 "Create a waitqueue."
234 (%make-waitqueue
:name name
))
237 (setf (sb!kernel
:fdocumentation
'waitqueue-name
'function
)
238 "The name of the waitqueue. Setfable.")
241 (declaim (inline waitqueue-data-address
))
243 (defun waitqueue-data-address (waitqueue)
244 (declare (optimize (speed 3)))
247 (+ (sb!kernel
:get-lisp-obj-address waitqueue
)
248 (- (* 3 sb
!vm
:n-word-bytes
) sb
!vm
:instance-pointer-lowtag
))))
250 (defun condition-wait (queue mutex
)
252 "Atomically release MUTEX and enqueue ourselves on QUEUE. Another
253 thread may subsequently notify us using CONDITION-NOTIFY, at which
254 time we reacquire MUTEX and return to the caller."
255 #!-sb-thread
(declare (ignore queue
))
257 #!-sb-thread
(error "Not supported in unithread builds.")
259 (let ((value (mutex-value mutex
)))
261 (let ((me *current-thread
*))
262 ;; XXX we should do something to ensure that the result of this setf
263 ;; is visible to all CPUs
264 (setf (waitqueue-data queue
) me
)
265 (release-mutex mutex
)
266 ;; Now we go to sleep using futex-wait. If anyone else
267 ;; manages to grab MUTEX and call CONDITION-NOTIFY during
268 ;; this comment, it will change queue->data, and so
269 ;; futex-wait returns immediately instead of sleeping.
270 ;; Ergo, no lost wakeup
271 (futex-wait (waitqueue-data-address queue
)
272 (sb!kernel
:get-lisp-obj-address me
)))
273 ;; If we are interrupted while waiting, we should do these things
274 ;; before returning. Ideally, in the case of an unhandled signal,
275 ;; we should do them before entering the debugger, but this is
276 ;; better than nothing.
277 (get-mutex mutex value
))))
279 (defun condition-notify (queue)
281 "Notify one of the threads waiting on QUEUE."
282 #!-sb-thread
(declare (ignore queue
))
283 #!-sb-thread
(error "Not supported in unithread builds.")
285 (let ((me *current-thread
*))
286 ;; no problem if >1 thread notifies during the comment in
287 ;; condition-wait: as long as the value in queue-data isn't the
288 ;; waiting thread's id, it matters not what it is
289 ;; XXX we should do something to ensure that the result of this setf
290 ;; is visible to all CPUs
291 (setf (waitqueue-data queue
) me
)
292 (futex-wake (waitqueue-data-address queue
) 1)))
294 (defun condition-broadcast (queue)
296 "Notify all threads waiting on QUEUE."
297 #!-sb-thread
(declare (ignore queue
))
298 #!-sb-thread
(error "Not supported in unithread builds.")
300 (let ((me *current-thread
*))
301 (setf (waitqueue-data queue
) me
)
302 (futex-wake (waitqueue-data-address queue
) (ash 1 30))))
304 ;;;; job control, independent listeners
307 (lock (make-mutex :name
"session lock"))
309 (interactive-threads nil
)
310 (interactive-threads-queue (make-waitqueue)))
312 (defvar *session
* nil
)
314 ;;; the debugger itself tries to acquire the session lock, don't let
315 ;;; funny situations (like getting a sigint while holding the session
317 (defmacro with-session-lock
((session) &body body
)
318 #!-sb-thread
(declare (ignore session
))
322 `(sb!sys
:without-interrupts
323 (with-mutex ((session-lock ,session
))
326 (defun new-session ()
327 (make-session :threads
(list *current-thread
*)
328 :interactive-threads
(list *current-thread
*)))
330 (defun init-job-control ()
331 (setf *session
* (new-session)))
333 (defun %delete-thread-from-session
(thread session
)
334 (with-session-lock (session)
335 (setf (session-threads session
)
336 (delete thread
(session-threads session
))
337 (session-interactive-threads session
)
338 (delete thread
(session-interactive-threads session
)))))
340 (defun call-with-new-session (fn)
341 (%delete-thread-from-session
*current-thread
* *session
*)
342 (let ((*session
* (new-session)))
345 (defmacro with-new-session
(args &body forms
)
346 (declare (ignore args
)) ;for extensibility
347 (sb!int
:with-unique-names
(fb-name)
348 `(labels ((,fb-name
() ,@forms
))
349 (call-with-new-session (function ,fb-name
)))))
351 ;;; Remove thread from its session, if it has one.
353 (defun handle-thread-exit (thread)
354 (with-mutex (*all-threads-lock
*)
355 (setq *all-threads
* (delete thread
*all-threads
*)))
357 (%delete-thread-from-session thread
*session
*)))
359 (defun terminate-session ()
361 "Kill all threads in session except for this one. Does nothing if current
362 thread is not the foreground thread."
363 ;; FIXME: threads created in other threads may escape termination
365 (with-session-lock (*session
*)
366 (and (eq *current-thread
*
367 (car (session-interactive-threads *session
*)))
368 (session-threads *session
*)))))
369 ;; do the kill after dropping the mutex; unwind forms in dying
370 ;; threads may want to do session things
371 (dolist (thread to-kill
)
372 (unless (eq thread
*current-thread
*)
373 ;; terminate the thread but don't be surprised if it has
374 ;; exited in the meantime
375 (handler-case (terminate-thread thread
)
376 (interrupt-thread-error ()))))))
378 ;;; called from top of invoke-debugger
379 (defun debugger-wait-until-foreground-thread (stream)
380 "Returns T if thread had been running in background, NIL if it was
382 (declare (ignore stream
))
386 (with-session-lock (*session
*)
387 (not (member *current-thread
*
388 (session-interactive-threads *session
*))))
391 (defun get-foreground ()
394 (let ((was-foreground t
))
396 (with-session-lock (*session
*)
397 (let ((int-t (session-interactive-threads *session
*)))
398 (when (eq (car int-t
) *current-thread
*)
399 (unless was-foreground
400 (format *query-io
* "Resuming thread ~A~%" *current-thread
*))
401 (return-from get-foreground t
))
402 (setf was-foreground nil
)
403 (unless (member *current-thread
* int-t
)
404 (setf (cdr (last int-t
))
405 (list *current-thread
*)))
407 (session-interactive-threads-queue *session
*)
408 (session-lock *session
*)))))))
410 (defun release-foreground (&optional next
)
412 "Background this thread. If NEXT is supplied, arrange for it to
413 have the foreground next."
414 #!-sb-thread
(declare (ignore next
))
417 (with-session-lock (*session
*)
418 (when (rest (session-interactive-threads *session
*))
419 (setf (session-interactive-threads *session
*)
420 (delete *current-thread
* (session-interactive-threads *session
*))))
422 (setf (session-interactive-threads *session
*)
424 (delete next
(session-interactive-threads *session
*)))))
425 (condition-broadcast (session-interactive-threads-queue *session
*))))
427 (defun foreground-thread ()
428 (car (session-interactive-threads *session
*)))
430 (defun make-listener-thread (tty-name)
431 (assert (probe-file tty-name
))
432 (let* ((in (sb!unix
:unix-open
(namestring tty-name
) sb
!unix
:o_rdwr
#o666
))
433 (out (sb!unix
:unix-dup in
))
434 (err (sb!unix
:unix-dup in
)))
435 (labels ((thread-repl ()
436 (sb!unix
::unix-setsid
)
437 (let* ((sb!impl
::*stdin
*
438 (sb!sys
:make-fd-stream in
:input t
:buffering
:line
441 (sb!sys
:make-fd-stream out
:output t
:buffering
:line
444 (sb!sys
:make-fd-stream err
:output t
:buffering
:line
447 (sb!sys
:make-fd-stream err
:input t
:output t
450 (sb!impl
::*descriptor-handlers
* nil
))
453 (sb!impl
::toplevel-repl nil
)
454 (sb!int
:flush-standard-output-streams
))))))
455 (make-thread #'thread-repl
))))
459 (defun make-thread (function &key name
)
461 "Create a new thread of NAME that runs FUNCTION. When the function
462 returns the thread exits."
463 #!-sb-thread
(declare (ignore function name
))
464 #!-sb-thread
(error "Not supported in unithread builds.")
466 (let* ((thread (%make-thread
:name name
))
468 (real-function (coerce function
'function
))
471 (sb!kernel
:get-lisp-obj-address
473 ;; FIXME: use semaphores?
475 ;; in time we'll move some of the binding presently done in C
477 (let ((*current-thread
* thread
)
478 (sb!kernel
::*restart-clusters
* nil
)
479 (sb!kernel
::*handler-clusters
* nil
)
480 (sb!kernel
::*condition-restarts
* nil
)
481 (sb!impl
::*descriptor-handlers
* nil
)) ; serve-event
482 ;; can't use handling-end-of-the-world, because that flushes
483 ;; output streams, and we don't necessarily have any (or we
484 ;; could be sharing them)
486 (catch 'sb
!impl
::toplevel-catcher
487 (catch 'sb
!impl
::%end-of-the-world
490 (format nil
"~~@<Terminate this thread (~A)~~@:>"
492 ;; now that most things have a chance to work
493 ;; properly without messing up other threads, it's
494 ;; time to enable signals
495 (sb!unix
::reset-signal-mask
)
497 (funcall real-function
)
498 ;; we're going down, can't handle
499 ;; interrupts sanely anymore
500 (block-deferrable-signals-and-inhibit-gc)))))
501 ;; and remove what can be the last reference to the
503 (handle-thread-exit thread
)
506 (when (sb!sys
:sap
= thread-sap
(sb!sys
:int-sap
0))
507 (error "Can't create a new thread"))
508 (setf (thread-%sap thread
) thread-sap
)
509 (with-mutex (*all-threads-lock
*)
510 (push thread
*all-threads
*))
511 (with-session-lock (*session
*)
512 (push thread
(session-threads *session
*)))
514 (sb!impl
::finalize thread
(lambda () (reap-dead-thread thread-sap
)))
517 (defun destroy-thread (thread)
519 "Deprecated. Same as TERMINATE-THREAD."
520 (terminate-thread thread
))
522 (define-condition interrupt-thread-error
(error)
523 ((thread :reader interrupt-thread-error-thread
:initarg
:thread
)
524 (errno :reader interrupt-thread-error-errno
:initarg
:errno
))
526 (:documentation
"Interrupting thread failed.")
527 (:report
(lambda (c s
)
528 (format s
"interrupt thread ~A failed (~A: ~A)"
529 (interrupt-thread-error-thread c
)
530 (interrupt-thread-error-errno c
)
531 (strerror (interrupt-thread-error-errno c
))))))
534 (setf (sb!kernel
:fdocumentation
'interrupt-thread-error-thread
'function
)
535 "The thread that was not interrupted."
536 (sb!kernel
:fdocumentation
'interrupt-thread-error-errno
'function
)
537 "The reason why the interruption failed.")
539 (defun interrupt-thread (thread function
)
541 "Interrupt the live THREAD and make it run FUNCTION. A moderate
542 degree of care is expected for use of interrupt-thread, due to its
543 nature: if you interrupt a thread that was holding important locks
544 then do something that turns out to need those locks, you probably
545 won't like the effect."
546 #!-sb-thread
(declare (ignore thread
))
547 ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
552 (let ((function (coerce function
'function
)))
553 (multiple-value-bind (res err
)
554 (sb!unix
::syscall
("interrupt_thread"
555 system-area-pointer sb
!alien
:unsigned-long
)
558 (sb!kernel
:get-lisp-obj-address function
))
560 (error 'interrupt-thread-error
:thread thread
:errno err
)))))
562 (defun terminate-thread (thread)
564 "Terminate the thread identified by THREAD, by causing it to run
565 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
566 (interrupt-thread thread
'sb
!ext
:quit
))
568 ;;; internal use only. If you think you need to use this, either you
569 ;;; are an SBCL developer, are doing something that you should discuss
570 ;;; with an SBCL developer first, or are doing something that you
571 ;;; should probably discuss with a professional psychiatrist first
573 (defun symbol-value-in-thread (symbol thread
)
574 (let ((thread-sap (thread-%sap thread
)))
575 (let* ((index (sb!vm
::symbol-tls-index symbol
))
576 (tl-val (sb!sys
:sap-ref-word thread-sap
577 (* sb
!vm
:n-word-bytes index
))))
578 (if (eql tl-val sb
!vm
::unbound-marker-widetag
)
579 (sb!vm
::symbol-global-value symbol
)
580 (sb!kernel
:make-lisp-obj tl-val
)))))