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

Kind	Covered	All	%
expression	708	1514	46.8
branch	36	90	40.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 "This file defines function which compute and compile algera operator aspects

6

for the 'org.datagraph.spocq' RDF sparql engine."

7

8

(copyright

9

10

11

#+spocq.trace-aspects

12

(defmacro trace-aspect (&rest args)

13

`(trace-data ,@args))

14

15

#-spocq.trace-aspects

16

(defmacro trace-aspect (&rest args)

17

(declare (ignore args))

18

(values))

19

20

 ;;; (loop for repository being each hash-value in *repositories* collect (repository-aspect-cache repository))

21

22

(defun get-aspect-cache (key &key (repository *repository*) (cache (repository-aspect-cache repository)))

23

(when cache

24

(gethash key cache)))

25

26

 (defun (setf get-aspect-cache) (function key &key (repository *repository*) (cache (repository-aspect-cache repository)))

27

(when cache

28

(setf (gethash key cache) function))

29

function)

30

31

32

(defun compute-binary-cache-op-lambda (base-dimensions other-dimensions)

33

"given the result solution dimensions and those for the to-cache and to-retrieve constituents,

34

  compute a function which accepts a source solution location, adds the solution location to the first cache

35

and retrieves the list of matched solution locations from the second cache."

36

37

(let* ((key-dimensions (intersect-dimensions base-dimensions other-dimensions))

38

(base-width (length base-dimensions)))

39

`(lambda (base-page base-index put-cache get-cache)

40

(declare (fixnum base-index)

41

(type (simple-array fixnum (* ,base-width)) base-page)

42

(optimize ,@*field-optimization*))

43

(let ((key (list ,@(loop for i from 0

44

for var in base-dimensions

45

if (find var key-dimensions)

46

collect `(aref base-page base-index ,i))))

47

(surrogate (cons base-page base-index)))

48

(trace-data binary-cache-op

49

base-index

50

                         (make-array ,base-width :displaced-to base-page :element-type 'fixnum

51

                                     :displaced-index-offset (* base-index ,base-width))

52

key)

53

(push surrogate (gethash key put-cache))

54

(gethash key get-cache)))))

55

56

(defun compute-binary-cache-op (base-dimensions other-dimensions)

57

"given the result solution dimensions and those for the to-cache and to-retrieve constituents,

58

  compute a function which accepts a source solution location, adds the solution location to the first cache

59

and retrieves the list of matched solution locations from the second cache."

60

61

(let* ((key (list 'compute-binary-cache-op base-dimensions other-dimensions))

62

(function (get-aspect-cache key)))

63

(or function

64

(let* ((lambda (compute-binary-cache-op-lambda base-dimensions other-dimensions))

65

(function (spocq-compile lambda)))

66

(setf (get-aspect-cache key) function)

67

(values function lambda)))))

68

69

70

(defun compute-binary-collector-lambda (result-dimensions left-dimensions right-dimensions)

71

"given the result solution dimensions and those for the left and right constituents,

72

compute a function which accepts spread arguments for the result and the source pages and indices

73

and sets the reults solution to the combination of the two source solutions."

74

75

(let ((result-width (length result-dimensions))

76

(left-width (length left-dimensions))

77

(right-width (length right-dimensions)))

78

`(lambda (result-page result-index left-page left-index right-page right-index)

79

(declare (ignorable right-page right-index)

80

(fixnum result-index left-index right-index)

81

(type (simple-array fixnum (* ,(length result-dimensions))) result-page)

82

(type (simple-array fixnum (* ,(length left-dimensions))) left-page)

83

(type (simple-array fixnum (* ,(length right-dimensions))) right-page)

84

(optimize ,@*field-optimization*))

85

,@(loop for result-i from 0

86

for result-variable in result-dimensions

87

for left-i = (position result-variable left-dimensions)

88

for right-i = (position result-variable right-dimensions)

89

collect `(setf (aref result-page result-index ,result-i)

90

,(cond (left-i `(aref left-page left-index ,left-i))

91

                                      (right-i `(aref right-page right-index ,right-i))

92

(t 0))))

93

        (trace-data binary-collector (type-of result-page) result-index (type-of left-page) left-index (type-of right-page) right-index

94

(make-array ,result-width :displaced-to result-page :element-type 'fixnum

95

                                :displaced-index-offset (* result-index ,result-width))

96

(make-array ,left-width :displaced-to left-page :element-type 'fixnum

97

:displaced-index-offset (* left-index ,left-width))

98

(make-array ,right-width :displaced-to right-page :element-type 'fixnum

99

                                :displaced-index-offset (* right-index ,right-width))))))

100

101

(defun compute-binary-collector (solution-dimensions left-dimensions right-dimensions)

102

"given the result solution dimensions and those for the left and right constituents,

103

compute a function which accepts spread arguments for the result and the source pages and indices

104

and sets the reults solution to the combination of the two source solutions."

105

106

(let* ((key (list 'compute-binary-collector solution-dimensions left-dimensions right-dimensions))

107

(function (get-aspect-cache key)))

108

(or function

109

         (let* ((lambda (compute-binary-collector-lambda solution-dimensions left-dimensions right-dimensions))

110

(function (spocq-compile lambda)))

111

(setf (get-aspect-cache key) function)

112

(values function lambda)))))

113

114

115

(defun compute-binary-predicate-lambda (test left-dimensions right-dimensions &key (handle-errors t))

116

"given the parameter dimensions for a predicate and those for the left and right constituents,

117

compute a function wrapper which accepts the predicate and the respective solution locations

118

and applies the function to the named terms in the solutions.

119

120

declare the dimensions of the join for the case where an exists filter is involved, in order

121

that it can compile readers for the argument fields.

122

123

allow for bindings as either machted or dynamic."

124

125

(let* ((parameters (expression-free-dimensions test))

126

(matched-variables (expression-matched-variables test))

127

(left-count 0)

128

(right-count 0)

129

(undefined-variables ())

130

(macros (loop for parameter in parameters

131

for left-i = (position parameter left-dimensions)

132

for right-i = (position parameter right-dimensions)

133

                        collect `(,parameter ,(cond (left-i (incf left-count) `(field-object-aref left-page left-index ,left-i ,parameter))

134

                                                    (right-i (incf right-count) `(field-object-aref right-page right-index ,right-i ,parameter))

135

                                                    (t (push parameter undefined-variables)

136

                                                       `(query-binding-value ',parameter))))))

137

(lambda `(lambda (left-page left-index right-page right-index)

138

(declare (fixnum left-index right-index)

139

                              (type (simple-array fixnum (* ,(length left-dimensions))) left-page)

140

                              (type (simple-array fixnum (* ,(length right-dimensions))) right-page)

141

(optimize ,@*field-optimization*)

142

                              ;; in the event that the filter is just exists, the references

143

;; are not in this lexical context

144

(ignorable left-page left-index right-page right-index)

145

                              (spocq.e:join-dimensions ,(union-dimensions left-dimensions right-dimensions)

146

                                                        ,left-dimensions ,right-dimensions))

147

                     ;; nb. an exists filter can reference a page even though the variables are not visible

148

                     ,@(unless (plusp left-count) '((declare (ignorable left-page left-index))))

149

                     ,@(unless (plusp right-count) '((declare (ignorable right-page right-index))))

150

(symbol-macrolet ,macros

151

                       ;; the handler adds about 25% to predicate processing, but without it, call sites need to establish

152

;; their own per-iteration error catch-and-skip logic

153

,(if handle-errors

154

`(handler-case (ebv ,test) (error () nil))

155

`(ebv ,test))))))

156

(when (set-difference undefined-variables matched-variables)

157

(case (undefined-variable-behavior)

158

(|urn:dydra|:|error| (spocq.e:compilation-error :expression test

159

                                                         :condition (make-condition 'spocq.e:undefined-variable-error

160

                                                                                    :variables undefined-variables)))

161

(|urn:dydra|:|warning| (log-warn "~@[~a: ~]~a"

162

*query*

163

(make-condition 'spocq.e:undefined-variable-error

164

:expression test

165

:variables undefined-variables))

166

(push `(declare (special ,@undefined-variables)) (cddr lambda)))

167

(|urn:dydra|:|dynamicBinding| (push `(declare (special ,@undefined-variables)) (cddr lambda)))))

168

lambda))

169

170

(defun compute-binary-predicate (test left-dimensions right-dimensions &key (handle-errors t))

171

"given the parameter dimensions for a predicate and those for the left and right constituents,

172

compute a function wrapper which accepts the predicate and the respective solution locations

173

and applies the function to the named terms in the solutions."

174

175

(flet ((true-binary-predicate (left-page left-index right-page right-index)

176

(declare (ignore left-page left-index right-page right-index))

177

t))

178

(if test

179

(let* ((key (list 'compute-binary-predicate test left-dimensions right-dimensions))

180

(function (get-aspect-cache key)))

181

(or function

182

             (let* ((lambda (compute-binary-predicate-lambda test left-dimensions right-dimensions :handle-errors handle-errors))

183

(function (spocq-compile lambda)))

184

(setf (get-aspect-cache key) function)

185

(values function lambda))))

186

#'true-binary-predicate)))

187

188

189

190

(defun compute-elementary-select-collector-lambda (result-dimensions base-dimensions bindings)

191

(let* ((count 0)

192

(base-width (length base-dimensions))

193

(result-width (length result-dimensions))

194

(macros (append (loop for variable in result-dimensions

195

for i from 0

196

                                collect `(,variable (field-object-aref result-page result-index ,i ,variable)))

197

(loop for variable in base-dimensions

198

for base-i from 0

199

                                for result-i = (position variable result-dimensions)

200

unless result-i

201

do (incf count) and

202

                                collect `(,variable (field-object-aref base-page base-index ,base-i ,variable)))))

203

(copy-forms (loop for variable in base-dimensions

204

for base-i from 0

205

for result-i = (position variable result-dimensions)

206

when result-i

207

do (incf count) and

208

                            collect `(setf (aref result-page result-index ,result-i) (aref base-page base-index ,base-i)))))

209

`(lambda (result-page result-index base-page base-index)

210

(declare (fixnum base-index result-index)

211

(type (simple-array fixnum (* ,base-width)) base-page)

212

(type (simple-array fixnum (* ,result-width)) result-page)

213

(optimize ,@*field-optimization*))

214

215

,@(unless (plusp count) '((declare (ignore base-page base-index))))

216

,@copy-forms

217

(symbol-macrolet ,macros

218

,@(loop for (variable form) in bindings

219

for result-i = (position variable result-dimensions)

220

collect `(handler-case (setf ,variable ,form)

221

                             (error () (setf (aref result-page result-index ,result-i) +null-term-id+)))))

222

(trace-data elementary-select-collector

223

base-index result-index

224

(make-array ,base-width :displaced-to base-page :element-type 'fixnum

225

:displaced-index-offset (* base-index ,base-width))

226

(make-array ,result-width :displaced-to result-page :element-type 'fixnum

227

                                :displaced-index-offset (* result-index ,result-width))))))

228

229

(defun compute-elementary-select-collector (result-dimensions base-dimensions bindings)

230

   "compute a constructor similar to extend, but allowing that some base dimension - or even all of them,

231

may not appear in the result."

232

233

(when *strict-extend-bindings*

234

(let ((already-bound (intersection (mapcar #'first bindings) base-dimensions)))

235

(when already-bound

236

(spocq.e:redefined-variable-error :variables already-bound

237

:expression base-dimensions))))

238

(let* ((key (list 'compute-elementary-select-collector result-dimensions base-dimensions bindings))

239

(function (get-aspect-cache key)))

240

(or function

241

         (let* ((lambda (compute-elementary-select-collector-lambda result-dimensions base-dimensions bindings))

242

(function (spocq-compile lambda)))

243

(setf (get-aspect-cache key) function)

244

(values function lambda)))))

245

246

;;; (compute-elementary-select-collector-lambda '(a s d f q) '(q sdf) '((sdf (+ s d f))))

247

248

(defun compute-extend-collector-lambda (result-dimensions base-dimensions bindings)

249

(let* ((variables (bindings-variables bindings))

250

(values (bindings-value-forms bindings))

251

(non-result-variables (set-difference (expression-variables bindings) result-dimensions))

252

(base-width (length base-dimensions))

253

(result-width (length result-dimensions))

254

(macros (append (loop for v in result-dimensions

255

for v-index from 0

256

                                collect `(,v (field-object-aref result-page result-index ,v-index ,v)))

257

(loop for v in non-result-variables

258

for v-index = (position v base-dimensions)

259

                                collect `(,v ,(cond (v-index `(field-object-aref base-page base-index ,v-index ,v))

260

                                                    ;; extend variables are always dynamically bindable

261

                                                    (t `(query-binding-value ',v))))))))

262

`(lambda (result-page result-index base-page base-index)

263

(declare (fixnum base-index result-index)

264

(type (simple-array fixnum (* ,base-width)) base-page)

265

(type (simple-array fixnum (* ,result-width)) result-page)

266

(optimize ,@*field-optimization*)

267

(ignorable base-page base-index)

268

(spocq.e:base-dimensions ,@base-dimensions)

269

(spocq.e:dimensions ,@base-dimensions))

270

,@(loop for var in base-dimensions

271

for base-i from 0

272

for result-i = (position var result-dimensions)

273

when result-i

274

collect `(setf (aref result-page result-index ,result-i)

275

(aref base-page base-index ,base-i)))

276

(symbol-macrolet ,macros

277

,@(loop for variable in variables

278

for value in values

279

for result-i = (position variable result-dimensions)

280

for base-i = (position value base-dimensions)

281

collect (if base-i

282

`(setf (aref result-page result-index ,result-i)

283

(aref base-page base-index ,base-i))

284

`(handler-case (setf ,variable ,value)

285

                               (error () (setf (aref result-page result-index ,result-i) +null-term-id+))))))

286

(trace-aspect extend-collector base-index result-index

287

(make-array ,base-width :displaced-to base-page :element-type 'fixnum

288

                                  :displaced-index-offset (* base-index ,base-width))

289

                      (make-array ,result-width :displaced-to result-page :element-type 'fixnum

290

                                  :displaced-index-offset (* result-index ,result-width))))))

291

292

(defun compute-extend-collector (result-dimensions base-dimensions bindings)

293

"given the result solution dimensions, the base dimensions, and a binding list,

294

compute an operator which accepts the result and base locationd, computes the values

295

to bind, and stores them in the extended result page. If an expression signals an error, store the

296

  +null-value+ in its place. this first initializes the result solution and then computes the extension, which

297

overwrites rebound values. This does not enforce the rebinding restriction imposed by the spec

298

for the extend operator, as these collected is used also by a binding projector to

299

implement select with expressions."

300

301

(let* ((key (list 'compute-extend-collector result-dimensions base-dimensions bindings))

302

(function (get-aspect-cache key)))

303

(or function

304

(let* ((lambda (compute-extend-collector-lambda result-dimensions base-dimensions bindings))

305

(function (spocq-compile lambda)))

306

(setf (get-aspect-cache key) function)

307

(values function lambda)))))

308

309

310

(defun flatten-field (list)

311

"Return a sequence of lists in which any cons element of the original is expanded into

312

individual lists. a null element results in a null result."

313

(if list

314

(destructuring-bind (first . rest) list

315

(loop for expanded-rest in (flatten-field rest)

316

append (if (listp first)

317

(loop for elt in first collect (cons elt expanded-rest))

318

(list (cons first expanded-rest)))))

319

(list nil)))

320

;;; (flatten-field '(1 2))

321

;;; (flatten-field '(1 (2 3) nil 4 (5 6)))

322

323

(defun compute-cartesian-extend-collector-lambda (result-dimensions base-dimensions bindings)

324

(let* ((undefined-variables (loop with bound-variables = base-dimensions

325

                                 for (binding-variable binding-expression) in bindings

326

                                 for binding-expression-variables = (expression-variables binding-expression)

327

                                 append (set-difference binding-expression-variables bound-variables)

328

do (push binding-variable bound-variables)))

329

(base-width (length base-dimensions))

330

(result-width (length result-dimensions)))

331

(when undefined-variables

332

(case (undefined-variable-behavior)

333

(|urn:dydra|:|error| (spocq.e:compilation-error :expression bindings

334

                                                         :condition (make-condition 'spocq.e:undefined-variable-error

335

                                                                                    :variables undefined-variables)))

336

(|urn:dydra|:|warning| (log-warn "~@[~a: ~]~a"

337

*query*

338

                                          (make-condition 'spocq.e:undefined-variable-error

339

                                                          :expression bindings

340

                                                          :variables undefined-variables)))

341

(|urn:dydra|:|dynamicBinding| )))

342

(flet ((var-term-number-var (var)

343

              (or (get var :term-number-var) (setf (get var :term-number-var) (gensym (concatenate 'string (string var) "-term-number")))))

344

(var-term-var (var)

345

              (or (get var :term-number-var) (setf (get var :term-var) (gensym (concatenate 'string (string var) "-term-number"))))))

346

(let ((lambda `(lambda (result-page result-indexer base-page base-index)

347

(declare (fixnum base-index)

348

(type (function () fixnum) result-indexer)

349

                                 (type (simple-array fixnum (* ,base-width)) base-page)

350

                                 (type (simple-array fixnum (* ,result-width)) result-page)

351

(optimize ,@*field-optimization*)

352

(ignorable base-page base-index)

353

(spocq.e:base-dimensions ,@base-dimensions)

354

(spocq.e:dimensions ,@base-dimensions))

355

                        ;; establish an initial contour bindings the term numbers from the base field

356

(let* ,(loop for var in base-dimensions

357

for v-index from 0

358

                                 append `((,(var-term-number-var var) (aref base-page base-index ,v-index))

359

                                          (,var (term-number-object ,(var-term-number-var var)))))

360

(declare (ignorable ,@base-dimensions))

361

                          ;; define the variable for the additional bindings for the results field and initialze them to undefined

362

                          (let ,(loop for var in (set-difference result-dimensions base-dimensions)

363

                                  append `((,(var-term-number-var var) +null-term-id+)

364

                                           (,var ,(spocq:make-unbound-variable var))))

365

,@(when undefined-variables

366

`((declare (special ,@undefined-variables))))

367

(handler-bind ((error (lambda (c)

368

                                                    (declare (ignore c))

369

                                                    (use-value ,(spocq:make-unbound-variable nil)))))

370

,@(loop for (var expression) in bindings

371

                                  collect `(setf ,var (restart-case ,expression (use-value (v) v)))))

372

;; transcribe new new numbers

373

(let ((%cartesian-p nil))

374

                              ,@(loop for var in (set-difference result-dimensions base-dimensions)

375

for term-number-var = (var-term-number-var var)

376

collect `(setf ,term-number-var

377

(typecase ,var

378

                                                   (list (setf %cartesian-p t)

379

                                                         (loop for elt in ,var collect (repository-object-term-number *transaction* elt)))

380

                                                   (t (repository-object-term-number *transaction* ,var)))))

381

(flet ((emit-solution ,result-dimensions

382

                                       (let ((result-index (funcall result-indexer)))

383

,@(loop for position from 0

384

                                            for term-number-var in result-dimensions

385

                                            collect `(setf (aref result-page result-index ,position) ,term-number-var))

386

                                         (trace-aspect extend-collector base-index result-index

387

                                                       (make-array ,base-width :displaced-to base-page :element-type 'fixnum

388

                                                                   :displaced-index-offset (* base-index ,base-width))

389

                                                       (make-array ,result-width :displaced-to result-page :element-type 'fixnum

390

                                                                   :displaced-index-offset (* result-index ,result-width))))))

391

(cond (%cartesian-p

392

                                       (loop for ,result-dimensions in (flatten-field (list ,@(mapcar #'var-term-number-var result-dimensions)))

393

                                         do (emit-solution ,@result-dimensions)))

394

(t

395

                                       (emit-solution ,@(mapcar #'var-term-number-var result-dimensions)))))))))))

396

lambda))))

397

398

;;; (compute-cartesion-extend-collector-lambda '(p r1 s) '(p s) '((r1 (fun p s))))

399

;;; (compute-cartesion-extend-collector-lambda '(p r1 r2 s) '(p s) '((r1 (fun p (qer s))) (r2 (x r1))))

400

401

(defun compute-cartesian-extend-collector (result-dimensions base-dimensions bindings)

402

"compute the colector analogous to an extend collector, but permit and expand list results."

403

404

(let* ((key (list 'compute-extend-collector result-dimensions base-dimensions bindings))

405

(function (get-aspect-cache key)))

406

(or function

407

         (let* ((lambda (compute-cartesian-extend-collector-lambda result-dimensions base-dimensions bindings))

408

(function (spocq-compile lambda)))

409

(setf (get-aspect-cache key) function)

410

(values function lambda)))))

411

412

;;; (compute-extend-collector-lambda '(v1 v2) '((v3 (+ v1 v2))))

413

414

#+(or) ; unused

415

(defun compute-field-test-applicator (function-dimensions field-dimensions)

416

"given the parameter dimensions for a predicate and those for the constituent field,

417

compute a function wrapper which accepts the predicate and the respective solution location

418

and applies the function to the named terms in the solutions."

419

420

(let* ((count 0)

421

(macros (loop for parameter in function-dimensions

422

for i = (position parameter field-dimensions)

423

                        collect `(,parameter ,(cond (i (incf count) `(aref page index ,i))

424

(t 0)))))

425

(lambda `(lambda (test page index)

426

(declare (fixnum index)

427

                              (type (simple-array fixnum (* ,(length field-dimensions))) page)

428

(optimize ,@*field-optimization*))

429

,@(unless (plusp count) '((declare (ignore page index))))

430

(symbol-macrolet ,macros

431

(funcall #+mcl (dimensioned-funcallable-object-function test)

432

#-mcl test

433

,@function-dimensions)))))

434

(values (spocq-compile lambda) lambda)))

435

436

437

(defun compute-flag-cache-op (dimensions)

438

"given the dimensions, compute a function which accepts a source solution location, and marks the

439

solution in the first cache and returns true if it was alread present, false if it was not."

440

441

(let ((lambda `(lambda (page index cache)

442

(declare (fixnum index)

443

                             (type (simple-array fixnum (* ,(length dimensions))) page)

444

                             (ignorable page index)    ; in case applied to a unit table

445

(optimize ,@*field-optimization*))

446

(let ((key (list ,@(loop for i from 0 below (length dimensions)

447

                                             collect `(aref page index ,i)))))

448

(cond ((gethash key cache))

449

(t

450

(setf (gethash key cache) t)

451

nil))))))

452

(values (spocq-compile lambda) lambda)))

453

454

455

(defun compute-key-generator-lambda (key-dimensions base-dimensions)

456

"given the dimensions for the key and the field return the hash code for the key constituents."

457

458

(let* ((base-width (length base-dimensions)))

459

`(lambda (base-page base-index)

460

(declare (fixnum base-index)

461

(type (simple-array fixnum (* ,base-width)) base-page)

462

(optimize ,@*field-optimization*))

463

,(if (= (length key-dimensions) 1)

464

`(sxhash (aref base-page base-index ,(position (first key-dimensions) base-dimensions)))

465

`(let ((key (list ,@(loop for i from 0

466

for var in base-dimensions

467

if (find var key-dimensions)

468

                                     collect `(aref base-page base-index ,i)))))

469

(declare (dynamic-extent key))

470

(term-id-list-psxhash key))))))

471

472

(defun compute-key-generator (key-dimensions base-dimensions)

473

"given the dimensions for the key and the field return the hash code for the key constituents."

474

475

(let* ((key (list 'compute-key-generator key-dimensions base-dimensions))

476

(function (get-aspect-cache key)))

477

(or function

478

(let* ((lambda (compute-key-generator-lambda key-dimensions base-dimensions))

479

(function (spocq-compile lambda)))

480

(setf (get-aspect-cache key) function)

481

(values function lambda)))))

482

483

484

485

(defun compute-optional-collector-lambda (result-dimensions base-dimensions optional-dimensions)

486

"given the result solution dimensions and those for the base and right constituents,

487

compute a function which accepts spread arguments for the result and the source pages and indices

488

and sets the results solution to the combination of the two source solutions."

489

(let ((base-width (length base-dimensions))

490

(optional-width (length optional-dimensions))

491

(result-width (length result-dimensions)))

492

493

`(lambda (result-page result-index base-page base-index optional-page optional-index)

494

(declare (ignorable base-page base-index optional-page optional-index)

495

(fixnum result-index base-index)

496

(type (simple-array fixnum (* ,(length result-dimensions))) result-page)

497

(type (simple-array fixnum (* ,(length base-dimensions))) base-page)

498

(optimize ,@*field-optimization*)

499

)

500

,@(loop for base-variable in base-dimensions

501

for base-i from 0

502

for result-i = (position base-variable result-dimensions)

503

collect `(setf (aref result-page result-index ,result-i)

504

(aref base-page base-index ,base-i)))

505

(if optional-page

506

;; augment the base solution with terms from the optional sourge.

507

          ;; allow for the case, that some dimension in the base page is present as a place-holder on;y

508

;; as a consequence of a union extening the dimensions

509

          (locally (declare (type (simple-array fixnum (* ,(length optional-dimensions))) optional-page)

510

(type fixnum optional-index))

511

,@(loop for result-i from 0

512

for result-variable in result-dimensions

513

for base-i = (position result-variable base-dimensions)

514

for optional-i = (position result-variable optional-dimensions)

515

if optional-i

516

if base-i

517

collect `(if (= (aref result-page result-index ,result-i) +null-term-id+)

518

(setf (aref result-page result-index ,result-i)

519

                                     (aref optional-page optional-index ,optional-i)))

520

else collect `(setf (aref result-page result-index ,result-i)

521

                                        (aref optional-page optional-index ,optional-i))))

522

          #+(or) ;; don't ;; mark unbound terms !! presumes that the pages are cleared before use

523

(progn ,@(loop for result-i from 0

524

for result-variable in result-dimensions

525

for base-i = (position result-variable base-dimensions)

526

for optional-i = (position result-variable optional-dimensions)

527

if (and optional-i (not base-i))

528

                         collect `(setf (aref result-page result-index ,result-i) +null-term-id+))))

529

530

(trace-data optional-collector base-index

531

(make-array ,base-width :displaced-to base-page :element-type 'fixnum

532

:displaced-index-offset (* base-index ,base-width))

533

(if optional-page

534

                      (make-array ,optional-width :displaced-to optional-page :element-type 'fixnum

535

                                  :displaced-index-offset (* optional-index ,optional-width))

536

"...")

537

(make-array ,result-width :displaced-to result-page :element-type 'fixnum

538

                                :displaced-index-offset (* result-index ,result-width))))))

539

540

541

(defun compute-optional-collector (result-dimensions base-dimensions optional-dimensions)

542

"given the result solution dimensions and those for the base and right constituents,

543

compute a function which accepts spread arguments for the result and the source pages and indices

544

and sets the reults solution to the combination of the two source solutions."

545

546

(let* ((key (list 'compute-optional-collector result-dimensions base-dimensions optional-dimensions))

547

(function (get-aspect-cache key)))

548

(or function

549

         (let* ((lambda (compute-optional-collector-lambda result-dimensions base-dimensions optional-dimensions))

550

(function (spocq-compile lambda)))

551

(setf (get-aspect-cache key) function)

552

(values function lambda)))))

553

554

555

(defun compute-optional-write-cache-op-lambda (base-dimensions optional-dimensions)

556

     "given the dimensions for the base and right constituents, compute a function which accepts spread arguments

557

  for the result and the source solutions as page and index, computes a key contingent on the presence of the

558

optional page, notes the solution and returns true if it was already present."

559

560

(let* ((base-width (length base-dimensions))

561

(optional-width (length optional-dimensions)))

562

`(lambda (base-page base-index optional-page optional-index result-cache)

563

(declare (ignorable base-page base-index optional-page optional-index)

564

(fixnum base-index)

565

(type (simple-array fixnum (* ,base-width)) base-page)

566

(optimize ,@*field-optimization*))

567

(let ((key (if optional-page

568

                       (locally (declare (type (simple-array fixnum (* ,optional-width)) optional-page)

569

(type fixnum optional-index))

570

(list ,@(loop for base-i from 0 below base-width

571

                                       collect `(aref base-page base-index ,base-i))

572

,@(loop for optional-i from 0

573

                                       for optional-variable in optional-dimensions

574

                                       unless (position optional-variable base-dimensions)

575

                                       collect `(aref optional-page optional-index ,optional-i))))

576

(list ,@(loop for base-i from 0 below base-width

577

                                     collect `(aref base-page base-index ,base-i))))))

578

(cond ((gethash key result-cache))

579

(t

580

(setf (gethash key result-cache) t)

581

nil))))))

582

583

(defun compute-optional-write-cache-op (base-dimensions optional-dimensions)

584

"given the result solution dimensions and those for the base and right constituents,

585

compute a function which accepts spread arguments for the result and the source pages and indices

586

and sets the reults solution to the combination of the two source solutions."

587

588

(let* ((key (list 'compute-optional-write-cache-op base-dimensions optional-dimensions))

589

(function (get-aspect-cache key)))

590

(or function

591

(let* ((lambda (compute-optional-write-cache-op-lambda base-dimensions optional-dimensions))

592

(function (spocq-compile lambda)))

593

(setf (get-aspect-cache key) function)

594

(values function lambda)))))

595

596

597

(defun compute-pattern-constructor-lambda (base-dimensions graph-pattern &key (mode :insert))

598

   "Given the dimensions of a base field and a result pattern, construct an operator which accepts such a

599

solution field and a collector and invokes the collector once for each projected solution for which

600

all variables are bound.

601

:mode indicates whether the result will be stores or exported. In the former case, the nodes

602

must be globally unique., but in the latter just local tot he task.

603

Return the operator and the result pattern field length and width."

604

605

   (let* ((with-quads (when (or (assoc 'spocq.a:|graph| graph-pattern) (assoc 'spocq.a:|quad| graph-pattern)) t))

606

(base-width (length base-dimensions))

607

(pattern-length 0)

608

(pattern-width (if with-quads 4 3))

609

(macros (loop for variable in base-dimensions

610

for i from 0

611

collect `(,variable (aref base-page base-index ,i))))

612

(blank-nodes (expression-blank-nodes graph-pattern))

613

(blank-node-variables (loop for i from 0 below (length blank-nodes)

614

collect (cons-variable "_")))

615

(undistinguished-variables (expression-undistinguished-variables graph-pattern))

616

(blank-node-map (mapcar #'cons blank-nodes blank-node-variables))

617

(abstract-graph-pattern (sublis blank-node-map graph-pattern))

618

          (blank-node-operator (ecase mode (:insert 'cons-global-blank-node) (:construct 'cons-blank-node)))

619

(ephemeral-p nil))

620

(flet ((object-term-number (term)

621

(let ((otn (object-term-number term)))

622

(when (minusp otn) (setf ephemeral-p t))

623

otn)))

624

(let ((lambda `(lambda (collector base-page base-index)

625

                        (declare (type (function ,(loop for i from 0 below pattern-width collect 'fixnum) t) collector)

626

                                 ;; this constraint is violated by federation data in inserts

627

                                 ;; (type (integer 0 ,(1- *field-page-length*)) base-index)

628

(type (integer 0 ) base-index)

629

                                 (type (simple-array fixnum (* ,base-width)) base-page)

630

                                 ;; in case, either the base page is a unit table or

631

;; the terms are all constant

632

(ignorable base-page base-index))

633

(symbol-macrolet ,macros

634

,(let ((body (loop for statement in abstract-graph-pattern

635

for pattern-index from 0

636

                                             append (case (first statement)

637

                                                      (spocq.a:|triple|

638

                                                       (incf pattern-length)

639

                                                       `((funcall collector

640

                                                                  ,@(loop for term in (statement-terms statement)

641

                                                                          collect (if (variable-p term)

642

                                                                                    term

643

                                                                                    (object-term-number term)))

644

                                                                  ;; graph is last

645

                                                                  ,@(when with-quads (list 'rlmdb:*default-context-number*)))))

646

                                                      (spocq.a:|quad|

647

                                                       (incf pattern-length)

648

                                                       `((funcall collector

649

                                                                  ,@(loop for term in (statement-terms statement)

650

                                                                          collect (if (variable-p term)

651

                                                                                    term

652

                                                                                    (object-term-number term))))))

653

                                                      (spocq.a:|graph| (destructuring-bind (graph triples) (rest statement)

654

                                                                         (unless (variable-p graph) (setf graph (object-term-number graph)))

655

                                                                         (loop for triple in triples

656

                                                                               do (incf pattern-length)

657

                                                                               collect `(funcall collector

658

                                                                                                 ,@(loop for term in (statement-terms triple)

659

                                                                                                         collect (if (variable-p term)

660

                                                                                                                   term

661

                                                                                                                   (object-term-number term)))

662

                                                                                                 ,graph))))

663

                                                      (t ;; presume it's a triple

664

                                                       (incf pattern-length)

665

                                                       `((funcall collector

666

                                                                  ,@(loop for term in (statement-terms statement)

667

                                                                          collect (if (variable-p term)

668

                                                                                    term

669

                                                                                    (object-term-number term)))

670

                                                                  ,@(when with-quads (list 'rlmdb:*default-context-number*)))))))))

671

(if (or blank-nodes undistinguished-variables)

672

                               `(let (,@(loop for variable in undistinguished-variables

673

                                              ;; undistinguished variables are always rewritten

674

                                              collect `(,variable (object-term-number (,blank-node-operator))))

675

                                      ,@(loop for variable in blank-node-variables

676

for node in blank-nodes

677

                                              ;; blank nodes are rewritten if skolemizing import only

678

                                              collect `(,variable ,(ecase mode

679

                                                                     (:insert

680

                                                                      (if (skolemize-insertions-p)

681

                                                                        `(object-term-number (,blank-node-operator))

682

                                                                        `(object-term-number ,node)))

683

                                                                     (:construct

684

                                                                      `(object-term-number (,blank-node-operator)))))))

685

,@body)

686

`(progn

687

,@body)))))))

688

(values lambda pattern-length pattern-width ephemeral-p)))))

689

690

691

(defun compute-pattern-constructor (base-dimensions graph-pattern &key (mode :insert))

692

   "Given the dimensions of a base field and a result pattern, construct an operator which accepts such a

693

solution field and a collector and invokes the collector once for each projected solution for which

694

all variables are bound.

695

:mode indicates whether the result will be stores or exported. In the former case, the nodes

696

must be globally unique., but in the latter just local tot he task.

697

Return the operator and the result pattern field length and width."

698

699

(let* ((key (list 'compute-pattern-constructor base-dimensions graph-pattern mode))

700

(function-and-size (get-aspect-cache key)))

701

(if function-and-size

702

(apply #'values function-and-size)

703

(multiple-value-bind (lambda length width ephemeral-p)

704

                            (compute-pattern-constructor-lambda base-dimensions graph-pattern :mode mode)

705

(let ((function (spocq-compile lambda)))

706

(unless ephemeral-p

707

(setf (get-aspect-cache key) (list function length width)))

708

(values function length width lambda))))))

709

710

 ;;; (compute-pattern-constructor '(?::|o| ?::|p| ?::|s|) '((spocq.a:|graph| <http://example.org/g1> ((spocq.a:|triple| ?::|s| ?::|p| "q")))))

711

712

713

(defun compute-insert-pattern-constructor (base-dimensions graph-pattern)

714

(compute-pattern-constructor base-dimensions graph-pattern :mode :insert))

715

716

(defun compute-construct-pattern-constructor (base-dimensions graph-pattern)

717

(compute-pattern-constructor base-dimensions graph-pattern :mode :construct))

718

719

(defun compute-project-collector (result-bindings base-dimensions)

720

"GIven a projection from a base field in the form of a binding list, generate an operator which

721

accepts a result location and a base location, and projects form the latter to the former."

722

(compute-extend-collector (bindings-variables result-bindings) base-dimensions result-bindings))

723

#+(or)

724

(defun call-collector (collector result-page result-index base-page base-index)

725

(funcall collector result-page result-index base-page base-index))

726

#+(or)

727

(defun compute-project-collector (result-bindings base-dimensions)

728

(let ((collector

729

          (compute-extend-collector (bindings-variables result-bindings) base-dimensions result-bindings)))

730

     #'(lambda (result-page result-index base-page base-index) (call-collector collector result-page result-index base-page base-index))))

731

732

733

 (defun compute-read-cache-op-lambda (base-dimensions other-dimensions &key (key-dimensions (intersect-dimensions base-dimensions other-dimensions)))

734

   "given the dimensions for the field to be matched against the cache contents and those for the other

735

  field, compute the key dimensions and generate a function which accepts a solution location and retrieves

736

the list of matched solution locations from the cache."

737

738

(let* ((base-width (length base-dimensions)))

739

`(lambda (base-page base-index cache)

740

(declare (fixnum base-index)

741

(type (simple-array fixnum (* ,base-width)) base-page)

742

(optimize ,@*field-optimization*))

743

(let ((key (list ,@(loop for i from 0

744

for var in base-dimensions

745

if (find var key-dimensions)

746

collect `(aref base-page base-index ,i)))))

747

(declare (dynamic-extent key))

748

(trace-data read-cache base-index

749

(make-array ,base-width :displaced-to base-page :element-type 'fixnum

750

                                  :displaced-index-offset (* base-index ,base-width))

751

key)

752

(gethash key cache)))))

753

754

 (defun compute-read-cache-op (base-dimensions other-dimensions &key (key-dimensions (intersect-dimensions base-dimensions other-dimensions)))

755

   "given the dimensions for the field to be matched against the cache contents and those for the other

756

  field, compute the key dimensions and generate a function which accepts a solution location and retrieves

757

the list of matched solution locations from the cache."

758

759

(let* ((key (list 'compute-read-cache-op base-dimensions other-dimensions key-dimensions))

760

(function (get-aspect-cache key)))

761

(or function

762

         (let* ((lambda (compute-read-cache-op-lambda base-dimensions other-dimensions :key-dimensions key-dimensions))

763

(function (spocq-compile lambda)))

764

(setf (get-aspect-cache key) function)

765

(values function lambda)))))

766

767

768

(defun compute-sort-predicate-operators (order-predicate-form)

769

(loop for order-expression in order-predicate-form

770

collect (if (consp order-expression)

771

(case (first order-expression)

772

(spocq.a::|asc| #'spocq.e:lessp)

773

(spocq.a::|desc| #'spocq.e:greaterp)

774

(t #'spocq.e:lessp))

775

#'spocq.e:lessp)))

776

777

; construct the sort ky as a three part list (term-numbers values location)

778

; predicate attempts to use the numbers, if that is not present, it uses the value

779

; if it is present, it uses it and if the comparison succeeds, it uses the result;

780

; if the comparison fails to prdue a result, it computs and caches the object value,

781

; removes the term number, and uses the object value instead

782

;; intermediate bindings are not as values, but as macrolets

783

784

(defun compute-sort-key-operator-lambda (base-dimensions order-predicate-form)

785

"given a sort predicate, a sequence of combined order specification and values expression,

786

and the dimensionality of the base field, compute a function which will return a list

787

of sort key values for each solution in the field and a list of the respective

788

comparison predicate operators.

789

nb. now returns just the choices, but it should be combined with the logic in the

790

order operator to return the actual list...

791

distinguish predicate according to whether the value will be extracted from the field - in which

792

    case a term number predicate should be used, or it will be computed, in which case a term object

793

predicate is required.

794

795

allow for bindings as either machted or dynamic.

796

"

797

(let* ((variables (expression-variables order-predicate-form))

798

(key-forms (loop for order-expression in order-predicate-form

799

collect (if (consp order-expression)

800

(case (first order-expression)

801

                                       ((spocq.a::|asc| spocq.a::|desc|) (second order-expression))

802

(t order-expression))

803

order-expression)))

804

(key-orders (loop for order-expression in order-predicate-form

805

collect (if (consp order-expression)

806

(case (first order-expression)

807

(spocq.a::|asc| '<)

808

(spocq.a::|desc| '>)

809

(t '<))

810

'<)))

811

(undefined-variables ())

812

(value-bindings (loop for variable in variables

813

for i = (position variable base-dimensions)

814

                                collect `(,variable ,(cond (i `(field-object-aref base-page base-index ,i ,variable))

815

                                                           (t (push variable undefined-variables)

816

                                                              `(query-binding-value ',variable))))))

817

(term-number-forms (loop for variable in variables

818

                                      for i = (position variable base-dimensions)

819

when i

820

                                      collect `(,variable . (aref base-page base-index ,i)))))

821

(multiple-value-bind (forms predicates)

822

(loop for form in key-forms

823

for order in key-orders

824

                                for term-number-form = (rest (assoc form term-number-forms))

825

if term-number-form

826

collect term-number-form into key-forms

827

                                and collect (case order (< #'compare-term-number) (> #'compare-term-number-inverted)) into predicates

828

else

829

                                collect `(handler-case ,form (error () nil)) into key-forms

830

                                and collect (case order (< #'compare-term) (> #'compare-term-inverted)) into predicates

831

finally (return (values key-forms predicates)))

832

(let ((lambda `(lambda (base-page base-index)

833

                        (declare (ignorable base-page base-index))          ; allow things like "order by rand()"

834

;; use a let, since the reference is likely repeated

835

(symbol-macrolet ,value-bindings

836

(list ,@forms)))))

837

(when undefined-variables

838

(case (undefined-variable-behavior)

839

(|urn:dydra|:|error| (spocq.e:compilation-error :expression order-predicate-form

840

                                                             :condition (make-condition 'spocq.e:undefined-variable-error

841

                                                                                        :variables undefined-variables)))

842

(|urn:dydra|:|warning| (log-warn "~@[~a: ~]~a"

843

*query*

844

                                              (make-condition 'spocq.e:undefined-variable-error

845

                                                              :expression order-predicate-form

846

                                                              :variables undefined-variables))

847

                                    (push `(declare (special ,@undefined-variables)) (cddr lambda)))

848

             (|urn:dydra|:|dynamicBinding| (push `(declare (special ,@undefined-variables)) (cddr lambda)))))

849

(values lambda

850

predicates)))))

851

852

(defun compute-sort-key-operator (base-dimensions order-predicate-form)

853

(let* ((key (list 'compute-sort-key-operator base-dimensions order-predicate-form))

854

(function.predicates (get-aspect-cache key)))

855

(if function.predicates

856

(values (first function.predicates) (second function.predicates))

857

(multiple-value-bind (lambda predicates)

858

                            (compute-sort-key-operator-lambda base-dimensions order-predicate-form)

859

(let ((function (spocq-compile lambda)))

860

(setf (get-aspect-cache key) (list function predicates))

861

(values function predicates lambda))))))

862

863

864

(defun compute-binding-iterator (base-dimensions variables)

865

"Given a base field description and a list of variable in it, generate an operator which accepts

866

an operator and a solution location, extracts each variable in turn and calls the given operator

867

with the variable and the term. If the variable is not bound in the solution, a null term id is

868

passed."

869

870

(let* ((lambda `(lambda (operator base-page base-index)

871

,(if variables

872

`(declare (type (function (fixnum) t) operator)

873

                                  (type (simple-array fixnum (* ,(length base-dimensions))) base-page)

874

(fixnum base-index))

875

'(declare (ignore operator base-page base-index)))

876

,@(loop for variable in variables

877

for i = (position variable base-dimensions)

878

                             if i collect `(funcall operator (aref base-page base-index ,i))

879

else collect `(funcall operator +null-term-id+)))))

880

(values (spocq-compile lambda) lambda)))

881

882

883

(defun compute-unary-collector-lambda (result-dimensions base-dimensions)

884

"given the result solution dimensions and those for the left and right constituents,

885

compute a function which accepts spread arguments for the result and the source pages and indices

886

and sets the reults solution to the combination of the two source solutions."

887

888

;; could iterate over the dimension count, but this forms supports also projection

889

(let* ((base-width (length base-dimensions))

890

(result-width (length result-dimensions)))

891

`(lambda (result-page result-index base-page base-index)

892

(declare (fixnum result-index base-index)

893

(type (simple-array fixnum (* ,(length result-dimensions))) result-page)

894

(type (simple-array fixnum (* ,(length base-dimensions))) base-page)

895

(optimize ,@*field-optimization*))

896

,@(loop for result-i from 0

897

for result-variable in result-dimensions

898

for base-i = (position result-variable base-dimensions)

899

collect `(setf (aref result-page result-index ,result-i)

900

,(if base-i

901

`(aref base-page base-index ,base-i)

902

'+null-term-id+)))

903

(trace-data unary-collector (type-of base-page) base-index (type-of result-page) result-index

904

(make-array ,base-width :displaced-to base-page :element-type 'fixnum

905

:displaced-index-offset (* base-index ,base-width))

906

(make-array ,result-width :displaced-to result-page :element-type 'fixnum

907

                                                       :displaced-index-offset (* result-index ,result-width))))))

908

909

(defun compute-unary-collector (result-dimensions base-dimensions)

910

"given the result solution dimensions and those for the left and right constituents,

911

compute a function which accepts spread arguments for the result and the source pages and indices

912

and sets the reults solution to the combination of the two source solutions."

913

914

(let* ((key (list 'compute-unary-collector result-dimensions base-dimensions))

915

(function (get-aspect-cache key)))

916

(or function

917

(let* ((lambda (compute-unary-collector-lambda result-dimensions base-dimensions))

918

(function (spocq-compile lambda)))

919

(setf (get-aspect-cache key) function)

920

(values function lambda)))))

921

922

923

(defun compute-unary-extractor-lambda (result-dimensions base-dimensions)

924

"given the result solution dimensions and those for the base constituents,

925

compute a function which a single field argument and constructs a solution

926

based on the base->result combination."

927

928

(let* ((base-width (length base-dimensions)))

929

`(lambda (base-page base-index)

930

(declare (fixnum base-index)

931

(type (simple-array fixnum (* ,base-width)) base-page)

932

(optimize ,@*field-optimization*))

933

(list ,@(loop for result-i from 0

934

for result-variable in result-dimensions

935

for base-i = (position result-variable base-dimensions)

936

collect (if base-i

937

`(aref base-page base-index ,base-i)

938

'+null-term-id+))))))

939

940

(defun compute-unary-extractor (result-dimensions base-dimensions)

941

"given the result solution dimensions and those for the left and right constituents,

942

compute a function which accepts spread arguments for the result and the source pages and indices

943

and sets the reults solution to the combination of the two source solutions."

944

945

(let* ((key (list 'compute-unary-extractor result-dimensions base-dimensions))

946

(function (get-aspect-cache key)))

947

(or function

948

(let* ((lambda (compute-unary-extractor-lambda result-dimensions base-dimensions))

949

(function (spocq-compile lambda)))

950

(setf (get-aspect-cache key) function)

951

(values function lambda)))))

952

953

954

(defun compute-unary-predicate-lambda (test base-dimensions)

955

"given a predicate expression and the dimensions for the base field,

956

compute a function applies interprets the expression respective a given solution location.

957

958

allow for bindings as either machted or dynamic."

959

960

(let* (; (parameters (union-dimensions (expression-dimensions test) base-dimensions))

961

;; limit the bindings to the free dimensions

962

(parameters (expression-free-dimensions test))

963

(matched-variables (expression-matched-variables test))

964

(count 0)

965

(undefined-variables ())

966

(macros (loop for parameter in parameters

967

for i = (position parameter base-dimensions)

968

collect `(,parameter ,(cond (i (incf count)

969

                                                       `(field-object-aref base-page base-index ,i ,parameter))

970

                                                    (t (push parameter undefined-variables)

971

                                                       `(query-binding-value ',parameter))))))

972

(lambda `(lambda (base-page base-index)

973

(declare (fixnum base-index)

974

                              (type (simple-array fixnum (* ,(length base-dimensions))) base-page)

975

(optimize ,@*field-optimization*))

976

(declare (spocq.e:dimensions ,@base-dimensions))

977

                     ;; nb. an exists filter can reference a page even though the variables are not visible

978

,@(unless (plusp count) '((declare (ignorable base-page base-index))))

979

(symbol-macrolet ,macros

980

;; (spocq.a:|&&| ,test t) #+(or)

981

(handler-case (spocq.a:|&&| ,test t)

982

(error (c) (when (typep c *break-on-filter-errors*)

983

(break "Error in predicate: ~a: ~a."

984

',test c))))))))

985

(when (set-difference undefined-variables matched-variables)

986

(case (undefined-variable-behavior)

987

(|urn:dydra|:|error| (spocq.e:compilation-error :expression test

988

                                                         :condition (make-condition 'spocq.e:undefined-variable-error

989

                                                                                    :variables undefined-variables)))

990

(|urn:dydra|:|warning| (log-warn "~@[~a: ~]~a"

991

*query*

992

(make-condition 'spocq.e:undefined-variable-error

993

:expression test

994

:variables undefined-variables))

995

(push `(declare (special ,@undefined-variables)) (cddr lambda)))

996

(|urn:dydra|:|dynamicBinding| (push `(declare (special ,@undefined-variables)) (cddr lambda)))))

997

lambda))

998

999

(defun compute-unary-predicate (test base-dimensions)

1000

"given a predicate expression and the dimensions for the base field,

1001

compute a function applies interprets the expression respective a given solution location."

1002

1003

(let* ((key (list 'compute-unary-predicate test base-dimensions))

1004

(function (get-aspect-cache key)))

1005

(or function

1006

(let* ((lambda (compute-unary-predicate-lambda test base-dimensions))

1007

(function (spocq-compile lambda)))

1008

(setf (get-aspect-cache key) function)

1009

(values function lambda)))))

1010

1011

1012

(defun compute-write-cache-op-lambda (base-dimensions other-dimensions &key

1013

                                                       (key-dimensions (intersect-dimensions base-dimensions other-dimensions)))

1014

   "given the dimensions for the field to be cached and those for the other field, compute the key dimensions

1015

  and generate a function which accepts a solution location and adds it to the list of cached equivalents."

1016

1017

(let* ((base-width (length base-dimensions)))

1018

`(lambda (base-page base-index cache)

1019

(declare (fixnum base-index)

1020

(type (simple-array fixnum (* ,base-width)) base-page)

1021

(optimize ,@*field-optimization*))

1022

(let ((key (list ,@(loop for i from 0

1023

for var in base-dimensions

1024

if (find var key-dimensions)

1025

collect `(aref base-page base-index ,i))))

1026

(surrogate (list base-page base-index)))

1027

(push surrogate (gethash key cache))))))

1028

1029

(defun compute-write-cache-op (base-dimensions other-dimensions &key

1030

                                                (key-dimensions (intersect-dimensions base-dimensions other-dimensions)))

1031

   "given the dimensions for the field to be cached and those for the other field, compute the key dimensions

1032

  and generate a function which accepts a solution location and adds it to the list of cached equivalents."

1033

;; constructor allows the cache entries to hold more than the two indices

1034

(let* ((key (list 'compute-write-cache-op base-dimensions other-dimensions key-dimensions))

1035

(function (get-aspect-cache key)))

1036

(or function

1037

(let* ((lambda (compute-write-cache-op-lambda base-dimensions other-dimensions

1038

                                                       :key-dimensions key-dimensions))

1039

(function (spocq-compile lambda)))

1040

(setf (get-aspect-cache key) function)

1041

(values function lambda)))))

1042

1043

1044

(defun compute-extended-write-cache-op-lambda (base-dimensions bindings)

1045

"given the dimensions for the field to be cached and a grouping specification, compute an operator

1046

which accepts a location and adds the solution to the keyed cache."

1047

(flet ((handled-form (form)

1048

(if (member form base-dimensions)

1049

form

1050

`(handler-case ,form (error () nil)))))

1051

(let* ((key-forms (bindings-value-forms bindings))

1052

(key-form-variables (expression-variables key-forms))

1053

(base-width (length base-dimensions)))

1054

(if (null (set-difference key-forms base-dimensions))

1055

(let* ((macros (loop for var in base-dimensions

1056

for i = (position var base-dimensions)

1057

collect `(,var (aref base-page base-index ,i))))

1058

(lambda `(lambda (base-page base-index cache)

1059

(declare (fixnum base-index)

1060

                                   (type (simple-array fixnum (* ,base-width)) base-page)

1061

(optimize ,@*field-optimization*))

1062

(symbol-macrolet ,macros

1063

(let ((key ,(if (rest key-forms)

1064

`(list ,@key-forms)

1065

(first key-forms)))

1066

(surrogate (cons base-page base-index)))

1067

(push surrogate (gethash key cache)))))))

1068

(values (spocq-compile lambda) lambda))

1069

;; implement in terms of term numbers

1070

;; if some expression is present, implement in terms of respective objects

1071

(let* ((macros (append (loop for var in base-dimensions

1072

for i = (position var base-dimensions)

1073

                                      collect `(,var (field-object-or-unbound-aref base-page base-index ,i ,var)))

1074

(loop for var in key-form-variables

1075

unless (find var base-dimensions)

1076

                                      collect `(,var (query-binding-value ',var)))))

1077

(lambda `(lambda (base-page base-index cache)

1078

(declare (fixnum base-index)

1079

                                    (type (simple-array fixnum (* ,base-width)) base-page)

1080

(optimize ,@*field-optimization*))

1081

(symbol-macrolet ,macros

1082

(let ((key ,(if (rest key-forms)

1083

                                           `(list ,@(mapcar #'handled-form key-forms))

1084

                                           (handled-form (first key-forms))))

1085

(surrogate (cons base-page base-index)))

1086

(push surrogate (gethash key cache)))))))

1087

(values (spocq-compile lambda) lambda))))))

1088

1089

(defun compute-extended-write-cache-op (base-dimensions bindings)

1090

"given the dimensions for the field to be cached and a grouping specification, compute an operator

1091

which accepts a location add the solution to the keyed cache."

1092

(let* ((key (list 'compute-extended-write-cache-op base-dimensions bindings))

1093

(function (get-aspect-cache key)))

1094

(or function

1095

(let* ((lambda (compute-extended-write-cache-op-lambda base-dimensions bindings))

1096

(function (spocq-compile lambda)))

1097

(setf (get-aspect-cache key) function)

1098

(values function lambda)))))

1099

1100

1101

(defun compute-extended-key-op-lambda (base-dimensions bindings)

1102

"given the dimensions for the field to be cached and a grouping specification, compute an operator

1103

which accepts a location and returns the computed key atom or list."

1104

(flet ((handled-form (form)

1105

(if (member form base-dimensions)

1106

form

1107

`(handler-case ,form (error () nil)))))

1108

(let* ((key-forms (bindings-value-forms bindings))

1109

(key-form-variables (expression-variables key-forms))

1110

(base-width (length base-dimensions)))

1111

;; implement in terms of term numbers

1112

;; if some expression is present, implement in terms of respective objects

1113

(let* ((macros (append (loop for var in base-dimensions

1114

for i = (position var base-dimensions)

1115

                                collect `(,var (field-object-or-unbound-aref base-page base-index ,i ,var)))

1116

(loop for var in key-form-variables

1117

unless (find var base-dimensions)

1118

collect `(,var (query-binding-value ',var)))))

1119

(lambda `(lambda (base-page base-index)

1120

(declare (fixnum base-index)

1121

                                  (type (simple-array fixnum (* ,base-width)) base-page)

1122

(optimize ,@*field-optimization*)

1123

(ignorable base-page base-index))

1124

(symbol-macrolet ,macros

1125

,(if (rest key-forms)

1126

`(list ,@(mapcar #'handled-form key-forms))

1127

(handled-form (first key-forms)))))))

1128

(values (spocq-compile lambda) lambda)))))

1129

1130

(defun compute-extended-key-op (base-dimensions bindings)

1131

"given the dimensions for the field to be cached and a grouping specification, compute an operator

1132

which accepts a location and returns the computed key atom or list."

1133

(let* ((key (list 'compute-extended-key-op base-dimensions bindings))

1134

(function (get-aspect-cache key)))

1135

(or function

1136

(let* ((lambda (compute-extended-key-op-lambda base-dimensions bindings))

1137

(function (spocq-compile lambda)))

1138

(setf (get-aspect-cache key) function)

1139

(values function lambda)))))

1140

1141

(defun compute-simple-key-op-lambda (key-dimensions base-dimensions)

1142

"given the dimensions for the key and the field return the key constituents as a list."

1143

1144

(let* ((base-width (length base-dimensions)))

1145

`(lambda (base-page base-index)

1146

(declare (fixnum base-index)

1147

(type (simple-array fixnum (* ,base-width)) base-page)

1148

(optimize ,@*field-optimization*)

1149

(ignorable base-page base-index)) ; is the case for a null key

1150

,(when key-dimensions

1151

`(list ,@(loop for i from 0

1152

for var in base-dimensions

1153

if (find var key-dimensions)

1154

collect `(aref base-page base-index ,i)))))))

1155

1156

(defun compute-simple-key-op (key-dimensions base-dimensions)

1157

"given the dimensions for the key and the field return the key constituents as a list."

1158

1159

(let* ((key (list 'compute-simple-key-op-lambda key-dimensions base-dimensions))

1160

(function (get-aspect-cache key)))

1161

(or function

1162

(let* ((lambda (compute-simple-key-op-lambda key-dimensions base-dimensions))

1163

(function (spocq-compile lambda)))

1164

(setf (get-aspect-cache key) function)

1165

(values function lambda)))))

1166

1167

;;;

1168

;;; spread operators : retain individual solutions as vectors rather than as page references

1169

1170

(defun compute-binary-cache-op-lambda-spread (base-dimensions other-dimensions)

1171

"given the result solution dimensions and those for the to-cache and to-retrieve constituents,

1172

  compute a function which accepts a source solution location, adds the solution location to the first cache

1173

and retrieves the list of matched solution locations from the second cache."

1174

1175

(let* ((key-dimensions (intersect-dimensions base-dimensions other-dimensions))

1176

(base-width (length base-dimensions)))

1177

`(lambda (base-page base-index put-cache get-cache

1178

                         &optional (surrogate (make-array ,base-width :element-type 'fixnum)))

1179

(declare (fixnum base-index)

1180

(type (simple-array fixnum (* ,base-width)) base-page)

1181

(type (vector fixnum ,base-width) surrogate)

1182

(optimize ,@*field-optimization*))

1183

(let ((key (list ,@(loop for i from 0

1184

for var in base-dimensions

1185

if (find var key-dimensions)

1186

collect `(aref base-page base-index ,i)))))

1187

(dotimes (i ,base-width)

1188

(setf (aref surrogate i) (aref base-page base-index i)))

1189

(trace-data binary-cache-op base-index surrogate key)

1190

          (when put-cache                ; allow, that one side completes and thus the other no longer caches

1191

(push surrogate (gethash key put-cache)))

1192

(values (when get-cache (gethash key get-cache)) surrogate)))))

1193

1194

(defun compute-binary-cache-op-spread (base-dimensions other-dimensions)

1195

"given the result solution dimensions and those for the to-cache and to-retrieve constituents,

1196

  compute a function which accepts a source solution location, adds the solution location to the first cache

1197

and retrieves the list of matched solution locations from the second cache."

1198

1199

(let* ((key (list 'compute-binary-cache-op-spread base-dimensions other-dimensions))

1200

(function (get-aspect-cache key)))

1201

(or function

1202

(let* ((lambda (compute-binary-cache-op-lambda-spread base-dimensions other-dimensions))

1203

(function (spocq-compile lambda)))

1204

(setf (get-aspect-cache key) function)

1205

(values function lambda)))))

1206

1207

1208

(defun compute-binary-collector-lambda-spread (result-dimensions left-dimensions right-dimensions)

1209

"given the result solution dimensions and those for the left and right constituents,

1210

compute a function which accepts spread arguments for the result and the source pages and indices

1211

and sets the reults solution to the combination of the two source solutions."

1212

1213

(let ((result-width (length result-dimensions))

1214

(left-width (length left-dimensions))

1215

(right-width (length right-dimensions)))

1216

`(lambda (result-page result-index left-solution right-solution)

1217

(declare (fixnum result-index)

1218

(type (simple-array fixnum (* ,(length result-dimensions))) result-page)

1219

(type (vector fixnum ,left-width) left-solution)

1220

(type (vector fixnum ,right-width) right-solution)

1221

(optimize ,@*field-optimization*))

1222

,@(loop for result-i from 0

1223

for result-variable in result-dimensions

1224

for left-i = (position result-variable left-dimensions)

1225

for right-i = (position result-variable right-dimensions)

1226

collect `(setf (aref result-page result-index ,result-i)

1227

,(cond (left-i `(aref left-solution ,left-i))

1228

(right-i `(aref right-solution ,right-i))

1229

(t +null-term-id+))))

1230

        (trace-data binary-collector (type-of result-page) result-index (type-of left-solution) (type-of right-solution)

1231

(make-array ,result-width :displaced-to result-page :element-type 'fixnum

1232

                                :displaced-index-offset (* result-index ,result-width))

1233

left-solution

1234

right-solution))))

1235

1236

(defun compute-binary-collector-spread (solution-dimensions left-dimensions right-dimensions)

1237

"given the result solution dimensions and those for the left and right constituents,

1238

compute a function which accepts spread arguments for the result and the source pages and indices

1239

and sets the reults solution to the combination of the two source solutions."

1240

1241

(let* ((key (list 'compute-binary-collector-spread solution-dimensions left-dimensions right-dimensions))

1242

(function (get-aspect-cache key)))

1243

(or function

1244

         (let* ((lambda (compute-binary-collector-lambda-spread solution-dimensions left-dimensions right-dimensions))

1245

(function (spocq-compile lambda)))

1246

(setf (get-aspect-cache key) function)

1247

(values function lambda)))))

1248

1249

1250

(defun compute-binary-predicate-lambda-spread (test left-dimensions right-dimensions &key (handle-errors t))

1251

"given the parameter dimensions for a predicate and those for the left and right constituents,

1252

compute a function wrapper which accepts the predicate and the respective solution locations

1253

and applies the function to the named terms in the solutions.

1254

1255

declare the dimensions of the join for the case where an exists filter is involved, in order

1256

that it can compile readers for the argument fields."

1257

1258

(let* ((parameters (expression-free-dimensions test))

1259

(matched-variables (expression-matched-variables test))

1260

(left-count 0)

1261

(right-count 0)

1262

(undefined-variables ())

1263

(macros (loop for parameter in parameters

1264

for left-i = (position parameter left-dimensions)

1265

for right-i = (position parameter right-dimensions)

1266

collect `(,parameter ,(cond (left-i (incf left-count)

1267

                                                            `(field-vector-object-aref left-solution ,left-i ,parameter))

1268

                                                    (right-i (incf right-count)

1269

                                                             `(field-vector-object-aref right-solution ,right-i ,parameter))

1270

                                                    (t (push parameter undefined-variables)

1271

                                                       `(query-binding-value ',parameter))))))

1272

(lambda `(lambda (left-solution right-solution)

1273

(declare (type (vector fixnum ,(length left-dimensions)) left-solution)

1274

                              (type (vector fixnum ,(length right-dimensions)) right-solution)

1275

(optimize ,@*field-optimization*)

1276

                              ;; in the event that the filter is just exists, the references

1277

;; are not in this lexical context

1278

(ignorable left-solution right-solution)

1279

                              (spocq.e:join-dimensions ,(union-dimensions left-dimensions right-dimensions)

1280

                                                        ,left-dimensions ,right-dimensions))

1281

                     ;; nb. an exists filter can reference a page even though the variables are not visible

1282

,@(unless (plusp left-count) '((declare (ignorable left-solution))))

1283

,@(unless (plusp right-count) '((declare (ignorable right-solution))))

1284

(symbol-macrolet ,macros

1285

                       ;; the handler adds about 25% to predicate processing, but without it, call sites need to establish

1286

;; their own per-iteration error catch-and-skip logic

1287

,(if handle-errors

1288

`(handler-case (ebv ,test) (error () nil))

1289

`(ebv ,test))))))

1290

(when (set-difference undefined-variables matched-variables)

1291

(case (undefined-variable-behavior)

1292

(|urn:dydra|:|error| (spocq.e:compilation-error :expression test

1293

                                    :condition (make-condition 'spocq.e:undefined-variable-error

1294

                                                               :variables undefined-variables)))

1295

(|urn:dydra|:|warning| (log-warn "~@[~a: ~]~a"

1296

*query*

1297

(make-condition 'spocq.e:undefined-variable-error

1298

:expression test

1299

:variables undefined-variables))

1300

(push `(declare (special ,@undefined-variables)) (cddr lambda)))

1301

(|urn:dydra|:|dynamicBinding| (push `(declare (special ,@undefined-variables)) (cddr lambda)))))

1302

lambda))

1303

1304

(defun compute-binary-predicate-spread (test left-dimensions right-dimensions &key (handle-errors t))

1305

"given the parameter dimensions for a predicate and those for the left and right constituents,

1306

compute a function wrapper which accepts the predicate and the respective solution locations

1307

and applies the function to the named terms in the solutions."

1308

1309

(flet ((true-binary-predicate (left-solution right-solution)

1310

(declare (ignore left-solution right-solution))

1311

t))

1312

(if test

1313

(let* ((key (list 'compute-binary-predicate-spread test left-dimensions right-dimensions))

1314

(function (get-aspect-cache key)))

1315

(or function

1316

             (let* ((lambda (compute-binary-predicate-lambda-spread test left-dimensions right-dimensions :handle-errors handle-errors))

1317

(function (spocq-compile lambda)))

1318

(setf (get-aspect-cache key) function)

1319

(values function lambda))))

1320

#'true-binary-predicate)))

1321

1322

1323

 (defun compute-binary-vector-comparison-lambda (left-dimensions right-dimensions left-sort-dimensions right-sort-dimensions)

1324

(let ((shared-dimensions (intersect-dimensions left-dimensions right-dimensions)))

1325

(flet ((shared-p (d) (member d shared-dimensions)))

1326

(declare (dynamic-extent #'shared-p))

1327

(if (and left-dimensions right-dimensions

1328

(equal (remove-if-not #'shared-p left-sort-dimensions)

1329

(remove-if-not #'shared-p right-sort-dimensions)))

1330

(let* ((comparisons (loop for dimension in shared-dimensions

1331

for left-i = (position dimension left-dimensions)

1332

for right-i = (position dimension right-dimensions)

1333

collect (list left-i right-i)))

1334

(lambda `(lambda (left-solution right-solution)

1335

                           (declare (type (vector fixnum ,(length left-dimensions)) left-solution)

1336

                                    (type (vector fixnum ,(length right-dimensions)) right-solution)

1337

(optimize ,@*field-optimization*)

1338

                                    ;; in the event that the filter is just exists, the references

1339

;; are not in this lexical context

1340

(ignorable left-solution right-solution)

1341

                                    (spocq.e:join-dimensions ,(union-dimensions left-dimensions right-dimensions)

1342

                                                             ,left-dimensions ,right-dimensions))

1343

,(let ((result '(quote =)))

1344

(loop for (left-i right-i) in comparisons

1345

                                    do (setf result `(if (= (aref left-solution ,left-i) (aref right-solution ,right-i))

1346

,result

1347

                                                       (if (< (aref left-solution ,left-i) (aref right-solution ,right-i))

1348

                                                         '< '>))))

1349

result))))

1350

lambda)

1351

;; if the order is different or unknown

1352

'(lambda (left-solution right-solution)

1353

(declare (ignore left-solution right-solution))

1354

'>)))))

1355

;;; (pprint (compute-binary-vector-predicate-lambda '(a b c) '(a c e) '(c a b) '(c e a)))

1356

1357

 (defun compute-binary-vector-comparison (left-dimensions right-dimensions left-sort-dimensions right-sort-dimensions)

1358

(let* ((key (list 'compute-binary-vector-comparison left-dimensions right-dimensions))

1359

(function (get-aspect-cache key)))

1360

(or function

1361

(let* ((lambda (compute-binary-vector-comparison-lambda left-dimensions right-dimensions

1362

                                                                left-sort-dimensions right-sort-dimensions))

1363

(function (spocq-compile lambda)))

1364

(setf (get-aspect-cache key) function)

1365

(values function lambda)))))