Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 308 lines (286 sloc) 11.518 kb
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
1 (defpackage "WORK-QUEUE"
2 (:use "CL" "SB-EXT" "SB-THREAD")
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
3 (:export "TASK" "TASK-P" "BULK-TASK" "BULK-TASK-P"
4 "TASK-DESIGNATOR"
5 "QUEUE" "MAKE" "P" "ALIVE-P"
693a555 Paul Khuong Thread pool diffs
authored
6 "ENQUEUE" "ENQUEUE-ALL" "STOP"
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
7 "PUSH-SELF" "PUSH-SELF-ALL"
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
8 "PROGRESS-UNTIL"
9 "CURRENT-QUEUE" "WORKER-ID" "WORKER-COUNT")
bae856f Paul Khuong Split up in work-stack and work-queue
authored
10 (:import-from "WORK-STACK"
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
11 "TASK" "TASK-P"
bae856f Paul Khuong Split up in work-stack and work-queue
authored
12 "BULK-TASK" "BULK-TASK-P"
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
13 "TASK-DESIGNATOR"))
14
15 ;;; Work-unit queue/stack, with thread-pool
16 ;;;
17 ;;; Normal work queue: created with a fixed number of worker threads,
18 ;;; and a shared FIFO of work units (c.f. work-stack).
19 ;;;
20 ;;; However, each worker also has a work-stack. This way, tasks can
21 ;;; spawn new tasks recursively, while enjoying temporal locality and
22 ;;; skipping in front of the rest of the queue.
23 ;;;
24 ;;; ENQUEUE/ENQUEUE-ALL insert work units in the queue.
25 ;;;
26 ;;; PUSH-SELF/PUSH-SELF-ALL insert work units in the worker's local
27 ;;; stack, or, if not executed by a worker, punt to ENQUEUE/ENQUEUE-ALL.
28 ;;;
29 ;;; Note that the work-stacks support task-stealing, so pushing to the
30 ;;; local stack does not reduce parallelism.
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
31
32 (in-package "WORK-QUEUE")
33
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
34 (defconstant +max-thread-count+ 1024)
35 (deftype thread-count ()
36 `(integer 1 ,+max-thread-count+))
37 (deftype thread-id ()
38 `(mod ,+max-thread-count+))
39
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
40 (defstruct (queue
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
41 (:constructor %make-queue))
42 (locks (error "foo") :type (simple-array mutex 1)
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
43 :read-only t)
44 (cvar (make-waitqueue) :type waitqueue
45 :read-only t)
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
46 (nthread (error "foo") :type thread-count
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
47 :read-only t)
48 (state (error "foo") :type cons
49 :read-only t)
bae856f Paul Khuong Split up in work-stack and work-queue
authored
50 (queue (sb-queue:make-queue) :type sb-queue:queue)
51 (stacks (error "Foo") :type (simple-array work-stack:stack 1)
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
52 :read-only t)
53 (threads (error "Foo") :type (simple-array t 1)
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
54 :read-only t)
55 (randoms (error "Foo") :type (simple-array random-state 1)
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
56 :read-only t))
57
58 (declaim (inline p))
59 (defun p (x)
60 (queue-p x))
61
bae856f Paul Khuong Split up in work-stack and work-queue
authored
62 (defun grab-task (queue stacks i)
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
63 (declare (type thread-id i)
64 (type simple-vector stacks))
bae856f Paul Khuong Split up in work-stack and work-queue
authored
65 (let ((task (sb-queue:dequeue queue)))
66 (when task
67 (return-from grab-task task)))
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
68 (let* ((n (length stacks))
69 (lb (integer-length (1- n)))
70 (ceil (ash 1 lb))
71 (ceil-1 (1- ceil))
72 (scaled (ceiling (ash i lb) n)))
73 (declare (type thread-count n ceil)
74 (type thread-id scaled))
75 ;; scaled is the least value such that
76 ;; (truncate (* scaled n) ceil) = i.
77 (dotimes (j ceil)
78 (let* ((scaledp (* n (logxor scaled j)))
79 (unscaled (ash scaledp (- lb)))
80 (r (logand scaledp ceil-1)))
81 (when (< r n) ;; when (logxor scaled j) is the least value
82 ;; such that the truncation yields unscaled
83 (let ((task (or (work-stack:steal (aref stacks unscaled))
84 (sb-queue:dequeue queue))))
85 (when task
86 (return-from grab-task task))))))))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
87
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
88 (declaim (type (or null thread-id) *worker-id*))
693a555 Paul Khuong Thread pool diffs
authored
89 (defvar *worker-id* nil)
b6ca3dd Paul Khuong Track default hint for bulk tasks better in thread-pool; also name worke...
authored
90 (defvar *worker-hint* 0)
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
91 (defvar *current-queue* nil)
693a555 Paul Khuong Thread pool diffs
authored
92
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
93 (declaim (inline current-queue worker-id worker-count))
35b669d Paul Khuong Refactor work-queue:current-queue usage
authored
94 (defun current-queue (&optional default)
95 (if *current-queue*
96 (weak-pointer-value *current-queue*)
97 default))
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
98
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
99 (defun worker-id ()
100 *worker-id*)
101
1ec0d76 Paul Khuong More bugfixes in parallel primitives
authored
102 (defun worker-count (&optional (queue (current-queue)))
103 (and queue (queue-nthread queue)))
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
104
105 (defun loop-get-task (state lock cvar queue stacks i
106 &optional max-time)
fd1fc48 Paul Khuong More spin loop before going to slow mutex/condvar path waiting for more ...
authored
107 (flet ((try ()
108 (when (eql (car state) :done)
109 (return-from loop-get-task nil))
110 (let ((task (grab-task queue stacks i)))
111 (when task
112 (return-from loop-get-task task)))))
113 (declare (inline try))
3182bff Paul Khuong Tweak wait times in work queue
authored
114 (let ((timeout 1e-4)
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
115 (total 0d0)
2ae2722 Paul Khuong heavier busy-looping in thread pool
authored
116 (fast t))
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
117 (declare (single-float timeout)
118 (double-float total))
cb7bc6c Paul Khuong Undo damage in thread-pool
authored
119 (loop
120 (if fast
121 (dotimes (i 128)
122 (try)
123 (loop repeat (* i 128)
124 do (spin-loop-hint)))
125 (try))
126 ;; Don't do this at home.
127 (setf fast nil)
128 (with-mutex (lock)
129 (if (condition-wait cvar lock :timeout timeout)
130 (setf fast t)
131 (grab-mutex lock)))
132 (when (and max-time
133 (> (incf total timeout) max-time))
134 (return :timeout))
135 (setf timeout (min 1.0 (* timeout 1.1)))))))
fd1fc48 Paul Khuong More spin loop before going to slow mutex/condvar path waiting for more ...
authored
136
4013654 Paul Khuong Factor our worker loop logic
authored
137 (declaim (inline %worker-loop))
138 (defun %worker-loop (weak-queue index hint &optional poll-function wait-time)
0067fcd Paul Khuong muffle code deletion in inlined function
authored
139 (declare (muffle-conditions code-deletion-note))
3dcc430 Paul Khuong Smarter recursive waiting: work on our own stack before stealing
authored
140 (let* ((wait-time (and poll-function (or wait-time 1)))
141 (wqueue (or (weak-pointer-value weak-queue)
142 (return-from %worker-loop)))
143 (i index)
144 (state (queue-state wqueue))
145 (cvar (queue-cvar wqueue))
146 (locks (queue-locks wqueue))
147 (lock (aref locks i))
148 (queue (queue-queue wqueue))
149 (stacks (queue-stacks wqueue))
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
150 (stack (aref stacks i))
151 (random (aref (queue-randoms wqueue) i)))
3dcc430 Paul Khuong Smarter recursive waiting: work on our own stack before stealing
authored
152 (labels ((poll ()
153 (when poll-function
154 (let ((x (funcall poll-function)))
155 (when x (return-from %worker-loop x)))))
156 (work ()
157 (loop while (progn
158 (poll)
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
159 (work-stack:run-one stack random))
3dcc430 Paul Khuong Smarter recursive waiting: work on our own stack before stealing
authored
160 do (when (eq (car state) :done)
161 (return-from %worker-loop)))))
162 (declare (inline poll work))
163 (work)
89c1094 Paul Khuong More straightforward polling loop for recursive wait
authored
164 (let ((task (if (and wait-time (zerop wait-time))
533cd3f Paul Khuong Simpler still
authored
165 (grab-task queue stacks i)
89c1094 Paul Khuong More straightforward polling loop for recursive wait
authored
166 (loop-get-task state lock cvar
167 queue stacks i
168 wait-time))))
533cd3f Paul Khuong Simpler still
authored
169 (cond ((not task)
89c1094 Paul Khuong More straightforward polling loop for recursive wait
authored
170 (poll)
171 (return-from %worker-loop))
172 (poll-function
3dcc430 Paul Khuong Smarter recursive waiting: work on our own stack before stealing
authored
173 (when (eq task :timeout)
cbcbf0d Paul Khuong More robust get-task
authored
174 (poll)
175 (return-from %worker-loop)))
3dcc430 Paul Khuong Smarter recursive waiting: work on our own stack before stealing
authored
176 (t
177 (assert (not (eq task :timeout)))))
178 (if (bulk-task-p task)
179 (work-stack:push stack task hint)
180 (work-stack:execute-task task))
181 (work)
182 (setf queue nil)))))
4013654 Paul Khuong Factor our worker loop logic
authored
183
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
184 (defun %make-worker (wqueue i &optional binding-names binding-compute)
4013654 Paul Khuong Factor our worker loop logic
authored
185 (declare (type queue wqueue))
186 (let* ((state (queue-state wqueue))
b6ca3dd Paul Khuong Track default hint for bulk tasks better in thread-pool; also name worke...
authored
187 (nthread (queue-nthread wqueue))
e788ffb Paul Khuong Try to make context smarter and allow finalisation
authored
188 (hint (float (/ i nthread) 1d0))
189 (weak-queue (make-weak-pointer wqueue)))
693a555 Paul Khuong Thread pool diffs
authored
190 (make-thread
e788ffb Paul Khuong Try to make context smarter and allow finalisation
authored
191 (lambda (&aux (*worker-id* i) (*current-queue* weak-queue) (*worker-hint* hint))
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
192 (progv binding-names (mapcar (lambda (x)
193 (if (functionp x) (funcall x) x))
194 binding-compute)
4013654 Paul Khuong Factor our worker loop logic
authored
195 (loop
04ae010 Paul Khuong Scrub worker threads' stack from time to time
authored
196 (flet ((inner ()
4013654 Paul Khuong Factor our worker loop logic
authored
197 (%worker-loop weak-queue i hint)))
7becef2 Paul Khuong Trivial refactors. Sanity checked all logic below xecto-impl
authored
198 (declare (notinline inner))
04ae010 Paul Khuong Scrub worker threads' stack from time to time
authored
199 (inner)
4013654 Paul Khuong Factor our worker loop logic
authored
200 (sb-sys:scrub-control-stack)
201 (when (eq (car state) :done)
202 (return))))))
b6ca3dd Paul Khuong Track default hint for bulk tasks better in thread-pool; also name worke...
authored
203 :name (format nil "Work queue worker ~A/~A" i nthread))))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
204
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
205 (defun progress-until (condition)
206 (let* ((condition (if (functionp condition)
207 condition (fdefinition condition)))
208 (i (worker-id))
5d34439 Paul Khuong More aggressive polling in recursive wait
authored
209 (hint *worker-hint*)
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
210 (weak-queue *current-queue*)
4013654 Paul Khuong Factor our worker loop logic
authored
211 (state (queue-state
212 (or (current-queue)
5d34439 Paul Khuong More aggressive polling in recursive wait
authored
213 (error "Not in recursive wait?!")))))
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
214 (tagbody
215 retry
533cd3f Paul Khuong Simpler still
authored
216 (flet ((check ()
217 (let ((value (funcall condition)))
218 (when value
219 (return-from progress-until value)))))
220 (declare (inline check))
221 (%worker-loop weak-queue i hint #'check 0)
4013654 Paul Khuong Factor our worker loop logic
authored
222 (unless (eql :done (car state))
223 (go retry))
224 (check)))))
b18cf37 Paul Khuong Recursive waiting in thread-pool, and leak more information to help with...
authored
225
1bc70e7 Paul Khuong Reorganisation, nicer inheritance for parallel futures
authored
226 (defun make (nthread &optional constructor &rest arguments)
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
227 (declare (type thread-count nthread)
1bc70e7 Paul Khuong Reorganisation, nicer inheritance for parallel futures
authored
228 (dynamic-extent arguments))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
229 (let* ((threads (make-array nthread))
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
230 (default-bindings (getf arguments :bindings))
231 (arguments (loop for (key value) on arguments by #'cddr
232 unless (eql key :bindings)
233 nconc (list key value)))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
234 (wqueue (apply (or constructor #'%make-queue)
235 :locks (map-into (make-array nthread) #'make-mutex)
236 :cvar (make-waitqueue)
237 :nthread nthread
238 :state (list :running)
239 :queue (sb-queue:make-queue)
240 :stacks (map-into (make-array nthread) #'work-stack:make)
241 :threads threads
9a72e83 Paul Khuong Randomised subtask distribution, task stealing works better with non-pow...
authored
242 :randoms (let ((i 0))
243 (map-into (make-array nthread)
244 (lambda ()
245 (seed-random-state (incf i)))))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
246 arguments)))
247 (finalize wqueue (let ((cvar (queue-cvar wqueue))
bae856f Paul Khuong Split up in work-stack and work-queue
authored
248 (state (queue-state wqueue)))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
249 (lambda ()
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
250 (setf (car state) :done)
251 (condition-broadcast cvar))))
b8af6ce Paul Khuong Default bindings in worker threads, use it to refer to the right paralle...
authored
252 (let ((binding-names (mapcar #'car default-bindings))
253 (binding-values (mapcar #'cdr default-bindings)))
254 (dotimes (i nthread wqueue)
255 (setf (aref threads i)
256 (%make-worker wqueue i binding-names binding-values))))))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
257
258 (defun stop (queue)
259 (declare (type queue queue))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
260 (setf (car (queue-state queue)) :done)
261 (condition-broadcast (queue-cvar queue))
693a555 Paul Khuong Thread pool diffs
authored
262 nil)
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
263
264 (defun alive-p (queue)
265 (declare (type queue queue))
266 (eql (car (queue-state queue)) :running))
267
9bf46f7 Paul Khuong Fix some uses of *current-queue* to go through function
authored
268 (defun enqueue (task &optional (queue (current-queue)))
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
269 (declare (type task-designator task)
270 (type queue queue))
a640810 Paul Khuong Fix a couple bugs and perf regression issues (?)
authored
271 (assert (and (alive-p queue) 'enqueue))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
272 (sb-queue:enqueue task (queue-queue queue))
273 (condition-broadcast (queue-cvar queue))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
274 nil)
275
9bf46f7 Paul Khuong Fix some uses of *current-queue* to go through function
authored
276 (defun enqueue-all (tasks &optional (queue (current-queue)))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
277 (declare (type queue queue))
a640810 Paul Khuong Fix a couple bugs and perf regression issues (?)
authored
278 (assert (and (alive-p queue) 'enqueue-all))
e28c720 Paul Khuong Eschew real locking over condvar in work queue; we have a lock-free queu...
authored
279 (let ((queue (queue-queue queue)))
280 (map nil (lambda (task)
281 (sb-queue:enqueue task queue))
282 tasks))
283 (condition-broadcast (queue-cvar queue))
4e01ed9 Paul Khuong Thread pool with recursive task generation
authored
284 nil)
693a555 Paul Khuong Thread pool diffs
authored
285
9bf46f7 Paul Khuong Fix some uses of *current-queue* to go through function
authored
286 (defun push-self (task &optional (queue (current-queue)))
693a555 Paul Khuong Thread pool diffs
authored
287 (declare (type queue queue)
08e8906 Paul Khuong Document thread-pool + tweak interface
authored
288 (type task-designator task))
a640810 Paul Khuong Fix a couple bugs and perf regression issues (?)
authored
289 (assert (and (alive-p queue) 'push-self))
693a555 Paul Khuong Thread pool diffs
authored
290 (let ((id *worker-id*))
291 (cond (id
292 (assert (eql (aref (queue-threads queue) id)
293 *current-thread*))
b6ca3dd Paul Khuong Track default hint for bulk tasks better in thread-pool; also name worke...
authored
294 (work-stack:push (aref (queue-stacks queue) id) task *worker-hint*))
693a555 Paul Khuong Thread pool diffs
authored
295 (t
606e16f Paul Khuong Fix internal usage of enqueue[-all], and make sure to reacquire locks as...
authored
296 (enqueue task queue)))))
693a555 Paul Khuong Thread pool diffs
authored
297
9bf46f7 Paul Khuong Fix some uses of *current-queue* to go through function
authored
298 (defun push-self-all (tasks &optional (queue (current-queue)))
693a555 Paul Khuong Thread pool diffs
authored
299 (declare (type queue queue))
a640810 Paul Khuong Fix a couple bugs and perf regression issues (?)
authored
300 (assert (and (alive-p queue) 'push-self-all))
693a555 Paul Khuong Thread pool diffs
authored
301 (let ((id *worker-id*))
302 (cond (id
303 (assert (eql (aref (queue-threads queue) id)
304 *current-thread*))
b6ca3dd Paul Khuong Track default hint for bulk tasks better in thread-pool; also name worke...
authored
305 (work-stack:push-all (aref (queue-stacks queue) id) tasks *worker-hint*))
693a555 Paul Khuong Thread pool diffs
authored
306 (t
606e16f Paul Khuong Fix internal usage of enqueue[-all], and make sure to reacquire locks as...
authored
307 (enqueue-all tasks queue)))))
Something went wrong with that request. Please try again.