Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 207 lines (189 sloc) 7.924 kb
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
1 (defpackage "PARALLEL"
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
2 (:use)
3 (:export "PROMISE" "PROMISE-VALUE" "LET"
4 "FUTURE" "FUTURE-VALUE" "BIND"
5 "DOTIMES" "MAP" "REDUCE"))
6
7 (defpackage "PARALLEL-IMPL"
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
8 (:use "CL")
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
9 (:import-from "PARALLEL" "PROMISE" "PROMISE-VALUE"
10 "FUTURE" "FUTURE-VALUE"))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
11
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
12 (in-package "PARALLEL-IMPL")
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
13
14 (deftype status ()
15 `(member :waiting :done))
16
17 (defstruct (promise
18 (:constructor make-promise (function))
19 (:include work-stack:task))
20 %values
21 (%status :waiting :type (or status promise-slow-status)))
22
23 (status:define-status-type promise-slow-status
24 (:fast-type promise
25 :status-type status
26 :default-status :waiting
27 :final-states (:done))
28 promise-%status
29 promise-status
30 %promise-wait
31 %promise-upgrade)
32
33 (defun promise (thunk &rest args)
34 (work-queue:push-self
35 (make-promise (lambda (promise)
36 (declare (type promise promise))
37 (setf (promise-%values promise)
38 (multiple-value-list (apply thunk args)))
1ec0d76d »
2011-12-19 More bugfixes in parallel primitives
39 (%promise-upgrade promise :done :waiting)))
40 parallel-future:*context*))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
41
42 (defun promise-value (promise)
43 (declare (type promise promise))
44 (when (work-queue:worker-id)
45 (work-queue:progress-until
46 (lambda ()
47 (eql :done (promise-status promise)))))
48 (%promise-wait promise :done)
49 (values-list (promise-%values promise)))
50
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
51 (defmacro parallel:let ((&rest bindings) &body body)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
52 (let ((temporaries (loop for (name value) in bindings
53 collect `(,(gensym "PROMISE") (promise (lambda ()
54 ,value))))))
55 `(let* (,@temporaries
56 ,@(loop for (name) in bindings
57 for (temp) in temporaries
58 collect `(,name (promise-value ,temp))))
59 ,@body)))
60
61 (defstruct (future
62 (:include parallel-future:future))
63 %values)
64
65 (defun call-with-future-values (function futures)
66 (declare (type simple-vector futures))
67 (apply function (map 'list (lambda (x)
68 (if (future-p x)
69 (future-value x)
70 x))
71 futures)))
72
73 (defun future (dependencies callback &key subtasks cleanup)
74 (declare (type simple-vector dependencies)
75 (type (or null simple-vector) subtasks))
76 (let ((future (parallel-future:make
77 (remove-if-not #'future-p dependencies)
78 (lambda (self)
79 (setf (future-%values self)
4e37a993 »
2011-12-19 Again
80 (multiple-value-list
81 (call-with-future-values
82 callback dependencies))))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
83 (or subtasks #())
84 (and cleanup
85 (lambda (self)
86 (setf (future-%values self)
4e37a993 »
2011-12-19 Again
87 (multiple-value-list
88 (call-with-future-values
89 cleanup dependencies)))))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
90 #'make-future)))
1ec0d76d »
2011-12-19 More bugfixes in parallel primitives
91 (work-queue:push-self future parallel-future:*context*)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
92 future))
93
94 (defun future-value (future)
95 (declare (type future future))
96 (when (work-queue:worker-id)
97 (work-queue:progress-until (lambda ()
98 (eql (future:status future) :done))))
99 (future:wait future :done)
100 (values-list (future-%values future)))
101
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
102 (defmacro parallel:bind ((&rest bindings)
103 &body body)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
104 (let ((wait nil))
105 (when (eql :wait (car body))
106 (setf wait t)
107 (pop body))
108 `(,(if wait 'future-value 'identity)
109 (future (vector ,@(mapcar #'second bindings))
110 (lambda ,@(mapcar #'first bindings)
111 ,@body)))))
112
113 (defun %call-n-times (count function cleanup)
114 (let ((future
115 (parallel-future:make
116 #()
117 nil
118 (make-array count :initial-element 0)
119 (and cleanup
120 (lambda (self)
121 (setf (future-%values self)
4e37a993 »
2011-12-19 Again
122 (multiple-value-list (funcall cleanup)))))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
123 #'make-future
124 :%values '(nil)
125 :subtask-function (lambda (subtask self index)
126 (declare (ignore subtask self))
127 (funcall function index)))))
1ec0d76d »
2011-12-19 More bugfixes in parallel primitives
128 (work-queue:push-self future parallel-future:*context*)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
129 future))
130
131 (defun call-n-times (count function aggregate-function &optional cleanup)
1ec0d76d »
2011-12-19 More bugfixes in parallel primitives
132 (let* ((worker-count (or (work-queue:worker-count parallel-future:*context*)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
133 (error "No current queue")))
134 (max (expt worker-count 2)))
135 (if (<= count max)
136 (%call-n-times count function cleanup)
137 (let ((step (truncate count max)))
138 (%call-n-times (ceiling count step)
139 (lambda (i)
140 (let* ((begin (* i step))
141 (end (min (+ begin step) count)))
142 (funcall aggregate-function begin end)))
143 cleanup)))))
144
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
145 (defmacro parallel:dotimes ((var count &optional result) &body body)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
146 (let ((begin (gensym "BEGIN"))
147 (end (gensym "END"))
148 (i (gensym "I"))
149 (wait nil)
150 (tid (gensym "TID")))
151 (when (eql (car body) :wait)
152 (setf wait t)
153 (pop body))
154 `(,(if wait 'future-value 'identity)
155 (call-n-times ,count
156 (lambda (,var)
157 ,@body)
158 (lambda (,begin ,end &aux (,tid (work-queue:worker-id)))
159 (declare (type fixnum ,begin ,end ,tid))
160 (flet ((work-queue:worker-id ()
161 ,tid))
162 (declare (inline work-queue:worker-id)
163 (ignorable #'work-queue:worker-id))
164 (loop for ,i of-type fixnum from ,begin below ,end
165 do
166 (let ((,var ,i))
167 ,@body))))
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
168 ,(and result
169 `(lambda ()
170 (let ((,var nil))
171 (declare (ignorable ,var))
172 (progn ,result))))))))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
173
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
174 (defun parallel:map (type function arg &key (wait t))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
175 (let* ((arg (coerce arg 'simple-vector))
176 (function (if (functionp function)
177 function
178 (fdefinition function)))
179 (future (if (eql nil type)
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
180 (parallel:dotimes (i (length arg))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
181 (funcall function (aref arg i)))
182 (let ((destination (make-array (length arg))))
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
183 (parallel:dotimes (i (length arg) (coerce destination type))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
184 (setf (aref destination i)
185 (funcall function (aref arg i))))))))
186 (if wait
187 (future-value future)
188 future)))
189
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
190 (defun parallel:reduce (function arg seed &key (wait t))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
191 (let* ((arg (coerce arg 'simple-vector))
192 (function (if (functionp function)
193 function
194 (fdefinition function)))
1ec0d76d »
2011-12-19 More bugfixes in parallel primitives
195 (accumulators (make-array (work-queue:worker-count parallel-future:*context*)
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
196 :initial-element seed))
5b6b0008 »
2011-12-19 Bug fixes in parallel primitives, and split package/definition packag…
197 (future (parallel:dotimes (i (length arg)
198 (reduce function accumulators
199 :initial-value seed))
45baa1af »
2011-12-19 Generic parallel programming primitives; not used here, but so easy
200 (let ((idx (work-queue:worker-id)))
201 (setf (aref accumulators idx)
202 (funcall function
203 (aref accumulators idx)
204 (aref arg i)))))))
205 (if wait
206 (future-value future)
207 future)))
Something went wrong with that request. Please try again.