Coverage report: /home/ellis/comp/core/std/par.lisp

Kind	Covered	All	%
expression	0	281	0.0
branch	0	20	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; par.lisp --- Parallelized versions of Common Lisp functions

2

3

;; Based on LPARALLEL cognates

4

5

;;; Commentary:

6

7

;; ref: https://github.com/lmj/lparallel

8

9

;;; Code:

10

(in-package :std/par)

11

12

;; TODO 2025-04-27:

13

;;; plet

14

(defconstant +no-result+ '+no-result+)

15

(defmacro msetq (vars form)

16

(if (= 1 (length vars))

17

`(setq ,(first vars) ,form)

18

`(multiple-value-setq ,vars ,form)))

19

20

(defun client-vars (binding-data)

21

(reduce #'append binding-data :key #'car))

22

23

(defun temp-vars (binding-data)

24

(reduce #'append binding-data :key #'cadr))

25

26

(defun primary-temp-vars (binding-data)

27

(loop for (nil temp-vars nil) in binding-data

28

collect (first temp-vars)))

29

30

(defmacro with-temp-bindings (here-binding-datum spawn-binding-data &body body)

31

`(let (,@(temp-vars (list here-binding-datum))

32

,@(loop for var in (temp-vars spawn-binding-data)

33

collect `(,var +no-result+)))

34

,@body))

35

36

(defmacro with-client-bindings (binding-data null-bindings &body body)

37

`(let (,@null-bindings

38

,@(mapcar #'list

39

(client-vars binding-data)

40

(temp-vars binding-data)))

41

,@body))

42

43

(defmacro spawn (kernel temp-vars form)

44

(check-type kernel symbol)

45

`(submit-raw-task

46

(make-task

47

(task-lambda

48

;; task handler already established

49

(unwind-protect (msetq ,temp-vars (with-task-context ,form))

50

(locally (declare (optimize (speed 3) (safety 0)))

51

(update-limiter-count (the kernel ,kernel) 1)))

52

(values)))

53

,kernel))

54

55

(defmacro spawn-tasks (kernel spawn-binding-data)

56

(check-type kernel symbol)

57

`(progn

58

,@(loop for (nil temp-vars form) in spawn-binding-data

59

collect `(spawn ,kernel ,temp-vars ,form))))

60

61

