Coverage report: /development/source/library/org/datagraph/spocq-shard/src/algebra/matrix-operators/matrix.lisp

Kind	Covered	All	%
expression	0	632	0.0
branch	0	70	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

(:documentation "construction, declaration, and access operators for matrix fields"

6

)

7

8

 ;;; (load (compile-file "/development/source/library/org/datagraph/spocq/src/algebra/matrix-operators/matrix.lisp"))

9

10

(defparameter *matrix-operators* (make-solution-cache :single-thread nil)

11

"a thread-safe cache for matrix operator function definitions.")

12

13

(defparameter *save-matrix-operator-definitions* t

14

   "when true, save the matrix operator lambda form as the LAMBDA property of the generated function name.")

15

16

(defun matrix-dimension-error (&key matrix expected-dimensions)

17

(error "matrix expected dimensions not present: ~s: ~s" expected-dimensions matrix))

18

19

20

21

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

22

(defun constant-dimensions-p (object)

23

(and (consp object)

24

(every #'(lambda (object) (typep object '(or fixnum null))) object)))

25

26

(defun quote-form-p (form)

27

(and (consp form) (eq (first form) 'quote)))

28

29

(defun pointer-not-lessp (p1 p2)

30

(>= (cffi:pointer-address p1) (cffi:pointer-address p2)))

31

32

(defun sort-order-equal (left-order right-order)

33

"return true iff all dimensions which appear in both orders are in the same absolute position."

34

(or (null left-order)

35

(null right-order)

36

(and (eq (first left-order) (first right-order))

37

(sort-order-equal (rest left-order) (rest right-order)))))

38

39

(defun sort-order-covers (prospective-order required-dimensions)

40

"return true iff all dimensions in the required order are present in the prospective without

41

regard to position."

42

(null (set-difference required-dimensions prospective-order)))

43

;; (sort-order-covers '(a s) '(s))

44

;; (sort-order-covers '(a s) '(s a))

45

;; (sort-order-covers '(a s) '(s d))

46

47

)

48

49

50

51

52

53

;;; matrix operator caching

54

;;; use the operator parameters

55

56

(defgeneric compute-matrix-operator-lambda (operator-name &rest specifications)

57

(:documentation "compute the lambda form which perfoems the named matrix operation

58

given the respetive specification for the field dimensions."))

59

60

(defparameter *last-matrix-operator-lambda* nil)

61

62

(defun ensure-matrix-operator (operator-name &rest arguments)

63

(declare (dynamic-extent arguments))

64

(let ((dynamic-key (cons operator-name arguments)))

65

(declare (dynamic-extent dynamic-key))

66

(or (and *matrix-operators*

67

(gethash dynamic-key *matrix-operators*))

68

(let ((function-name (gensym (string operator-name)))

69

(static-key (cons operator-name (copy-list arguments))))

70

(setf (symbol-value function-name) static-key)

71

(multiple-value-bind (function lambda)

72

                                (apply #'compute-matrix-operator operator-name arguments)

73

(setq *last-matrix-operator-lambda* lambda)

74

(setf (symbol-function function-name) function)

75

(when *save-matrix-operator-definitions*

76

(setf (get function-name 'lambda) lambda))

77

(when *matrix-operators*

78

(setcache static-key *matrix-operators* function-name))

79

function-name)))))

80

81

82

(defun compute-matrix-operator (name &rest arguments)

83

(declare (dynamic-extent arguments))

84

(let ((lambda (apply #'compute-matrix-operator-lambda name arguments)))

85

(values (spocq-compile lambda)

86

lambda)))

87

88

#|

89

(defun format-name (tag &rest args)

90

(declare (dynamic-extent args)

91

(optimize (speed 3) (safety 0)))

92

(let* ((name (substitute #\_ #\space (format nil "~a~{ ~a~}" tag args)))

93

(symbol (intern name :cl-user)))

94

(fboundp symbol)))

95

96

(defparameter *m-cache* (make-hash-table :test 'equal))

97

(defun list-name (tag &rest args)

98

(let ((name (cons tag args)))

99

(or (gethash name *m-cache*)

100

(setf (gethash name *m-cache*) t))))

101

102

(defparameter *g-cache* (make-hash-table :test 'equal))

103

(defun gen-name (tag &rest args)

104

(declare (dynamic-extent args))

105

(let ((key (cons tag args)))

106

(declare (dynamic-extent key))

107

(or (gethash key *g-cache*)

108

(let ((name (gensym (string tag)))

109

(static-key (cons tag args)))

110

(setf (symbol-value name) static-key)

111

(setf (symbol-function name) #'identity)

112

(setf (gethash static-key *g-cache*) name)))))

113

114

(time (dotimes (x 10000) (make-name 'tag :value x))) ==> 0.063 / 0.047

115

(time (dotimes (x 10000) (list-name 'tag :value x))) ==> 0.004 / 0.003

116

(time (dotimes (x 10000) (gen-name 'tag :value x))) ==> 0.022 / 0.004 which is ok

117

118

|#

119

120

;;; solution field operators

121

122

(defgeneric new-field-row (field)

123

(:documentation "return the location to write a 'new' solution into the given field.

124

FIELD : solution-field

125

VALUES : data : (or array foreign-array) : locates the base of the solution field page

126

row : fixnum : index into the data array for the new solution

127

128

when the field is a streamed field, the data is a pointer to a possibly new page,

129

with completed pages passed to a destination and replaced.")

130

131

(:method ((field matrix-field))

132

(let ((%data (matrix-field-data field)))

133

(when (cffi:null-pointer-p %data)

134

(initialize-result-field field)

135

(setf %data (matrix-field-data field)))

136

(let ((row-index (matrix-field-row-index field)))

137

(when (>= row-index (matrix-field-row-count field))

138

(let ((new-row-count (+ row-index *matrix-fold-length*))

139

(%matrix (matrix-field-solutions field))

140

(limit (matrix-field-row-count-limit field)))

141

(cond ((and limit (> new-row-count limit))

142

;; stream the page and replace it

143

                    (mqueue:send-message (matrix-field-channel field) %matrix (cffi:foreign-type-size :pointer))

144

(setf %matrix

145

(setf (matrix-field-solutions field)

146

                                (rdfcache:make-matrix *matrix-fold-length* (length (solution-field-dimensions field)))))

147

(finalize-matrix-field-solutions field %matrix)

148

(setf new-row-count *matrix-fold-length*

149

row-index 0))

150

(t

151

                    (rdfcache:matrix-resize %matrix new-row-count (length (matrix-field-dimensions field)))))

152

(incf (solution-field-length field) *matrix-fold-length*)

153

(setf (matrix-field-row-count field) new-row-count)

154

(setf %data (setf (matrix-field-data field) (rdfcache:matrix-data-pointer %matrix)))))

155

(setf (matrix-field-row-index field) (1+ row-index))

156

(values %data row-index field)))))

157

158

159

(defmethod new-field-data ((field matrix-field))

160

(let ((old-row-count (solution-field-row-count field)))

161

(cond ((zerop old-row-count)

162

(initialize-solution-field field :row-count *matrix-fold-length*)

163

(values (rdfcache:matrix-data-pointer (matrix-field-solutions field))

164

*matrix-fold-length*

165

0))

166

(t

167

(let ((new-row-count (+ old-row-count *matrix-fold-length*))

168

(solutions (matrix-field-solutions field)))

169

(rdfcache:matrix-resize solutions new-row-count)

170

(setf (solution-field-length field) new-row-count)

171

(values (rdfcache:matrix-data-pointer solutions)

172

new-row-count

173

old-row-count))))))

174

175

176

(defgeneric current-field-row (field)

177

(:method ((field matrix-field))

178

(values (matrix-field-data field) (matrix-field-row-index field))))

179

180

181

(defun first-field-row (field)

182

(setf (solution-field-row-index field) 0)

183

(next-field-row field))

184

185

(defgeneric next-field-row (field)

186

(:documentation "provide the location for the next soution row for the given field.

187

FIELD : solution-field

188

VALUES : data : (or array foreign-array) : locates the base of the solution field page

189

row : fixnum : index into the data array for the next solution

190

when the field is a matrix field, the data is either a pointer to a possibly new page,

191

with replacements retrieved from the a source channel, or it is a null pointer when

192

the source is exhausted.

193

when the field is a page channel, the data is either an array or null.

194

the row is either an index into the returned page or -1 when the source is exhausted.")

195

196

(:method ((field matrix-field))

197

(let ((%data (matrix-field-data field))

198

(row (matrix-field-row-index field)))

199

(flet ((next-field-data-row ()

200

(if (cffi:null-pointer-p (next-field-data field))

201

(values (cffi:null-pointer) -1)

202

(values (matrix-field-data field)

203

                          (shiftf (matrix-field-row-index field) (1+ (matrix-field-row-index field)))))))

204

(cond ((cffi:null-pointer-p %data)

205

(next-field-data-row))

206

((>= row (matrix-field-row-count field))

207

(next-field-data-row))

208

(t

209

(setf (matrix-field-row-index field) (1+ row))

210

(values %data row)))))))

211

212

213

(defmethod next-field-data ((field matrix-field))

214

(let ((channel (matrix-field-channel field)))

215

(cond ((plusp channel)

216

(cffi:with-foreign-pointer (%matrix-handle (cffi:foreign-type-size :pointer))

217

(mqueue:receive-message channel %matrix-handle (cffi:foreign-type-size :pointer))

218

(let ((%matrix (cffi:mem-ref %matrix-handle :pointer)))

219

(setf (solution-field-solutions field) %matrix)

220

(cond ((cffi:null-pointer-p %matrix)

221

;; leave the matrix reference intakt to be released later

222

(setf (matrix-field-channel field) -1

223

(matrix-field-row-count field) 0

224

(matrix-field-row-index field) -1)

225

(setf (matrix-field-data field) (cffi:null-pointer)))

226

(t

227

;; swap the matrices if there is a replacement

228

(rdfcache:matrix-release (solution-field-solutions field))

229

(setf (solution-field-solutions field) %matrix)

230

(incf (matrix-field-length field) (matrix-field-row-count field))

231

                       (setf (matrix-field-row-count field) (rdfcache:matrix-row-count %matrix)

232

(matrix-field-row-index field) 0)

233

                       (setf (matrix-field-data field) (rdfcache:matrix-data-pointer %matrix)))))))

234

235

(t

236

;; leave the matrix reference intakt to be released later

237

(values (setf (matrix-field-data field) (cffi:null-pointer))

238

(setf (matrix-field-row-index field) -1))))))

239

240

241

242

243

244

(defmethod put-field-data ((field matrix-field))

245

;; for a static field, do nothing

246

nil)

247

248

(defgeneric complete-field-data (field)

249

(:method ((field matrix-field))

250

"complete additions to a stationary field by resizing the data array to the given row count."

251

(ecase (solution-field-state field)

252

(:closed)

253

(:input

254

(log-warn "invalid completion state: ~s" field))

255

(:output

256

(setf (solution-field-state field) :closed)

257

(let ((%matrix (solution-field-solutions field))

258

(index (solution-field-row-index field)))

259

(cond ((cffi:null-pointer-p %matrix)

260

(setf (solution-field-row-count field) 0

261

(solution-field-length field) 0

262

(matrix-field-data field) (cffi:null-pointer)))

263

(t

264

(if (= index (rdfcache:matrix-row-count %matrix))

265

(setf (solution-field-row-count field) (rdfcache:matrix-row-count %matrix))

266

(let ((delta (- (matrix-field-row-count field) index)))

267

;; truncate the data to the used rows

268

(rdfcache:matrix-resize %matrix index)

269

(setf (matrix-field-row-count field) index)

270

(decf (solution-field-length field) delta)))

271

(setf (matrix-field-data field) (rdfcache:matrix-data-pointer %matrix)

272

(solution-field-length field) (solution-field-row-count field))

273

(setf (matrix-field-data field) (rdfcache:matrix-data-pointer %matrix))))

274

;; reset the index to 0 for the expected use as a combination argument

275

(setf (solution-field-row-index field) 0)

276

(let ((channel (matrix-field-channel field)))

277

(when (plusp channel)

278

(unless (cffi:null-pointer-p %matrix)

279

(mqueue:send-message channel %matrix (cffi:foreign-type-size :pointer)))

280

(mqueue:send-message channel (cffi:null-pointer) (cffi:foreign-type-size :pointer))))

281

(trace-matrix "~&complete-field-data: ~a [~s [~s]] to ~s,~s,~s"

282

field %matrix (matrix-field-data field)

283

(solution-field-row-index field)

284

(solution-field-row-count field)

285

(solution-field-length field)))))

286

(values field (solution-field-state field))))

287

288

(defmacro next-source-row (field %base-pointer count row)

289

`(if (>= (incf ,row) ,count)

290

      (unless (or (cffi:null-pointer-p (multiple-value-setq (,%base-pointer ,count) (get-field-data ,field)))

291

(zerop ,count))

292

(setf ,row 0))

293

,row))

294

295

(defmacro next-result-row (field %base-pointer count row)

296

`(progn (incf ,row)

297

(trace-matrix "~&next result: ~s/~s" ,row ,count)

298

(when (>= ,row ,count)

299

(put-field-data ,field)

300

(multiple-value-setq (,%base-pointer ,count ,row) (new-field-data ,field))

301

(trace-matrix "~&next result new data: ~s ~s/~s" ,%base-pointer ,row ,count))))

302

303

304

;;; nb. these must be defined as macros as there must be a forign array declaration visible in

305

;;; the lexical context in order to compile the foreign-array-ref operations

306

307

 (defmacro combine-foreign-solutions ((result result-row) (left left-row) (right right-row) left-projection right-projection)

308

   (macroexpand-combine-foreign-solutions result result-row left left-row right right-row left-projection right-projection))

309

310

 (defun macroexpand-combine-foreign-solutions (result result-row left left-row right right-row left-projection right-projection)

311

(when (quote-form-p left-projection) (setf left-projection (second left-projection)))

312

(when (quote-form-p right-projection) (setf right-projection (second right-projection)))

313

(flet ((combine (result source result-row source-row result-position source-position)

314

`(setf (foreign-array-ref ,result ,result-row ,result-position)

315

(foreign-array-ref ,source ,source-row ,source-position))))

316

`(progn

317

,@(loop for source-position from 0

318

for result-position in left-projection

319

when result-position

320

                collect (combine result left result-row left-row result-position source-position))

321

,@(loop for source-position from 0

322

for result-position in right-projection

323

when (and result-position (not (member result-position left-projection)))

324

                collect (combine result right result-row right-row result-position source-position)))))

325

326

327

(defmacro compare-foreign-solutions ((left left-row) (right right-row) left-key right-key)

328

(macroexpand-compare-foreign-solutions left left-row right right-row left-key right-key))

329

330

(defun macroexpand-compare-foreign-solutions (left left-row right right-row left-key right-key)

331

(when (quote-form-p left-key) (setf left-key (second left-key)))

332

(when (quote-form-p right-key) (setf right-key (second right-key)))

333

(labels ((compare (left-key right-key)

334

(if left-key

335

(let ((left-position (first left-key))

336

(right-position (first right-key)))

337

(if (and left-position right-position)

338

`(let ((left (foreign-array-ref ,left ,left-row ,left-position))

339

(right (foreign-array-ref ,right ,right-row ,right-position)))

340

(declare (type term-number left right)

341

(dynamic-extent left right))

342

(if (= left right)

343

,(compare (rest left-key) (rest right-key))

344

(if (< left right) -1 1)))

345

(compare (rest left-key) (rest right-key))))

346

0)))

347

(compare left-key right-key)))

348

349

350

(defmacro move-foreign-solution (result source)

351

`(project-foreign-solution ,result ,source nil))

352

353

 (defmacro project-foreign-solution ((result result-row) (source source-row) &optional projection &environment env)

354

"generate a form to copy a source to a destination solution given

355

the source and destination base pointers and row numbers. where the projection is an

356

identity, reduce the operation to a byte move of the ddefined width."

357

(macroexpand-project-foreign-solution result result-row source source-row projection env))

358

359

(defun macroexpand-project-foreign-solution (result result-row source source-row projection environment)

360

(when (quote-form-p projection) (setf projection (second projection)))

361

(if (null projection)

362

;; implement the identity projection as a byte vector copy

363

(let ((result-declaration (foreign-type-declaration result environment))

364

(source-declaration (foreign-type-declaration source environment)))

365

(assert (typep result-declaration '(cons (eql foreign-array))) ()

366

               "variable not declared to be a foreign array: ~s . ~s." result result-declaration)

367

(assert (typep source-declaration '(cons (eql foreign-array))) ()

368

               "variable not declared to be a foreign array: ~s . ~s." source source-declaration)

369

;; the restriction would prevent a union with a unit table

370

#+(or)

371

(assert (equal source-declaration result-declaration) ()

372

"source and destination fields not equivalent: ~s . ~s; ~s . ~s"

373

result result-declaration source source-declaration)

374

(if (equal source-declaration result-declaration)

375

(destructuring-bind (type element-type dimensions) source-declaration

376

(declare (ignore type))

377

           (let ((source-solution-index `(* +matrix-element-size+ ,(array-row-major-index-form dimensions source-row 0)))

378

                 (result-solution-index `(* +matrix-element-size+ ,(array-row-major-index-form dimensions result-row 0)))

379

                 (byte-count (apply #'* (cffi:foreign-type-size element-type) (rest dimensions))))

380

`(let ((result (sb-sys:sap+ ,result ,result-solution-index))

381

(source (sb-sys:sap+ ,source ,source-solution-index)))

382

(declare (type sb-sys:system-area-pointer result source)

383

(dynamic-extent result source))

384

(rdfcache::%%memcpy result source ,byte-count))))

385

;; in the table case, there is nothing to project, just avoid a warning

386

`(progn ,result ,result-row ,source ,source-row 0)))

387

(flet ((move (result source result-row source-row result-position source-position)

388

`(setf (foreign-array-ref ,result ,result-row ,result-position)

389

(foreign-array-ref ,source ,source-row ,source-position))))

390

`(progn

391

          (trace-matrix "~&pfs ~@{~a ~}" :result ,result :source ,source :result-row ,result-row :source-row ,source-row :projection ',projection)

392

,@(loop for source-position from 0

393

for result-position in projection

394

when result-position

395

                  collect (move result source result-row source-row result-position source-position))))))

396

397

398

(defmacro compare-foreign-cache (cache (base base-row) projection)

399

(when (quote-form-p projection) (setf projection (second projection)))

400

(macroexpand-compare-foreign-cache cache base base-row projection))

401

#+(or)

402

(defmacro compare-foreign-cache (cache (base base-row) projection)

403

(when (quote-form-p projection) (setf projection (second projection)))

404

(let ((expansion (macroexpand-compare-foreign-cache cache base base-row projection)))

405

(if *matrix-trace-output*

406

`(let ((result ,expansion)

407

              (cache (loop for i from 0 upto ,(reduce #'max projection) collect (foreign-array-ref ,cache 0 i)))

408

              (base (loop for i from 0 below ,(length projection) collect (foreign-array-ref ,base ,base-row i))))

409

          (trace-matrix "cfc: ~@{~a ~}" :cache ,cache cache :base ,base base :base-row ,base-row := result)

410

result)

411

expansion)))

412

413

414

(defun macroexpand-compare-foreign-cache (cache base base-row projection)

415

(labels ((compare (projection base-position)

416

(if projection

417

(let ((cache-position (first projection)))

418

(if cache-position

419

`(let ((cache-term (foreign-array-ref ,cache 0 ,cache-position))

420

                           (base-term (foreign-array-ref ,base ,base-row ,base-position)))

421

(declare (type term-number cache-term base-term)

422

(dynamic-extent cache-term base-term))

423

(if (= cache-term base-term)

424

,(compare (rest projection) (1+ base-position))

425

(if (< cache-term base-term) -1 1)))

426

(compare (rest projection) (1+ base-position))))

427

0)))

428

(compare projection 0)))

429

430

#+(or)

431

(defun macroexpand-compare-foreign-cache (cache base base-row projection)

432

(labels ((compare (projection base-position)

433

(if projection

434

(let ((cache-position (first projection)))

435

(if cache-position

436

`(let ((cache-term (foreign-array-ref ,cache 0 ,cache-position))

437

                           (base-term (foreign-array-ref ,base ,base-row ,base-position)))

438

(declare (type term-number cache-term base-term)

439

(dynamic-extent cache-term base-term))

440

,@(when *matrix-trace-output*

441

                           `((format *matrix-trace-output* "cfc.~a.~a = ~a.~a" ,cache-position ,base-position cache-term base-term)))

442

(if (= cache-term base-term)

443

,(compare (rest projection) (1+ base-position))

444

(if (< cache-term base-term) -1 1)))

445

(compare (rest projection) (1+ base-position))))

446

0)))

447

(compare projection 0)))

448

449

450

#|

451

;;; deprecated in favor of the setf form

452

;;; plus, the accessor needs to be specific to matrix element type

453

(defun set-array-term (pointer offset value) (break "set")

454

(sb-kernel:%set-signed-sap-ref-64 pointer offset value))

455

456

(defmacro foreign-array-set (pointer-variable value &rest subscripts &environment env)

457

"rewrite the multi-dimensional foreign array modification to a foreign vector modification given the

458

base pointer and the subscripts.

459

nb. not a setf as the setf expander interposes intermediate bindings."

460

(macroexpand-foreign-array-set pointer-variable value subscripts env))

461

462

(defun macroexpand-foreign-array-set (pointer-variable value subscripts env)

463

(let ((declaration (foreign-type-declaration pointer-variable env)))

464

(assert (typep declaration '(cons (eql foreign-array))) ()

465

             "variable not declared to be a foreign array: ~s : ~s" pointer-variable declaration)

466

467

(destructuring-bind (type element-type dimensions) declaration

468

(declare (ignore type))

469

`(setf (,+matrix-accessor+ (the sb-sys:system-area-pointer ,pointer-variable)

470

                                        (the fixnum (* ,(cffi:foreign-type-size element-type)

471

                                                       ,(apply #'array-row-major-index-form dimensions subscripts))))

472

,value))))

473

474

|#

475

476

477

(defun reconcile-field-order (left-field right-field &rest args &key symmetrical materialize)

478

"given two fields, an indication if one side is primary (t nil) and

479

  an indication which side must be materialized (nil :left :right :both), ensure that the two fields are

480

sorted according to the same key with respect to shared fields."

481

(declare (ignore symmetrical materialize))

482

483

(apply #'perform-reconcile-field-order-steps

484

left-field right-field

485

(apply #'compute-reconcile-field-order-steps

486

left-field right-field

487

args)))

488

489

490

(defun compute-reconcile-field-order-steps (left-field right-field)

491

;; nb. when the direct result of a bgp pattern match, the dimension list is not lexicographically

492

;; sorted and will contain NIL in the positions where the pattern had a constant term.

493

;; the consequence is, the left and right key dimsnions need not be in the same order

494

(when *matrix-trace-output*

495

(format *matrix-trace-output* "~&to sort:~% ~s.~s~% x~% ~s.~s~%"

496

(solution-field-dimensions left-field)

497

(solution-field-sort-dimensions left-field)

498

(solution-field-dimensions right-field)

499

(solution-field-sort-dimensions right-field)))

500

501

(let* ((operations ())

502

(left-dimensions (solution-field-dimensions left-field))

503

(right-dimensions (solution-field-dimensions right-field))

504

(left-key-dimensions (join-key-dimensions left-dimensions right-dimensions))

505

(right-key-dimensions (join-key-dimensions right-dimensions left-dimensions))

506

(left-sort-order (solution-field-sort-dimensions left-field))

507

(right-sort-order (solution-field-sort-dimensions right-field))

508

(left-join-sort-order (join-key-dimensions left-sort-order right-sort-order))

509

(right-join-sort-order (join-key-dimensions right-sort-order left-sort-order)))

510

#+(or) (print-lexical-frame)

511

(flet ((record-steps (&rest args)

512

(setf operations (append operations args))))

513

;; arrange to sort

514

;; reordering requires that some field is shared

515

(when left-key-dimensions

516

(if (and left-sort-order (sort-order-covers left-sort-order left-key-dimensions))

517

(if (and right-sort-order (sort-order-covers right-sort-order right-key-dimensions))

518

;; if both cover, then test if they are equal and if so, just materialize.

519

;; otherwise, if one side is primary, sort that to agree with the other

520

;; otherwise, sort the materialized side, or if none is, then the narrowest

521

(if (sort-order-equal left-sort-order right-sort-order)

522

;; return the common sort order

523

(record-steps :order (join-dimensions left-sort-order right-sort-order))

524

;; otherwise, sort the one which is not already sufficiently

525

(if (sort-order-equal left-sort-order left-join-sort-order)

526

(record-steps :order left-join-sort-order :sort :right)

527

(record-steps :order right-join-sort-order :sort :left)))

528

;; if just the left covers, sort the right to the left order

529

(record-steps :order (join-dimensions left-sort-order right-dimensions)

530

:sort :right))

531

(if (and right-sort-order (sort-order-covers right-sort-order right-key-dimensions))

532

;; if just the right covers, sort the left to the right order

533

(record-steps :order (join-dimensions right-sort-order left-dimensions)

534

:sort :left)

535

;; otherwise, neither order covers, sort both to the shared key

536

(record-steps :order (join-dimensions right-dimensions left-dimensions)

537

:sort :left

538

:sort :right))))

539

operations)))

540

541

542

(defun perform-reconcile-field-order-steps (left right &rest operations)

543

(flet ((side (side)

544

(ecase side

545

(:left left)

546

(:right right))))

547

(let ((order ()))

548

(loop (ecase (pop operations)

549

((nil) (return))

550

(:order (setf order (pop operations)))

551

(:sort (solution-field-sort (side (pop operations)) order))))

552

(values left right order))))

553

554

#|

555

(defun run-compute-reconcile-field-order-steps (left-dimensions right-dimensions materialize symmetrical)

556

   (compute-reconcile-field-order-steps (make-solution-field :dimensions left-dimensions :sort-dimensions left-dimensions)

557

                                                        (make-solution-field :dimensions right-dimensions :sort-dimensions right-dimensions)

558

                                                        :materialize materialize :symmetrical symmetrical))

559

560

(dolist (left-dimensions '((a) (a b) (b a)))

561

(dolist (right-dimensions '((a) (b) (a x b)))

562

(dolist (materialize '(nil :left :right :both))

563

(dolist (symmetrical '(t nil))

564

(let ((*print-pretty* nil))

565

(format *trace-output* "~&~%~s -> ~%~s"

566

(list left-dimensions right-dimensions materialize symmetrical)

567

                   (run-compute-reconcile-field-order-steps left-dimensions right-dimensions materialize symmetrical)))))))

568

(trace sort-order-covers join-dimensions sort-order-equal)

569

(run-compute-reconcile-field-order-steps '(a b) '(b) :right t)

570

(run-compute-reconcile-field-order-steps '(a b) '(b) :left t)

571

|#

572

573

(defun matrix-bindings-operator (base-dimensions bindings)

574

(let* ((result-dimensions (mapcar #'first bindings))

575

(all-dimensions (union-dimensions base-dimensions result-dimensions))

576

(abstracted-dimensions (loop for dimension in all-dimensions

577

for position from 0

578

                                       collect (when dimension (cons-symbol *variable-package* :var (prin1-to-string position)))))

579

(dimension-map (loop for dimension in all-dimensions

580

for abstracted in abstracted-dimensions

581

when dimension

582

collect (cons dimension abstracted)))

583

(abstract-base-dimensions (sublis dimension-map base-dimensions))

584

(abstracted-bindings (sublis dimension-map bindings)))

585

     (ensure-matrix-operator 'bindings :source-dimensions abstract-base-dimensions :bindings abstracted-bindings)))

586

587

588

#|

589

590

(defgeneric new-field-data (field)

591

(:documentation "provide the location for a 'new' solution for the given field.

592

FIELD : solution-field

593

VALUES : data : (or array foreign-array) : locates the base of the solution field page

594

row : fixnum : index into the data array for the new solution

595

596

when the field is a streamed field, the data is a pointer to a possibly new page,

597

with completed pages passed to a destination and replaced.

598

599

if the channel number is non-minus, attempt to read from it.

600

if null, then clear the number. otherwise integrate the new page.")

601

602

(:method ((field matrix-field))

603

(let ((data (matrix-field-data field))

604

(channel (matrix-field-channel field)))

605

(cond ((cffi:null-pointer-p data)

606

(values data 0))

607

((null data)

608

(initialize-solution-field field :row-count *matrix-fold-length*)

609

(values (matrix-field-data field)

610

0))

611

((plusp channel)

612

(rdfcache:matrix-release (solution-field-solutions field))

613

(cffi:with-foreign-pointer (%matrix-handle (cffi:foreign-type-size :pointer))

614

(mqueue:receive-message channel %matrix-handle (cffi:foreign-type-size :pointer))

615

(let ((%matrix (cffi:mem-ref %matrix-handle :pointer)))

616

(setf (solution-field-solutions field) %matrix)

617

(if (cffi:null-pointer-p %matrix)

618

(values (setf (matrix-field-data field) %matrix) 0)

619

                    (values (setf (matrix-field-data field) (rdfcache:matrix-data-pointer %matrix)) 0)))))

620

(t

621

(values (setf (solution-field-solutions field) (cffi:null-pointer)) 0))))))

622

623

|#