Coverage report: /home/ati/workspace/perec/query/compiler.lisp

Kind	Covered	All	%
expression	1073	1301	82.5
branch	70	100	70.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;(declaim-debug)

10

11

(enable-pattern-reader #\M)

12

13

;;;; TODO: sorting and grouping

14

;;;; TODO: embedded SQL in queries

15

;;;; TODO: return nil if there is contradiction between asserts

16

;;;; TODO: eliminate tautologies from asserts

17

;;;; TODO: n-m associations

18

;;;; TODO: delete and update operations

19

;;;; TODO: recursive selects

20

21

;;;

22

;;; Compile queries

23

;;;

24

(defvar *compile-query-counter* 0

25

"Number of calls to COMPILE-QUERY. (FOR TESTING)")

26

27

(defvar *test-query-compiler* nil

28

"When true, the compiled form performs a runtime check by comparing the result of the query

29

with the result of the naively compiled query.")

30

31

(defun reset-compile-query-counter ()

32

(setf *compile-query-counter* 0))

33

34

(defmethod compile-query :before (query)

35

(incf *compile-query-counter*))

36

37

(defmethod compile-query ((query query))

38

(%compile-query (make-instance 'trivial-query-compiler) query))

39

40

(defmethod compile-query ((query simple-query))

41

(if *test-query-compiler*

42

(%compile-query (make-instance 'debug-query-compiler) query)

43

(%compile-query (make-instance 'simple-query-compiler) query)))

44

45

(defclass* query-compiler ()

46

()

47

(:documentation "Generic query compiler, which can transform to sql to any select form."))

48

49

(defgeneric %compile-query (compiler query)

50

(:documentation "Compiles the query with the specified compiler."))

51

52

(defmethod %compile-query ((compiler query-compiler) (query query))

53

(unparse-query-syntax

54

(optimize-query

55

compiler

56

(emit-query

57

compiler

58

(transform-query

59

compiler

60

query)))))

61

62

(defgeneric transform-query (compiler query)

63

(:documentation "TODO")

64

65

(:method (compiler query)

66

query))

67

68

(defgeneric emit-query (compiler query)

69

(:documentation "TODO"))

70

71

(defgeneric optimize-query (compiler syntax)

72

(:documentation "TODO")

73

74

(:method (compiler syntax)

75

syntax))

76

77

;;;;

78

;;;; Trivial query compiler

79

;;;;

80

(defclass* trivial-query-compiler (query-compiler)

81

()

82

   (:documentation "Query compiler that can compile any select form, but does not optimize sql queries."))

83

84

(defmethod emit-query ((compiler trivial-query-compiler) query)

85

(bind ((lexical-variables (lexical-variables-of query))

86

(variables (get-query-variable-names query))

87

(body (body-of query))

88

(body (mapcar 'query-macroexpand body))

89

(persistent-object-literals (collect-persistent-object-literals body))

90

(persistent-object-variables (mapcar #L(gensym (symbol-name (class-name (class-of !1))))

91

                                               persistent-object-literals)))

92

(with-unique-names (objects result-list)

93

`(lambda ,lexical-variables

94

(declare (ignorable ,@lexical-variables))

95

,@(mapcar #L(`(load-instance ,!1)) persistent-object-literals)

96

         (let (,@(mapcar #L(`(,!1 (load-instance ,!2))) persistent-object-variables persistent-object-literals)

97

(,objects (mapcar 'cache-object

98

                                 (execute ,(sql-select-oids-for-class 'persistent-object))))

99

(,result-list nil))

100

(flet ((assert! (cond) (when (not cond) (throw 'fail nil)))

101

(collect (&rest exprs) (push exprs ,result-list))

102

(purge (&rest objects) (mapc 'make-transient objects))

103

(order-by (&rest order-spec) nil)) ; TODO

104

             (declare (ignorable (function assert!) (function collect) (function purge) (function order-by)))

105

(bind-cartesian-product ((,@variables) ,objects)

106

(catch 'fail

107

(progn

108

,@(sublis

109

(cons '(assert . assert!)

110

                            (mapcar 'cons persistent-object-literals persistent-object-variables))

111

body)))))

112

,(add-conversion-to-result-type

113

query

114

(add-unique-filter

115

query

116

`(make-list-result-set (nreverse ,result-list)))))))))

117

118

;;;;

119

;;;; Debug query compiler

120

;;;;

121

(defclass* debug-query-compiler (query-compiler)

122

()

123

(:documentation "Generic query compiler, which can transform to sql to any select form and

124

wraps the compiled code with a runtime check of the result."))

125

126

(defmethod %compile-query ((compiler debug-query-compiler) (query query))

127

"Emits code that checks that the result of COMPILED-FORM equals

128

to the result of the PREDICATE-FORM."

129

(let* ((predicate-form (%compile-query (make-instance 'trivial-query-compiler) query))

130

(compiled-form (%compile-query (make-instance 'simple-query-compiler) query))

131

(lexical-variables (lexical-variables-of query)))

132

(with-unique-names (result expected result-list expected-list)

133

(unparse-query-syntax

134

`(lambda ,lexical-variables

135

(declare (ignorable ,@lexical-variables))

136

(bind ((,result (funcall ,compiled-form ,@lexical-variables))

137

(,expected (funcall ,predicate-form ,@lexical-variables))

138

(,result-list (to-list ,result))

139

(,expected-list (to-list ,expected)))

140

;; TODO: set-exclusive-or is not ok for comparing the results, because

141

;; the result is not a set and (set-exclusive-or '(a b b) '(a a b))

142

;; returns NIL.

143

(when (set-exclusive-or ,result-list ,expected-list :test 'equal)

144

(cerror "Return the expected result." 'query-error

145

:query ,query :result ,result-list :expected ,expected-list))

146

,expected))))))

147

148

(define-condition query-error ()

149

((query :initarg :query)

150

(result :initarg :result)

151

(expected :initarg :expected))

152

153

(:report (lambda (condition stream)

154

(format stream "Query ~S failed. Result is ~:W, but expected ~:W."

155

(slot-value condition 'query)

156

(slot-value condition 'result)

157

(slot-value condition 'expected))))

158

159

(:documentation "Condition signalling that the runtime check of the query failed."))

160

161

;;;;---------------------------------------------------------------------------

162

;;;; Simple query compiler

163

;;;;

164

(defclass* simple-query-compiler (query-compiler)

165

()

166

(:documentation "Query compiler that can transform to sql to simple select forms."))

167

168

(defmethod emit-query ((compiler simple-query-compiler) (query simple-query))

169

(ecase (action-of query)

170

(:collect (emit-select query))

171

(:purge (emit-purge query))))

172

173

(defun emit-purge (query)

174

(bind ((lexical-variables (lexical-variables-of query))

175

(asserts (asserts-of query))

176

(variables (query-variables-of query))

177

(purge-var (first (action-args-of query)))

178

(type (xtype-of purge-var))

179

(substitutions (generate-persistent-object-substitutions query)))

180

(if asserts

181

;; execute deletes from lisp filter

182

(with-unique-names (row)

183

`(lambda ,lexical-variables

184

(declare (ignorable ,@lexical-variables))

185

(let (,@(emit-persistent-object-bindings substitutions))

186

,(substitute-syntax

187

`(execute ,(sql-select-for-query query)

188

:visitor

189

(lambda (,row)

190

(let ,(emit-query-variable-bindings variables row #f)

191

,(emit-ignorable-variables-declaration variables)

192

(when (and ,@asserts)

193

(make-transient ,(first (action-args-of query)))))))

194

substitutions))))

195

;; execute deletes from sql

196

(bind (((values deletes cleanup) (sql-deletes-for-query query)))

197

`(lambda ,lexical-variables

198

(declare (ignorable ,@lexical-variables))

199

(let (,@(emit-persistent-object-bindings substitutions))

200

(invalidate-persistent-flag-of-cached-objects (find-persistent-class* ,type))

201

,(substitute-syntax

202

(if cleanup

203

`(unwind-protect (mapc 'execute ,deletes) (execute ,cleanup))

204

`(mapc 'execute ,deletes))

205

substitutions)))))))

206

207

(defun emit-select (query)

208

"Emits code that for the compiled query."

209

(bind ((lexical-variables (lexical-variables-of query)))

210

(if (contradictory-p query)

211

`(lambda ,lexical-variables

212

(declare (ignorable ,@lexical-variables))

213

,(empty-result query))

214

(bind ((substitutions (generate-persistent-object-substitutions query)))

215

`(lambda ,lexical-variables

216

(declare (ignorable ,@lexical-variables))

217

(let (,@(emit-persistent-object-bindings substitutions))

218

,(substitute-syntax

219

(add-conversion-to-result-type

220

query

221

(add-unique-filter

222

query

223

(add-mapping-for-collects

224

query

225

(add-sorter-for-order-by

226

query

227

(add-filter-for-asserts

228

query

229

`(open-result-set

230

',(result-type-of query)

231

,(partial-eval (sql-select-for-query query) query)))))))

232

substitutions)))))))

233

234

(defun empty-result (query)

235

(ecase (result-type-of query)

236

(list nil)

237

(scroll '(make-instance 'simple-scroll))))

238

239

(defun add-filter-for-asserts (query form)

240

(bind ((variables (query-variables-of query))

241

(asserts (asserts-of query))

242

(prefetchp (prefetchp query)))

243

(with-unique-names (row)

244

(if asserts

245

`(make-filtered-result-set

246

,form

247

(lambda (,row)

248

(let (,@(emit-query-variable-bindings variables row prefetchp))

249

,(emit-ignorable-variables-declaration variables)

250

(and ,@asserts))))

251

form))))

252

253

(defun add-sorter-for-order-by (query form)

254

(bind ((variables (query-variables-of query))

255

(order-by (order-by-of query))

256

(prefetchp (prefetchp query)))

257

(labels ((rename-query-variables (expr suffix)

258

"Adds the SUFFIX to each query variable symbol in EXPR."

259

(sublis (mapcar #L(cons (name-of !1) (concatenate-symbol (name-of !1) suffix))

260

variables)

261

expr))

262

(generate-variable-bindings (row suffix)

263

(rename-query-variables (emit-query-variable-bindings variables row prefetchp)

264

suffix))

265

(generate-lessp-body (order-by)

266

"Builds the body of the lessp predicate."

267

(bind ((lessp (ecase (first order-by) (:asc 'lessp) (:desc 'greaterp)))

268

(expr1 (rename-query-variables (second order-by) "1"))

269

(expr2 (rename-query-variables (second order-by) "2")))

270

(if (null (cddr order-by))

271

`(,lessp ,expr1 ,expr2)

272

(with-unique-names (obj1 obj2)

273

`(let ((,obj1 ,expr1)

274

(,obj2 ,expr2))

275

(or

276

(,lessp ,obj1 ,obj2)

277

(and

278

(equal ,obj1 ,obj2)

279

,(generate-lessp-body (cddr order-by))))))))))

280

(if (and order-by (or (member :asc order-by) (member :desc order-by)))

281

(with-unique-names (row1 row2)

282

`(make-ordered-result-set

283

,form

284

(lambda (,row1 ,row2)

285

(let (,@(generate-variable-bindings row1 "1")

286

,@(generate-variable-bindings row2 "2"))

287

,(generate-lessp-body order-by)))))

288

form))))

289

290

(defun add-mapping-for-collects (query form)

291

(bind ((variables (query-variables-of query))

292

(collects (collects-of query))

293

(prefetchp (prefetchp query)))

294

(with-unique-names (row)

295

`(make-mapped-result-set

296

,form

297

(lambda (,row)

298

(let (,@(emit-query-variable-bindings variables row prefetchp))

299

,(emit-ignorable-variables-declaration variables)

300

(list ,@collects)))))))

301

302

(defun add-unique-filter (query form)

303

(if (uniquep query)

304

`(make-unique-result-set ,form)

305

form))

306

307

(defun add-conversion-to-result-type (query form)

308

(ecase (result-type-of query)

309

(list `(to-list ,form ,(flatp query)))

310

(scroll `(to-scroll ,form))))

311

312

(defun emit-query-variable-bindings (variables row prefetchp)

313

(iter (for variable in variables)

314

(for slots = (when prefetchp (prefetched-slots-for variable)))

315

(for column-count = (reduce '+ slots

316

:key 'column-count-of

317

:initial-value (length +oid-column-names+)))

318

(for i initially 0 then (+ i column-count))

319

(collect `(,(name-of variable) (cache-object-with-prefetched-slots ,row ,i ',slots)))))

320

321

(defun emit-ignorable-variables-declaration (variables)

322

`(declare (ignorable ,@(mapcar 'name-of variables))))

323

324

(defun generate-persistent-object-substitutions (query)

325

(bind ((objects (collect-persistent-object-literals query))

326

(variables (mapcar #L(gensym (symbol-name (class-name (class-of !1)))) objects)))

327

(mapcar 'cons objects variables)))

328

329

(defun emit-persistent-object-bindings (substitutions)

330

(mapcar #L(`(,(cdr !1) (load-instance ,(car !1)))) substitutions))

331

332

;;;;---------------------------------------------------------------------------

333

;;;; Transformations

334

;;;;

335

(defmethod transform-query ((compiler simple-query-compiler) (query simple-query))

336

"Transforms the QUERY by pushing down the asserts to the SQL query."

337

(macroexpand-query query)

338

(parse-query query)

339

(normalize-query query)

340

(infer-types query)

341

(introduce-joined-variables query)

342

(partial-eval-asserts query)

343

(when (not (contradictory-p query))

344

(let ((*suppress-alias-names* (simple-purge-p query)))

345

(build-sql query)))

346

query)

347

348

(defun macroexpand-query (query)

349

"Expands query macros in QUERY."

350

(setf (asserts-of query)

351

(mapcar 'query-macroexpand (asserts-of query))))

352

353

(defun parse-query (query)

354

(bind ((variables (get-variables query)))

355

(setf (asserts-of query) (mapcar #L(parse-query-form !1 variables) (asserts-of query)))

356

(setf (action-args-of query) (mapcar #L(parse-query-form !1 variables) (action-args-of query)))

357

(setf (order-by-of query) (iter (for (dir expr) on (order-by-of query) by 'cddr)

358

                                     (nconcing (list dir (parse-query-form expr variables)))))))

359

360

(defun normalize-query (query)

361

(setf (asserts-of query)

362

(mappend #L(conjuncts-of

363

(simplify-boolean-syntax

364

(normalize-syntax

365

(partial-eval !1 query))))

366

(asserts-of query))))

367

368

(defun conjuncts-of (syntax)

369

"Return a list of the conjuncts in SYNTAX."

370

(pattern-case syntax

371

(#M(macro-call :macro and) (args-of syntax))

372

(#M(literal-value :value #t) nil)

373

(?otherwise (list syntax))))

374

375

(defgeneric normalize-syntax (syntax)

376

(:documentation "Normalizes type asserts to (typep ...) forms to ease further processing:

377

(typep <object> '<class-name>) -> (typep <object> <class>)

378

(subtypep (class-of <obj>) '<class-name>) -> (typep <object> <class>)

379

(subtypep (class-of <obj>) <type>) -> (typep <object> <type>)

380

381

if the assoc is 1-1

382

(eq (<primary-assoc-end-accessor> <obj1>) <obj2>) ->

383

                                            (eq (secondary-assoc-end-accessor <obj2>) <obj1>)")

384

385

(:method (syntax)

386

syntax)

387

(:method ((form compound-form))

388

(setf (operands-of form)

389

(mapcar 'normalize-syntax (operands-of form)))

390

form)

391

(:method ((call function-call))

392

(call-next-method)

393

(pattern-case call

394

(#M(function-call :fn typep

395

                                :args (?obj #M(literal-value :value (?is ?class persistent-class-p))))

396

call)

397

(#M(function-call :fn typep

398

                                :args (?obj #M(literal-value :value (?is ?name persistent-class-name-p))))

399

(setf (second (args-of call)) (make-literal-value :value (find-class ?name)))

400

call)

401

(#M(function-call :fn subtypep

402

                                :args (#M(function-call :fn class-of :args (?object))

403

                                         #M(literal-value :value (?is ?name persistent-class-name-p))))

404

(make-function-call :fn 'typep

405

:args (list ?object

406

                                                 (make-literal-value :value (find-class ?name)))))

407

(#M(function-call :fn subtypep

408

                                :args (#M(function-call :fn class-of :args (?object)) ?type))

409

(make-function-call :fn 'typep :args (list ?object ?type)))

410

;; TODO reverse 1-1 association-end

411

(?otherwise

412

call))))

413

414

(defun introduce-joined-variables (query)

415

(mapc #L(introduce-joined-variables-for !1 query) (asserts-of query))

416

(mapc #L(introduce-joined-variables-for !1 query) (action-args-of query))

417

(mapc #L(when (syntax-object-p !1) (introduce-joined-variables-for !1 query)) (order-by-of query)))

418

419

(defgeneric introduce-joined-variables-for (syntax query)

420

(:documentation "Substitutes the arguments of slot accessor forms with joined variables.")

421

;; atoms, unparsed

422

(:method (syntax query)

423

(values))

424

;; recurse on compound forms

425

(:method ((syntax compound-form) query)

426

(mapc #L(introduce-joined-variables-for !1 query) (operands-of syntax)))

427

;; slot access -> ensure that arg is a query variable with the correct type

428

(:method ((access slot-access) query)

429

(call-next-method)

430

(when (association-end-access-p (arg-of access))

431

(setf (arg-of access)

432

(joined-variable-for-association-end-access query (arg-of access))))

433

(when (slot-of access)

434

(setf (arg-of access)

435

                    (ensure-type query (arg-of access) (slot-definition-class (slot-of access)))))

436

(values)))

437

438

(defun partial-eval-asserts (query)

439

(setf (asserts-of query)

440

(mapcar #L(partial-eval !1 query) (asserts-of query))))

441

442

(defun contradictory-p (query)

443

(is-false-literal

444

(simplify-boolean-syntax

445

(make-macro-call :macro 'and :args (asserts-of query)))))

446

447

(defun build-sql (query)

448

"Converts assert conditions and order by specifications to SQL."

449

(iter (for variable in (query-variables-of query))

450

(when (joined-variable-p variable)

451

(add-where-clause query (sql-join-condition-for-joined-variable variable))))

452

(setf (asserts-of query)

453

(iter (for condition in (asserts-of query))

454

(bind (((values sql success) (transform-to-sql condition)))

455

(if success

456

(add-where-clause query sql)

457

(collect condition)))))

458

(bind ((new-order-by (iter (for (dir expr) on (order-by-of query) by 'cddr)

459

                              (bind (((values sort-key success) (transform-to-sql expr))

460

                                     (ordering (ecase dir (:asc :ascending) (:desc :descending))))

461

(if success

462

&