(defmacro exec-task (here-binding-datum)

62

(destructuring-bind (client-vars temp-vars form) here-binding-datum

63

(declare (ignore client-vars))

64

`(msetq ,temp-vars ,form)))

65

66

(defmacro sync (kernel spawn-binding-data)

67

(check-type kernel symbol)

68

;; reverse to check last spawn first

69

(let ((temp-vars (reverse (temp-vars spawn-binding-data))))

70

`(locally (declare (optimize (speed 3) (safety 3)))

71

(loop with worker = *worker*

72

while (or ,@(loop for temp-var in temp-vars

73

collect `(eq ,temp-var +no-result+)))

74

do #+lparallel.with-green-threads (thread-yield)

75

(steal-work (the kernel ,kernel) worker)))))

76

77

(defmacro scan-for-errors (binding-data)

78

;; a wrapped error would only appear as the primary return value

79

`(locally (declare (optimize (speed 3) (safety 3)))

80

,@(loop for temp-var in (primary-temp-vars binding-data)

81

collect `(when (typep ,temp-var 'wrapped-error)

82

(unwrap-result ,temp-var)))))

83

84

(defmacro %%%%plet (kernel bindings body)

85

(multiple-value-bind (binding-data null-bindings) (make-binding-data bindings)

86

(destructuring-bind

87

(here-binding-datum &rest spawn-binding-data) binding-data

88

`(with-temp-bindings ,here-binding-datum ,spawn-binding-data

89

(spawn-tasks ,kernel ,spawn-binding-data)

90

(exec-task ,here-binding-datum)

91

(sync ,kernel ,spawn-binding-data)

92

(scan-for-errors ,spawn-binding-data)

93

(with-client-bindings ,binding-data ,null-bindings

94

,@body)))))

95

96

(defmacro with-lock-predicates (&key lock predicate1 predicate2

97

succeed/lock succeed/no-lock fail)

98

(with-gensyms (top fail-tag)

99

`(block ,top

100

(tagbody

101

(when ,predicate1

102

(with-spin-lock-held (,lock)

103

(if ,predicate2

104

,succeed/lock

105

(go ,fail-tag)))

106

(return-from ,top ,succeed/no-lock))

107

,fail-tag

108

(return-from ,top ,fail)))))

109

110

(defmacro %%%plet (kernel predicate spawn-count bindings body)

111

;; Putting the body code into a shared dynamic-extent function

112

;; caused some slowdown, so reluctantly duplicate the body.

113

`(with-lock-predicates

114

:lock (limiter-lock (the kernel ,kernel))

115

:predicate1 ,predicate

116

:predicate2 (accept-task-p ,kernel)

117

:succeed/lock (update-limiter-count/no-lock ,kernel ,(- spawn-count))

118

:succeed/no-lock (%%%%plet ,kernel ,bindings ,body)

119

:fail (slet ,bindings ,@body)))

120

121

(defmacro %%plet (kernel predicate bindings body)

122

(let ((spawn-count (- (length (parse-bindings bindings)) 1)))

123

(if (plusp spawn-count)

124

`(%%%plet ,kernel ,predicate ,spawn-count ,bindings ,body)

125

`(slet ,bindings ,@body))))

126

127

(defmacro %plet (kernel bindings &body body)

128

`(%%plet ,kernel

129

(accept-task-p ,kernel)

130

,bindings

131

,body))

132

133

(defmacro %plet-if (kernel predicate bindings &body body)

134

`(%%plet ,kernel

135

(and (accept-task-p ,kernel) ,predicate)

136

,bindings

137

,body))

138

139

;;; Utils

140

(defun zip-vector (seqs)

141

"Return a vector containing zipped SEQS."

142

(apply #'map 'vector #'list seqs))

143

144

(defun find-min-length (seqs)

145

"Find and return the sequence of minimum length in SEQS."

146

(reduce #'min seqs :key #'length))

147

148

(defun subsize (seq size start end)

149

"Return the length of a subseq of SEQ with given SIZE, erroring if (START

150

. END) is a bad range."

151

(let ((ret (- (or end size) start)))

152

(when (or (minusp ret) (> ret size))

153

(error "Bad range for seq ~A: :start ~A :end ~A"

154

seq start end))

155

ret))

156

157

;;; Subdivide

158

(defun find-num-parts (size parts-hint)

159

(multiple-value-bind (quo rem) (floor size parts-hint)

160

(values (if (zerop quo) rem parts-hint) quo rem)))

161

162

(defmacro with-parts (seq-size parts-hint &body body)

163

(with-gensyms (quo rem index num-parts part-offset part-size)

164

`(multiple-value-bind

165

(,num-parts ,quo ,rem) (find-num-parts ,seq-size ,parts-hint)

166

(declare (fixnum ,num-parts ,quo ,rem))

167

(let ((,index 0)

168

(,part-offset 0)

169

(,part-size 0))

170

(declare (fixnum ,index ,part-offset ,part-size))

171

(flet ((next-part ()

172

(when (< ,index ,num-parts)

173

(unless (zerop ,index)

174

(incf ,part-offset ,part-size))

175

(setf ,part-size (if (< ,index ,rem) (1+ ,quo) ,quo))

176

(incf ,index)))

177

(part-size () ,part-size)

178

(part-offset () ,part-offset)

179

(num-parts () ,num-parts))

180

(declare (inline part-size part-offset num-parts)

181

(ignorable #'part-size #'part-offset #'num-parts))

182

,@body)))))

183

184

(defun subdivide-array (array size parts-hint)

185

(with-parts size parts-hint

186

(map-into (make-array (num-parts))

187

(lambda ()

188

(next-part)

189

(make-array (part-size)

190

:displaced-to array

191

:displaced-index-offset (part-offset)

192

:element-type (array-element-type array))))))

193

194

(defun subdivide-list (list size parts-hint)

195

(with-parts size parts-hint

196

(loop with p = list

197

while (next-part)

198

collect p

199

do (setf p (nthcdr (part-size) p)))))

200

201

(defun subdivide-list/slice (list size parts-hint)

202

(with-parts size parts-hint

203

(loop with p = list

204

while (next-part)

205

collect p into firsts

206

collect (prog1 (setf p (nthcdr (1- (part-size)) p))

207

(setf p (prog1 (cdr p) (setf (cdr p) nil)))) into lasts

208

finally (return (values firsts

209

(lambda ()

210

;; stitch it back together

211

(loop for last in lasts

212

for first in (cdr firsts)

213

do (setf (cdr last) first)

214

                                           finally (setf (cdr last) p))))))))

215

216

(defun make-parts (result size parts-hint &key slicep)

217

(if (listp result)

218

(funcall (if slicep #'subdivide-list/slice #'subdivide-list)

219

result size parts-hint)

220

(subdivide-array result size parts-hint)))

221

222

(defun make-result-parts (result size parts-hint)

223

"Subdivide the result sequence. For a list, delineate boundaries by slicing."

224

(make-parts result size parts-hint :slicep t))

225

226

(defun make-input-parts (sequences size parts-hint)

227

"Subdivide and interleave sequences for parallel mapping."

228

(zip-vector (mapcar (lambda (seq) (make-parts seq size parts-hint))

229

sequences)))

230

231

;;; Reduce

232

(defmacro with-preduce-context (size parts &body body)

233

(with-gensyms (results)

234

`(with-parts ,size ,parts

235

(let ((,results (make-array (num-parts))))

236

(with-submit-indexed (num-parts) ,results

237

,@body

238

(receive-indexed))))))

239

240

;;;; defpun

241

(defmacro defun/wrapper (wrapper-name impl-name lambda-list &body body)

242

(with-gensyms (args kernel)

243

(multiple-value-bind (wrapper-lambda-list expansion)

244

(if (intersection lambda-list lambda-list-keywords)

245

(values `(&rest ,args)

246

``(apply (function ,',impl-name) ,,kernel ,',args))

247

(values lambda-list

248

``(,',impl-name ,,kernel ,@',lambda-list)))

249

`(defun ,wrapper-name ,wrapper-lambda-list

250

(macrolet ((call-impl (,kernel) ,expansion))

251

,@body)))))

252

253

(defun call-with-toplevel-handler (fn)

254

(declare (optimize (speed 3) (safety 3)))

255

(declare (type function fn))

256

(let* ((results (multiple-value-list (std/thread::call-with-work-handler fn)))

257

(first (first results)))

258

(when (typep first 'std/condition:wrapped-error)

259

(std/thread::unwrap-result first))

260

(values-list results)))

261

262

(defun call-inside-worker (kernel fn)

263

(declare (optimize (speed 3) (safety 3)))

264

(declare (type function fn))

265

(let ((channel (let ((*kernel* kernel)) (make-instance 'channel))))

266

(std/thread::submit-work channel (lambda () (multiple-value-list (funcall fn))))

267

(values-list (std/thread::receive-result channel))))

268

269

(defun call-impl-fn (kernel impl)

270

(declare (optimize (speed 3) (safety 3)))

271

(declare (type function impl))

272

(if (or std/thread::*worker* (use-caller-p kernel))

273

(call-with-toplevel-handler impl)

274

(call-inside-worker kernel impl)))

275

276

(declaim (inline unsplice))

277

(defun unsplice (form)

278

(if form (list form) nil))

279

280

(defvar *registration-lock* (make-mutex :name "registration"))

281

282

(defmacro define-defpun (defpun doc defun &rest types)

283

`(defmacro ,defpun (name lambda-list ,@types &body body)

284

,doc

285

(with-parsed-body (body declares docstring)

286

(with-lock-held (*registration-lock*)

287

;; these two calls may affect the registered macrolets in the

288

;; return form below

289

(delete-stale-registrations)

290

(register-name name)

291

(with-gensyms (kernel)

292

`(progn

293

(,',defun ,(unchecked-name name) (,kernel ,@lambda-list)

294

,,@(unsplice (when types ``(kernel ,@,(first types))))

295

,,@(unsplice (when types (second types)))

296

,@declares

297

(declare (ignorable ,kernel))

298

(macrolet ((plet (bindings &body body)

299

`(%plet ,',kernel ,bindings ,@body))

300

(plet-if (predicate bindings &body body)

301

`(%plet-if ,',kernel ,predicate ,bindings ,@body))

302

,@(registered-macrolets kernel))

303

,@body))

304

(defun/wrapper ,name ,(unchecked-name name) ,lambda-list

305

,@(unsplice docstring)

306

(let ((,kernel (check-kernel)))

307

(call-impl-fn ,kernel (lambda () (call-impl ,kernel)))))

308

(eval-when (:load-toplevel :execute)

309

(with-lock-held (*registration-lock*)

310

(register-fn ',name)))

311

',name))))))

312

313

(define-defpun defpun

314

"`defpun' defines a function which is specially geared for

315

fine-grained parallelism. If you have many small tasks which bog down

316

the system, `defpun' may help.

317

318

The syntax of `defpun' matches that of `defun'. The difference is that

319

`plet' and `plet-if' take on new meaning inside `defpun'. The symbols

320

in the binding positions of `plet' and `plet-if' should be viewed as

321

lazily evaluated immutable references.

322

323

Inside a `defpun' form the name of the function being defined is a

324

macrolet, as are the names of other functions which were defined by

325

`defpun'. Thus using #' on them is an error. Calls to functions

326

defined by `defpun' entail more overhead when the caller lies outside

327

a `defpun' form.

328

329

A `defpun' function must exist before it is referenced inside another

330

`defpun' function. If this is not possible--for example if func1 and

331

func2 reference each other--then use `declaim-defpun' to specify

332

intent:

333

334

(declaim-defpun func1 func2)

335

"

336

defun)

337

338

(define-defpun defpun*

339

"Typed version of DEFPUN.

340

341

ARG-TYPES is an unevaluated list of argument types.

342

343

RETURN-TYPE is an unevaluated form of the return type, possibly indicating

344

multiple values as in (values fixnum float).

345

346

(As a technical point, if RETURN-TYPE contains no lambda list keywords then

347

the return type given to ftype will be additionally constrained to match the

348

number of return values specified.)"

349

defun*

350

arg-types

351

return-type)