forked from dmitryvk/sbcl-win32-threads
-
Notifications
You must be signed in to change notification settings - Fork 4
/
target-thread.lisp
372 lines (330 loc) · 12.2 KB
/
target-thread.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
(in-package "SB!THREAD")
(sb!alien::define-alien-routine ("create_thread" %create-thread)
sb!alien:unsigned-long
(lisp-fun-address sb!alien:unsigned-long))
(defun make-thread (function)
(let ((real-function (coerce function 'function)))
(%create-thread
(sb!kernel:get-lisp-obj-address
(lambda ()
;; in time we'll move some of the binding presently done in C
;; here too
(let ((sb!kernel::*restart-clusters* nil)
(sb!impl::*descriptor-handlers* nil); serve-event
(sb!impl::*available-buffers* nil)) ;for fd-stream
;; can't use handling-end-of-the-world, because that flushes
;; output streams, and we don't necessarily have any (or we
;; could be sharing them)
(sb!sys:enable-interrupt :sigint :ignore)
(sb!unix:unix-exit
(catch 'sb!impl::%end-of-the-world
(with-simple-restart
(destroy-thread
(format nil "~~@<Destroy this thread (~A)~~@:>"
(current-thread-id)))
(funcall real-function))
0))))))))
(defun destroy-thread (thread-id)
(sb!unix:unix-kill thread-id :sigterm)
;; may have been stopped for some reason, so now wake it up to
;; deliver the TERM
(sb!unix:unix-kill thread-id :sigcont))
;; Conventional wisdom says that it's a bad idea to use these unless
;; you really need to. Use a lock or a waitqueue instead
(defun suspend-thread (thread-id)
(sb!unix:unix-kill thread-id :sigstop))
(defun resume-thread (thread-id)
(sb!unix:unix-kill thread-id :sigcont))
(defun current-thread-id ()
(sb!sys:sap-int
(sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
;;;; iterate over the in-memory threads
(defun mapcar-threads (function)
"Call FUNCTION once for each known thread, giving it the thread structure as argument"
(let ((function (coerce function 'function)))
(loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
then (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
until (sb!sys:sap= thread (sb!sys:int-sap 0))
collect (funcall function thread))))
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
(defun get-spinlock (lock offset new-value)
(declare (optimize (speed 3) (safety 0)))
(loop until
(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
(defmacro with-spinlock ((queue) &body body)
(let ((pid (gensym "PID")))
`(unwind-protect
(let ((,pid (current-thread-id)))
(get-spinlock ,queue 2 ,pid)
,@body)
(setf (waitqueue-lock ,queue) 0))))
;;;; the higher-level locking operations are based on waitqueues
(defstruct waitqueue
(name nil :type (or null simple-base-string))
(lock 0)
(data nil))
(defstruct (mutex (:include waitqueue))
(value nil))
(sb!alien:define-alien-routine "block_sigcont" void)
(sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void)
(defun wait-on-queue (queue &optional lock)
(let ((pid (current-thread-id)))
;; FIXME what should happen if we get interrupted when we've blocked
;; the sigcont? For that matter, can we get interrupted?
(block-sigcont)
(when lock (release-mutex lock))
(get-spinlock queue 2 pid)
(pushnew pid (waitqueue-data queue))
(setf (waitqueue-lock queue) 0)
(unblock-sigcont-and-sleep)))
(defun dequeue (queue)
(let ((pid (current-thread-id)))
(get-spinlock queue 2 pid)
(setf (waitqueue-data queue)
(delete pid (waitqueue-data queue)))
(setf (waitqueue-lock queue) 0)))
(defun signal-queue-head (queue)
(let ((pid (current-thread-id)))
(get-spinlock queue 2 pid)
(let ((h (car (waitqueue-data queue))))
(setf (waitqueue-lock queue) 0)
(when h
(sb!unix:unix-kill h :sigcont)))))
;;;; mutex
(defun get-mutex (lock &optional new-value (wait-p t))
(declare (type mutex lock))
(let ((pid (current-thread-id)))
(unless new-value (setf new-value pid))
(assert (not (eql new-value (mutex-value lock))))
(loop
(unless
;; args are object slot-num old-value new-value
(sb!vm::%instance-set-conditional lock 4 nil new-value)
(dequeue lock)
(return t))
(unless wait-p (return nil))
(wait-on-queue lock nil))))
(defun release-mutex (lock &optional (new-value nil))
(declare (type mutex lock))
(let ((old-value (mutex-value lock))
(t1 nil))
(loop
(unless
;; args are object slot-num old-value new-value
(eql old-value
(setf t1
(sb!vm::%instance-set-conditional lock 4 old-value new-value)))
(signal-queue-head lock)
(return t))
(setf old-value t1))))
(defmacro with-mutex ((mutex &key value (wait-p t)) &body body)
(let ((block (gensym "NIL"))
(got (gensym "GOT")))
`(let ((,got (get-mutex ,mutex ,value ,wait-p)))
(when ,got
(unwind-protect
(progn ,@body)
(release-mutex ,mutex))))))
;;;; condition variables
(defun condition-wait (queue lock)
"Atomically release LOCK and enqueue ourselves on QUEUE. Another
thread may subsequently notify us using CONDITION-NOTIFY, at which
time we reacquire LOCK and return to the caller."
(unwind-protect
(wait-on-queue queue lock)
;; If we are interrupted while waiting, we should do these things
;; before returning. Ideally, in the case of an unhandled signal,
;; we should do them before entering the debugger, but this is
;; better than nothing.
(dequeue queue)
(get-mutex lock)))
(defun condition-notify (queue)
"Notify one of the processes waiting on QUEUE"
(signal-queue-head queue))
;;;; multiple independent listeners
(defvar *session-lock* nil)
(defun make-listener-thread (tty-name)
(assert (probe-file tty-name))
;; FIXME probably still need to do some tty stuff to get signals
;; delivered correctly.
;; FIXME
(let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
(out (sb!unix:unix-dup in))
(err (sb!unix:unix-dup in)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((*session-lock*
(make-mutex :name (format nil "lock for ~A" tty-name)))
(sb!impl::*stdin*
(sb!sys:make-fd-stream in :input t :buffering :line))
(sb!impl::*stdout*
(sb!sys:make-fd-stream out :output t :buffering :line))
(sb!impl::*stderr*
(sb!sys:make-fd-stream err :output t :buffering :line))
(sb!impl::*tty*
(sb!sys:make-fd-stream err :input t :output t :buffering :line))
(sb!impl::*descriptor-handlers* nil))
(get-mutex *session-lock*)
(sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams)))))
(make-thread #'thread-repl))))
;;;; job control
(defvar *background-threads-wait-for-debugger* t)
;;; may be T, NIL, or a function called with a stream and thread id
;;; as its two arguments, returning NIl or T
;;; called from top of invoke-debugger
(defun debugger-wait-until-foreground-thread (stream)
"Returns T if thread had been running in background, NIL if it was
already the foreground thread, or transfers control to the first applicable
restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
(let* ((wait-p *background-threads-wait-for-debugger*)
(*background-threads-wait-for-debugger* nil)
(lock *session-lock*))
(when (not (eql (mutex-value lock) (CURRENT-THREAD-ID)))
(when (functionp wait-p)
(setf wait-p
(funcall wait-p stream (CURRENT-THREAD-ID))))
(cond (wait-p (get-foreground))
(t (invoke-restart (car (compute-restarts))))))))
;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
;;; One day it will be default
(defun thread-repl-prompt-fun (out-stream)
(let ((lock *session-lock*))
(get-foreground)
(let ((stopped-threads (waitqueue-data lock)))
(when stopped-threads
(format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
(sb!impl::repl-prompt-fun out-stream))))
(defun resume-stopped-thread (id)
(let ((pid (current-thread-id))
(lock *session-lock*))
(with-spinlock (lock)
(setf (waitqueue-data lock)
(cons id (delete id (waitqueue-data lock)))))
(release-foreground)))
(defstruct rwlock
(name nil :type (or null simple-base-string))
(value 0 :type fixnum)
(max-readers nil :type (or fixnum null))
(max-writers 1 :type fixnum))
#+nil
(macrolet
((make-rwlocking-function (lock-fn unlock-fn increment limit test)
(let ((do-update '(when (eql old-value
(sb!vm::%instance-set-conditional
lock 2 old-value new-value))
(return (values t old-value))))
(vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
old-value
new-value
(limit ,limit))))
(labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
new-value (,v old-value ,increment))))
`(progn
(defun ,lock-fn (lock timeout)
(declare (type rwlock lock))
(let ,vars
(loop
,(do-setfs '+)
(when ,test
,do-update)
(when (sleep-a-bit timeout) (return nil)) ;expired
)))
;; unlock doesn't need timeout or test-in-range
(defun ,unlock-fn (lock)
(declare (type rwlock lock))
(declare (ignorable limit))
(let ,(cdr vars)
(loop
,(do-setfs '-)
,do-update))))))))
(make-rwlocking-function %lock-for-reading %unlock-for-reading 1
(rwlock-max-readers lock)
(and (>= old-value 0)
(or (null limit) (<= new-value limit))))
(make-rwlocking-function %lock-for-writing %unlock-for-writing -1
(- (rwlock-max-writers lock))
(and (<= old-value 0)
(>= new-value limit))))
#+nil
(defun get-rwlock (lock direction &optional timeout)
(ecase direction
(:read (%lock-for-reading lock timeout))
(:write (%lock-for-writing lock timeout))))
#+nil
(defun free-rwlock (lock direction)
(ecase direction
(:read (%unlock-for-reading lock))
(:write (%unlock-for-writing lock))))
;;;; beyond this point all is commented.
;;; Lock-Wait-With-Timeout -- Internal
;;;
;;; Wait with a timeout for the lock to be free and acquire it for the
;;; *current-process*.
;;;
#+nil
(defun lock-wait-with-timeout (lock whostate timeout)
(declare (type lock lock))
(process-wait-with-timeout
whostate timeout
#'(lambda ()
(declare (optimize (speed 3)))
#-i486
(unless (lock-process lock)
(setf (lock-process lock) *current-process*))
#+i486
(null (kernel:%instance-set-conditional
lock 2 nil *current-process*)))))
;;; With-Lock-Held -- Public
;;;
#+nil
(defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
&key (wait t) timeout)
&body body)
"Execute the body with the lock held. If the lock is held by another
process then the current process waits until the lock is released or
an optional timeout is reached. The optional wait timeout is a time in
seconds acceptable to process-wait-with-timeout. The results of the
body are return upon success and NIL is return if the timeout is
reached. When the wait key is NIL and the lock is held by another
process then NIL is return immediately without processing the body."
(let ((have-lock (gensym)))
`(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
(unwind-protect
,(cond ((and timeout wait)
`(progn
(when (and (error-check-lock-p ,lock) ,have-lock)
(error "Dead lock"))
(when (or ,have-lock
#+i486 (null (kernel:%instance-set-conditional
,lock 2 nil *current-process*))
#-i486 (seize-lock ,lock)
(if ,timeout
(lock-wait-with-timeout
,lock ,whostate ,timeout)
(lock-wait ,lock ,whostate)))
,@body)))
(wait
`(progn
(when (and (error-check-lock-p ,lock) ,have-lock)
(error "Dead lock"))
(unless (or ,have-lock
#+i486 (null (kernel:%instance-set-conditional
,lock 2 nil *current-process*))
#-i486 (seize-lock ,lock))
(lock-wait ,lock ,whostate))
,@body))
(t
`(when (or (and (recursive-lock-p ,lock) ,have-lock)
#+i486 (null (kernel:%instance-set-conditional
,lock 2 nil *current-process*))
#-i486 (seize-lock ,lock))
,@body)))
(unless ,have-lock
#+i486 (kernel:%instance-set-conditional
,lock 2 *current-process* nil)
#-i486 (when (eq (lock-process ,lock) *current-process*)
(setf (lock-process ,lock) nil)))))))