1 ;;;; unithread stub 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 ;;; used bu debug-int.lisp to access interrupt contexts
15 #!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
16 (defun sb!vm::current-thread-offset-sap (n)
17 (declare (type (unsigned-byte 27) n))
18 (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
21 (defun current-thread-id ()
22 (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t)))
23 (* sb!vm::thread-pid-slot 4)))
27 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
28 (defun get-spinlock (lock offset new-value)
29 (declare (ignore lock offset new-value)))
31 (defmacro with-spinlock ((queue) &body body)
32 (declare (ignore queue))
35 ;;;; the higher-level locking operations are based on waitqueues
38 (name nil :type (or null simple-base-string))
42 (defstruct (mutex (:include waitqueue))
46 (defun wait-on-queue (queue &optional lock)
47 (let ((pid (current-thread-id)))
48 ;; FIXME what should happen if we get interrupted when we've blocked
49 ;; the sigcont? For that matter, can we get interrupted?
51 (when lock (release-mutex lock))
52 (get-spinlock queue 2 pid)
53 (pushnew pid (waitqueue-data queue))
54 (setf (waitqueue-lock queue) 0)
55 (unblock-sigcont-and-sleep)))
58 (defun dequeue (queue)
59 (let ((pid (current-thread-id)))
60 (get-spinlock queue 2 pid)
61 (setf (waitqueue-data queue)
62 (delete pid (waitqueue-data queue)))
63 (setf (waitqueue-lock queue) 0)))
66 (defun signal-queue-head (queue)
67 (let ((pid (current-thread-id)))
68 (get-spinlock queue 2 pid)
69 (let ((h (car (waitqueue-data queue))))
70 (setf (waitqueue-lock queue) 0)
72 (sb!unix:unix-kill h sb!unix:sigcont)))))
77 (defun get-mutex (lock &optional new-value (wait-p t))
78 (declare (type mutex lock))
79 (let ((pid (current-thread-id)))
80 (unless new-value (setf new-value pid))
81 (assert (not (eql new-value (mutex-value lock))))
84 ;; args are object slot-num old-value new-value
85 (sb!vm::%instance-set-conditional lock 4 nil new-value)
88 (unless wait-p (return nil))
89 (wait-on-queue lock nil))))
92 (defun release-mutex (lock &optional (new-value nil))
93 (declare (type mutex lock))
94 (let ((old-value (mutex-value lock))
98 ;; args are object slot-num old-value new-value
101 (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
102 (signal-queue-head lock)
104 (setf old-value t1))))
106 (defun get-mutex (lock &optional new-value (wait-p t))
107 (declare (type mutex lock))
108 (let ((old-value (mutex-value lock)))
109 (when (and old-value wait-p)
110 (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
111 new-value ~S, but has already been acquired (with value ~S)."
112 lock wait-p new-value old-value))
113 (setf (mutex-value lock) new-value)
116 (defun release-mutex (lock)
117 (declare (type mutex lock))
118 (setf (mutex-value lock) nil))
120 ;;; what's the best thing to do with these on unithread? commented
121 ;;; functions are the thread versions, just to remind me what they do
124 (defun condition-wait (queue lock)
125 "Atomically release LOCK and enqueue ourselves on QUEUE. Another
126 thread may subsequently notify us using CONDITION-NOTIFY, at which
127 time we reacquire LOCK and return to the caller."
129 (wait-on-queue queue lock)
130 ;; If we are interrupted while waiting, we should do these things
131 ;; before returning. Ideally, in the case of an unhandled signal,
132 ;; we should do them before entering the debugger, but this is
133 ;; better than nothing.
138 (defun condition-notify (queue)
139 "Notify one of the processes waiting on QUEUE"
140 (signal-queue-head queue))
142 (defun maybe-install-futex-functions () nil)
146 (defun init-job-control () t)
147 (defun debugger-wait-until-foreground-thread (stream)
148 (declare (ignore stream))
150 (defun get-foreground () t)
151 (defun release-foreground (&optional next)
152 (declare (ignore next))
154 (defun terminate-session ())