0.8.15.7
[sbcl.git] / src / code / target-unithread.lisp
1 ;;;; unithread stub support for threads in the target machine
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!THREAD")
13
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))) 
19                (* n 4)))
20
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)))
24
25 (defun reap-dead-threads ())
26
27 ;;;; queues, locks 
28
29 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
30 (defun get-spinlock (lock offset new-value)
31   (declare (ignore lock offset new-value)))
32
33 (defmacro with-spinlock ((queue) &body body)
34   (declare (ignore queue))
35   `(progn ,@body))
36
37 ;;;; the higher-level locking operations are based on waitqueues
38
39 (defstruct waitqueue
40   (name nil :type (or null simple-base-string))
41   (lock 0)
42   (data nil))
43
44 (defstruct (mutex (:include waitqueue))
45   (value nil))
46
47 #+nil
48 (defun wait-on-queue (queue &optional lock)
49   (let ((pid (current-thread-id)))
50     ;; FIXME what should happen if we get interrupted when we've blocked
51     ;; the sigcont?  For that matter, can we get interrupted?
52     (block-sigcont)
53     (when lock (release-mutex lock))
54     (get-spinlock queue 2 pid)
55     (pushnew pid (waitqueue-data queue))
56     (setf (waitqueue-lock queue) 0)
57     (unblock-sigcont-and-sleep)))
58
59 #+nil
60 (defun dequeue (queue)
61   (let ((pid (current-thread-id)))
62     (get-spinlock queue 2 pid)
63     (setf (waitqueue-data queue)
64           (delete pid (waitqueue-data queue)))
65     (setf (waitqueue-lock queue) 0)))
66
67 #+nil
68 (defun signal-queue-head (queue)
69   (let ((pid (current-thread-id)))
70     (get-spinlock queue 2 pid)
71     (let ((h (car (waitqueue-data queue))))
72       (setf (waitqueue-lock queue) 0)
73       (when h
74         (sb!unix:unix-kill h sb!unix:sigcont)))))
75
76 ;;;; mutex
77
78 #+nil
79 (defun get-mutex (lock &optional new-value (wait-p t))
80   (declare (type mutex lock))
81   (let ((pid (current-thread-id)))
82     (unless new-value (setf new-value pid))
83     (assert (not (eql new-value (mutex-value lock))))
84     (loop
85      (unless
86          ;; args are object slot-num old-value new-value
87          (sb!vm::%instance-set-conditional lock 4 nil new-value)
88        (dequeue lock)
89        (return t))
90      (unless wait-p (return nil))
91      (wait-on-queue lock nil))))
92
93 #+nil
94 (defun release-mutex (lock &optional (new-value nil))
95   (declare (type mutex lock))
96   (let ((old-value (mutex-value lock))
97         (t1 nil))
98     (loop
99      (unless
100          ;; args are object slot-num old-value new-value
101          (eql old-value
102               (setf t1
103                     (sb!vm::%instance-set-conditional lock 4 old-value new-value)))       
104        (signal-queue-head lock)
105        (return t))
106      (setf old-value t1))))
107
108 (defun get-mutex (lock &optional new-value (wait-p t))
109   (declare (type mutex lock))
110   (let ((old-value (mutex-value lock)))
111     (when (and old-value wait-p)
112       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
113               new-value ~S, but has already been acquired (with value ~S)."
114              lock wait-p new-value old-value))
115     (setf (mutex-value lock) new-value)
116     t))
117
118 (defun release-mutex (lock)
119   (declare (type mutex lock))
120   (setf (mutex-value lock) nil))
121
122 ;;; what's the best thing to do with these on unithread?  commented
123 ;;; functions are the thread versions, just to remind me what they do
124 ;;; there
125 #+nil
126 (defun condition-wait (queue lock)
127   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
128 thread may subsequently notify us using CONDITION-NOTIFY, at which
129 time we reacquire LOCK and return to the caller."
130   (unwind-protect
131        (wait-on-queue queue lock)
132     ;; If we are interrupted while waiting, we should do these things
133     ;; before returning.  Ideally, in the case of an unhandled signal,
134     ;; we should do them before entering the debugger, but this is
135     ;; better than nothing.
136     (dequeue queue)
137     (get-mutex lock)))
138
139 #+nil
140 (defun condition-notify (queue)
141   "Notify one of the processes waiting on QUEUE"
142   (signal-queue-head queue))
143
144 (defun maybe-install-futex-functions () nil)
145
146 ;;;; job control
147
148 (defun init-job-control () t)
149 (defun debugger-wait-until-foreground-thread (stream)
150   (declare (ignore stream))
151   t)
152 (defun get-foreground () t)
153 (defun release-foreground (&optional next)
154   (declare (ignore next))
155   t)
156 (defun terminate-session ())