gazagnaire.org
SQL frontend over the catalog engine
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Ast
7
8(* SQLite's value-level semantics (comparison order, collation, text conversion,
9 aggregate folds) live in {!Value_ops}, shared with the register-VM paths;
10 open it so the tree-walker uses the same folds and orders by the same
11 rule. *)
12open Value_ops
13
14(* The built-in scalar / table-valued functions live in {!Func} (also shared
15 with the VM); open it so the tree-walker dispatches them through the same
16 value-level implementations. *)
17open Func
18
19(* The value-level binary operators (comparison with affinity, AND/OR/LIKE/GLOB/
20 JSON, IN-list) live in {!Value_op}; open it so the tree-walker evaluates an
21 operator through the same shared implementation as the VM. *)
22open Value_op
23
24type catalog = {
25 columns : string -> string list;
26 rows : string -> Catalog.Value.t list list;
27 rows_rowid : string -> (int64 option * Catalog.Value.t list) list;
28 (** Each row paired with its rowid, or [None] for a row source that has no
29 rowid (a view, a derived table, [VALUES]). Lets the executor resolve
30 the implicit [rowid]/[oid]/[_rowid_] column of a full table scan. *)
31 index_scan :
32 string ->
33 (string * Catalog.Value.t) list ->
34 (string * Catalog.Value.t list list) option;
35 (** [index_scan table eqs] returns [Some (index_name, rows)] if an index
36 on [table] serves the column-equality bindings [eqs] -- the rows whose
37 indexed columns match, by which the caller narrows a scan -- or [None]
38 to fall back to a full {!rows} scan. *)
39 index_for : string -> string list -> string option;
40 (** [index_for table cols] is the name of a unique index on [table] all of
41 whose columns are among [cols], if any -- the structural counterpart
42 of {!index_scan} (no values), used to explain the plan. *)
43 collation : string -> string -> string option;
44 (** [collation table col] is [col]'s declared [COLLATE] sequence
45 (uppercase) on [table], or [None] for the default binary / a derived
46 source. *)
47}
48
49let of_catalog cat =
50 {
51 columns = Catalog.Spi.columns cat;
52 rows = Catalog.Spi.rows cat;
53 rows_rowid = Catalog.Spi.rows_rowid cat;
54 index_scan = Catalog.Spi.index_scan cat;
55 index_for = Catalog.Spi.index_for cat;
56 collation = Catalog.Spi.collation cat;
57 }
58
59(* The runner used for every SELECT [eval] reaches: a scalar / [IN] / [EXISTS]
60 subquery, a FROM-subquery, a CTE body, and the recursive-CTE seed / arms,
61 given the enclosing-row [cat], the outer scope, the subquery, and the params.
62 Held in a private ref behind {!set_cat_subquery_runner}: the catalog-VM
63 engine that fulfils it ({!Engine.run_select}) sits above this module, so it
64 is injected, not called directly. {!Engine} installs it on load; a consumer
65 that reaches a SELECT without the engine linked gets a clear error. *)
66let cat_subquery_runner :
67 (catalog ->
68 (string * (string * Catalog.Value.t) list) list ->
69 Ast.select ->
70 Catalog.Value.t array ->
71 Catalog.Value.t list list)
72 ref =
73 ref (fun _ _ _ _ ->
74 failwith "Query: no SELECT runner installed (link Sql.Engine)")
75
76let set_cat_subquery_runner f = cat_subquery_runner := f
77
78(* ── Parameter numbering ─────────────────────────────────────── *)
79
80(* Renumber [?] placeholders left-to-right. [next] is a monotonic counter; the
81 explicit [let] bindings force left-to-right traversal so placeholders are
82 numbered in source order regardless of OCaml's argument evaluation. *)
83let rec renum_expr next = function
84 | Param _ -> Param (next ())
85 | (Lit _ | Col _ | Star | Qualified_star _) as e -> e
86 | Unop_not e -> Unop_not (renum_expr next e)
87 | Binary (op, a, b) ->
88 let a = renum_expr next a in
89 let b = renum_expr next b in
90 Binary (op, a, b)
91 | Is_null e -> Is_null (renum_expr next e)
92 | Is_not_null e -> Is_not_null (renum_expr next e)
93 | Is (a, b) ->
94 let a = renum_expr next a in
95 Is (a, renum_expr next b)
96 | In_list (e, l) ->
97 let e = renum_expr next e in
98 In_list (e, renum_exprs next l)
99 | In_select (e, s) ->
100 let e = renum_expr next e in
101 In_select (e, renum_select next s)
102 | Scalar_select s -> Scalar_select (renum_select next s)
103 | Exists s -> Exists (renum_select next s)
104 | Func (n, args) -> Func (n, renum_exprs next args)
105 | Distinct_agg (n, e) -> Distinct_agg (n, renum_expr next e)
106 | Filter (a, p) -> Filter (renum_expr next a, renum_expr next p)
107 | Ordered_agg (a, ob) ->
108 Ordered_agg
109 (renum_expr next a, List.map (fun (e, d) -> (renum_expr next e, d)) ob)
110 | Window (a, w) ->
111 let bound = function
112 | (Unbounded_preceding | Current_row | Unbounded_following) as b -> b
113 | Preceding e -> Preceding (renum_expr next e)
114 | Following e -> Following (renum_expr next e)
115 in
116 Window
117 ( renum_expr next a,
118 {
119 partition = List.map (renum_expr next) w.partition;
120 order = List.map (fun (e, d) -> (renum_expr next e, d)) w.order;
121 frame =
122 Option.map
123 (fun (f : frame) ->
124 { f with start = bound f.start; end_ = bound f.end_ })
125 w.frame;
126 } )
127 | Cast (e, ty) -> Cast (renum_expr next e, ty)
128 | Collate (e, c) -> Collate (renum_expr next e, c)
129 | Case (base, branches, els) ->
130 let base = Option.map (renum_expr next) base in
131 let branches =
132 List.map
133 (fun (c, r) ->
134 let c = renum_expr next c in
135 (c, renum_expr next r))
136 branches
137 in
138 let els = Option.map (renum_expr next) els in
139 Case (base, branches, els)
140
141and renum_exprs next = function
142 | [] -> []
143 | e :: rest ->
144 let e = renum_expr next e in
145 e :: renum_exprs next rest
146
147(* Source order: SELECT cols, FROM (subquery), JOINs, WHERE, ORDER BY, LIMIT. *)
148and renum_select next (s : select) =
149 let ctes =
150 List.map
151 (fun (c : cte) -> { c with query = renum_select next c.query })
152 s.ctes
153 in
154 let cols =
155 List.map
156 (fun (rc : result_col) -> { rc with expr = renum_expr next rc.expr })
157 s.cols
158 in
159 let from =
160 match s.from with
161 | (Unit | Table _) as f -> f
162 | Select fs -> Select { fs with fs_select = renum_select next fs.fs_select }
163 | Values rows -> Values (List.map (List.map (renum_expr next)) rows)
164 | Table_function tf ->
165 Table_function
166 { tf with tf_args = List.map (renum_expr next) tf.tf_args }
167 in
168 let joins =
169 List.map
170 (fun (j : join) ->
171 let table =
172 match j.table.subquery with
173 | Some q -> { j.table with subquery = Some (renum_select next q) }
174 | None -> j.table
175 in
176 { j with table; on = renum_expr next j.on })
177 s.joins
178 in
179 let where = Option.map (renum_expr next) s.where in
180 let group_by = List.map (renum_expr next) s.group_by in
181 let having = Option.map (renum_expr next) s.having in
182 let compound =
183 List.map (fun (op, arm) -> (op, renum_select next arm)) s.compound
184 in
185 let order_by = List.map (fun (e, d) -> (renum_expr next e, d)) s.order_by in
186 let limit = Option.map (renum_expr next) s.limit in
187 let offset = Option.map (renum_expr next) s.offset in
188 {
189 s with
190 ctes;
191 cols;
192 from;
193 joins;
194 where;
195 group_by;
196 having;
197 compound;
198 order_by;
199 limit;
200 offset;
201 }
202
203let number_params stmt =
204 let counter = ref 0 in
205 let next () =
206 let i = !counter in
207 incr counter;
208 i
209 in
210 let e = renum_expr next and es = renum_exprs next in
211 let rcs l =
212 List.map (fun (rc : result_col) -> { rc with expr = e rc.expr }) l
213 in
214 match stmt with
215 | Select s -> Select (renum_select next s)
216 | Insert (i : insert) ->
217 let source =
218 match i.source with
219 | Values rows -> Values (List.map es rows)
220 | Select s -> Select (renum_select next s)
221 | Default_values -> Default_values
222 in
223 let upsert =
224 Option.map
225 (fun (u : upsert) ->
226 match u.action with
227 | Nothing -> u
228 | Update (sets, w) ->
229 let sets = List.map (fun (c, x) -> (c, e x)) sets in
230 { u with action = Update (sets, Option.map e w) })
231 i.upsert
232 in
233 let returning = rcs i.returning in
234 Insert { i with source; upsert; returning }
235 | Delete d ->
236 let where = Option.map e d.where in
237 Delete { d with where; returning = rcs d.returning }
238 | Update u ->
239 let sets = List.map (fun (c, x) -> (c, e x)) u.sets in
240 let where = Option.map e u.where in
241 Update { u with sets; where; returning = rcs u.returning }
242 | Create_table_as cta ->
243 Create_table_as { cta with query = renum_select next cta.query }
244 | ( Create_table _ | Create_index _ | Create_view _ | Create_trigger _
245 | Drop _ | Alter_table _ | Pragma _ | Begin | Commit | Rollback
246 | Savepoint _ | Release _ | Rollback_to _ | Vacuum | Analyze ) as s ->
247 s
248
249(* ── Values ──────────────────────────────────────────────────── *)
250
251(* ── Three-valued logic ──────────────────────────────────────── *)
252
253(* The collating sequence an operand assigns by a top-level [COLLATE], if any.
254 In a comparison the left operand's explicit collation wins, else the right's
255 (datatype3.html sec.7.1). Column-declared collation is not yet threaded
256 here. *)
257let explicit_collation = function Collate (_, c) -> Some c | _ -> None
258
259(* SQLite integer coercion (as the bitwise/modulo operators apply it): an
260 integer stays itself, a real truncates toward zero, text parses its leading
261 numeric prefix (else 0), NULL is handled by the caller. *)
262
263(* [a << b] / [a >> b]: a negative shift count shifts the other way; a count of
264 64 or more clears the value, matching sqlite3. *)
265let shift dir x n =
266 let n = Int64.to_int n in
267 let lsl_ x n = if n >= 64 then 0L else Int64.shift_left x n in
268 (* arithmetic right shift, so a negative x keeps its sign, as in sqlite3 *)
269 let asr_ x n =
270 if n >= 64 then if x < 0L then -1L else 0L else Int64.shift_right x n
271 in
272 match dir with
273 | `Left -> if n >= 0 then lsl_ x n else asr_ x (-n)
274 | `Right -> if n >= 0 then asr_ x n else lsl_ x (-n)
275
276(* SQLite arithmetic: NULL is contagious; integer op integer stays integer
277 (with [/] truncating and division-by-zero giving NULL); any real operand, or
278 a text operand coerced to a number, makes the result real. The bitwise and
279 modulo operators always work on integers (operands coerced via {!intify}). *)
280(* Does this operand carry REAL affinity? A real literal, or text that parses as
281 a real but not an integer. Mod is computed on integers but returns a real when
282 either operand is real, as sqlite3 does. *)
283(* Add/Sub/Mul/Div: integer when both operands are integers ([/] truncates, /0
284 is NULL), otherwise real (text operands coerced to a number). *)
285(* SQLite computes an integer Add/Sub/Mul/Div that would overflow [int64] as
286 floating point instead of wrapping (e.g. [9223372036854775807 + 1] is a real).
287 Each op detects overflow on the native result and falls back to a float. *)
288let add_checked x y =
289 let r = Int64.add x y in
290 (* overflow iff the operands share a sign and the result's sign flips *)
291 if x >= 0L = (y >= 0L) && r >= 0L <> (x >= 0L) then
292 Float (Int64.to_float x +. Int64.to_float y)
293 else Int r
294
295let sub_checked x y =
296 let r = Int64.sub x y in
297 if x >= 0L <> (y >= 0L) && r >= 0L <> (x >= 0L) then
298 Float (Int64.to_float x -. Int64.to_float y)
299 else Int r
300
301let mul_checked x y =
302 let r = Int64.mul x y in
303 (* check the special [min_int * -1] first so the div below never hits it *)
304 let overflow =
305 x <> 0L && ((x = -1L && y = Int64.min_int) || Int64.div r x <> y)
306 in
307 if overflow then Float (Int64.to_float x *. Int64.to_float y) else Int r
308
309let arith_int op x y =
310 match op with
311 | Add -> add_checked x y
312 | Sub -> sub_checked x y
313 | Mul -> mul_checked x y
314 | Div ->
315 if y = 0L then Null
316 else if x = Int64.min_int && y = -1L then
317 Float (Int64.to_float x /. Int64.to_float y)
318 else Int (Int64.div x y)
319 | _ -> assert false
320
321let arith_float op a b =
322 let f = function
323 | Int i -> Int64.to_float i
324 | Float f -> f
325 | v -> (
326 match float_of_string_opt (String.trim (text_of_value v)) with
327 | Some f -> f
328 | None -> 0.)
329 in
330 let x = f a and y = f b in
331 match op with
332 | Add -> Float (x +. y)
333 | Sub -> Float (x -. y)
334 | Mul -> Float (x *. y)
335 | Div -> if y = 0. then Null else Float (x /. y)
336 | _ -> assert false
337
338let arith op a b =
339 if a = Null || b = Null then Null
340 else
341 match op with
342 | Mod ->
343 let y = intify b in
344 if y = 0L then Null
345 else
346 let r = Int64.rem (intify a) y in
347 if is_real a || is_real b then Float (Int64.to_float r) else Int r
348 | Bit_and -> Int (Int64.logand (intify a) (intify b))
349 | Bit_or -> Int (Int64.logor (intify a) (intify b))
350 | Shl -> Int (shift `Left (intify a) (intify b))
351 | Shr -> Int (shift `Right (intify a) (intify b))
352 | _ -> (
353 (* Apply numeric affinity to text operands first, so '5'+2 is integer
354 arithmetic (7) while '5.5'+2 is real (7.5), matching sqlite3. *)
355 match (numeric_affinity a, numeric_affinity b) with
356 | Int x, Int y -> arith_int op x y
357 | a, b -> arith_float op a b)
358
359(* ── Environments and lookup ─────────────────────────────────── *)
360
361(* A [binding] is one named row fragment: an (alias, [(column, value)]) pair --
362 the public form used for an outer [scope] (a correlated subquery's enclosing
363 row, or a trigger's OLD/NEW rows). *)
364type binding = string * (string * value) list
365
366(* Internally a row is a list of [frame]s -- one per table joined in, plus the
367 scope at the tail so inner tables shadow it for unqualified names. A table row
368 is a [Pos] frame: the alias, the shared column-name list (one allocation,
369 reused across every row of that table), and the row's values -- so building a
370 row's environment costs a 3-word record, not an n-pair association list. A
371 scope binding becomes an [Assoc] frame. *)
372(* A [Pos] frame carries the optional rowid of a real-table row (for the
373 implicit [rowid]/[oid]/[_rowid_] column); [None] for an index-narrowed scan,
374 a derived table, or a scope binding, where rowid is not resolvable. *)
375type frame =
376 | Pos of string * string list * value list * int64 option
377 | Assoc of binding
378
379type env = frame list
380
381(* The [rowid] pseudo-column and its two aliases, matched case-insensitively. A
382 real column of the same name shadows the implicit one, so this is consulted
383 only after the declared columns. *)
384let is_rowid_name n =
385 match String.lowercase_ascii n with
386 | "rowid" | "_rowid_" | "oid" -> true
387 | _ -> false
388
389(* Parallel-list lookup: the value paired with [name] in [cols]/[vals] (short
390 [vals] reads as trailing NULLs), or [None]. Column names match exactly, as
391 the association-list lookup it replaces did. *)
392let rec assoc2 name cols vals =
393 match (cols, vals) with
394 | c :: cs, v :: vs -> if c = name then Some v else assoc2 name cs vs
395 | c :: cs, [] -> if c = name then Some Null else assoc2 name cs []
396 | [], _ -> None
397
398let frame_alias = function Pos (a, _, _, _) | Assoc (a, _) -> a
399
400let frame_lookup name = function
401 | Pos (_, cols, vals, rid) -> (
402 match assoc2 name cols vals with
403 | Some _ as r -> r
404 | None -> (
405 match rid with
406 | Some r when is_rowid_name name -> Some (Int r)
407 | _ -> None))
408 | Assoc (_, row) -> List.assoc_opt name row
409
410(* The frame's values in column order -- the expansion of [alias.*]. The rowid
411 is a hidden column and never part of [*]. *)
412let frame_values = function
413 | Pos (_, _, vals, _) -> vals
414 | Assoc (_, row) -> List.map snd row
415
416(* The same frame with every value NULL -- the inner side of an unmatched outer
417 join row. The synthetic row has no rowid. *)
418let null_pad_frame = function
419 | Pos (a, cols, vals, _) -> Pos (a, cols, List.map (fun _ -> Null) vals, None)
420 | Assoc (a, row) -> Assoc (a, List.map (fun (c, _) -> (c, Null)) row)
421
422(* Drop the [drop] columns from a frame -- the NATURAL/USING common columns,
423 which survive on the left side and so are listed once. *)
424let trim_frame drop = function
425 | Pos (a, cols, vals, rid) ->
426 let keep =
427 List.filter
428 (fun (c, _) -> not (List.mem c drop))
429 (List.combine cols vals)
430 in
431 Pos (a, List.map fst keep, List.map snd keep, rid)
432 | Assoc (a, row) ->
433 Assoc (a, List.filter (fun (c, _) -> not (List.mem c drop)) row)
434
435let frames_of_scope (scope : binding list) : env =
436 List.map (fun b -> Assoc b) scope
437
438(* Materialise an environment as public [binding]s -- used only to hand the
439 current row to a correlated subquery as its outer scope. Re-pairs a [Pos]
440 frame's columns with its values (short values read as trailing NULLs); this
441 is the one place a row's association list is rebuilt, and only per outer row,
442 not per scanned row. *)
443let bindings_of_frames (env : env) : binding list =
444 let rec pairs cols vals =
445 match (cols, vals) with
446 | c :: cs, v :: vs -> (c, v) :: pairs cs vs
447 | c :: cs, [] -> (c, Null) :: pairs cs []
448 | [], _ -> []
449 in
450 List.map
451 (function Pos (a, cols, vals, _) -> (a, pairs cols vals) | Assoc b -> b)
452 env
453
454(* These walkers are top-level (capturing nothing) so a column lookup -- run
455 once per [Col] per row -- allocates neither a closure nor a [lazy] cell. *)
456let rec aliased q = function
457 | [] -> None
458 | f :: rest -> if frame_alias f = q then Some f else aliased q rest
459
460let rec aliased_ci qu = function
461 | [] -> None
462 | f :: rest ->
463 if String.uppercase_ascii (frame_alias f) = qu then Some f
464 else aliased_ci qu rest
465
466let rec lookup_unqual name = function
467 | [] -> Fmt.failwith "unknown column %S" name
468 | f :: rest -> (
469 match frame_lookup name f with
470 | Some v -> v
471 | None -> lookup_unqual name rest)
472
473let lookup env qual name =
474 match qual with
475 | Some q -> (
476 (* Exact alias first; then a case-insensitive match (the uppercase form is
477 built only if the exact match fails), since SQL identifiers (and the
478 OLD/NEW pseudo-tables, written in any case) are case-insensitive. *)
479 let frame =
480 match aliased q env with
481 | Some _ as r -> r
482 | None -> aliased_ci (String.uppercase_ascii q) env
483 in
484 match frame with
485 | None -> Fmt.failwith "unknown table %S in %s.%s" q q name
486 | Some f -> (
487 match frame_lookup name f with
488 | Some v -> v
489 | None -> Fmt.failwith "unknown column %s.%s" q name))
490 | None -> lookup_unqual name env
491
492(* ── Evaluation ──────────────────────────────────────────────── *)
493
494let frag cat (tr : table_ref) =
495 let alias = Option.value tr.alias ~default:tr.name in
496 let cols = cat.columns tr.name in
497 (alias, cols)
498
499(* An all-NULL environment carrying the FROM tables' column names. It resolves a
500 bare column over an EMPTY aggregate group (no rows): the aggregate is still
501 folded over zero rows, but a bare column reads as NULL -- as sqlite3 does for
502 an aggregate select list (or a HAVING) that names a column on an empty
503 table. *)
504let schema_env cat (s : select) : env =
505 (* Best-effort: a derived/subquery operand whose columns are not in the base
506 catalog is skipped (its bare columns simply stay unresolved, as before). *)
507 let frame tr =
508 match frag cat tr with
509 | alias, cols ->
510 Some (Pos (alias, cols, List.map (fun _ -> Null) cols, None))
511 | exception Failure _ -> None
512 in
513 let from_frames =
514 match s.from with Table tr -> Option.to_list (frame tr) | _ -> []
515 in
516 from_frames @ List.filter_map (fun (j : join) -> frame j.table) s.joins
517
518(* [max]/[min] are aggregates only in their one-argument form; [max(a,b,...)]
519 and [min(a,b,...)] are scalar functions over their arguments. *)
520let is_agg name args =
521 match name with
522 | "count" | "sum" | "avg" | "total" | "group_concat" | "string_agg" -> true
523 | "min" | "max" -> List.length args <= 1
524 | _ -> false
525
526(* Is [e] an aggregate call, possibly wrapped in FILTER/ORDER BY decorations? *)
527let rec is_agg_expr = function
528 | Func (n, a) -> is_agg n a
529 | Distinct_agg _ -> true
530 | Filter (e, _) | Ordered_agg (e, _) -> is_agg_expr e
531 | _ -> false
532
533(* Does [e] contain an aggregate of {e this} query anywhere? Unlike
534 {!is_agg_expr} this looks inside ordinary sub-expressions ([f(a, max(b))], [a
535 + count(c)]) but NOT into a subquery -- an aggregate there is the inner
536 query's, so it does not make the enclosing query an aggregate query. *)
537let rec contains_agg = function
538 | Func (n, args) -> is_agg n args || List.exists contains_agg args
539 | Distinct_agg _ | Filter _ | Ordered_agg _ -> true
540 | Binary (_, a, b) | Is (a, b) -> contains_agg a || contains_agg b
541 | Unop_not a | Is_null a | Is_not_null a | Cast (a, _) | Collate (a, _) ->
542 contains_agg a
543 | In_list (a, l) -> contains_agg a || List.exists contains_agg l
544 | In_select (a, _) -> contains_agg a
545 | Case (base, brs, els) ->
546 Option.fold ~none:false ~some:contains_agg base
547 || List.exists (fun (c, r) -> contains_agg c || contains_agg r) brs
548 || Option.fold ~none:false ~some:contains_agg els
549 | Window _ | Scalar_select _ | Exists _ | Lit _ | Col _ | Param _ | Star
550 | Qualified_star _ ->
551 false
552
553let is_aggregate (rc : Ast.result_col) = contains_agg rc.expr
554
555(* Does [s] aggregate at all -- it groups, has HAVING, or a select column folds
556 an aggregate? A LIMIT/OFFSET cannot be pushed into the scan of such a query
557 (the aggregate folds every row first), so a fast path must recognise and skip
558 it. *)
559let is_aggregate_query (s : select) =
560 s.group_by <> [] || s.having <> None || List.exists is_aggregate s.cols
561
562let dedup rows =
563 let seen = Hashtbl.create 64 in
564 List.filter
565 (fun r ->
566 if Hashtbl.mem seen r then false
567 else (
568 Hashtbl.add seen r ();
569 true))
570 rows
571
572let take n rows =
573 let rec go n = function
574 | _ when n <= 0 -> []
575 | [] -> []
576 | x :: rest -> x :: go (n - 1) rest
577 in
578 go n rows
579
580let rec drop n = function
581 | rows when n <= 0 -> rows
582 | [] -> []
583 | _ :: rest -> drop (n - 1) rest
584
585(* ── Index access ────────────────────────────────────────────── *)
586
587(* Top-level ANDed equalities [col = const] on table alias [alias], with the
588 right-hand side resolved to a constant (a literal or a bound parameter).
589 These are the predicates an index can drive; anything else is left to the row
590 filter. *)
591let collect_eqs params alias where =
592 let const = function
593 | Lit v -> Some v
594 | Param i -> if i < Array.length params then Some params.(i) else None
595 | _ -> None
596 in
597 let here = function None -> true | Some q -> q = alias in
598 let rec go acc = function
599 | Binary (And, a, b) -> go (go acc a) b
600 | Binary (Eq, Col (q, c), rhs) when here q -> (
601 match const rhs with Some v -> (c, v) :: acc | None -> acc)
602 | Binary (Eq, lhs, Col (q, c)) when here q -> (
603 match const lhs with Some v -> (c, v) :: acc | None -> acc)
604 | _ -> acc
605 in
606 match where with None -> [] | Some w -> go [] w
607
608(* The columns of [alias] equated to a constant (literal or parameter) at top
609 level -- the structural view of {!collect_eqs}, independent of any parameter
610 values, used to explain the plan. *)
611let eq_columns alias where =
612 let is_const = function Lit _ | Param _ -> true | _ -> false in
613 let here = function None -> true | Some q -> q = alias in
614 let rec go acc = function
615 | Binary (And, a, b) -> go (go acc a) b
616 | Binary (Eq, Col (q, c), e) when here q && is_const e -> c :: acc
617 | Binary (Eq, e, Col (q, c)) when here q && is_const e -> c :: acc
618 | _ -> acc
619 in
620 match where with None -> [] | Some w -> go [] w
621
622(* Does [e] reference table alias [a]? A join's inner table can be looked up by
623 index only when the other side of the equality does not. *)
624let rec mentions a = function
625 | Col (Some q, _) | Qualified_star q -> q = a
626 | Col (None, _) | Lit _ | Param _ | Star -> false
627 | Unop_not e | Is_null e | Is_not_null e -> mentions a e
628 | Binary (_, x, y) | Is (x, y) -> mentions a x || mentions a y
629 | In_list (e, l) -> mentions a e || List.exists (mentions a) l
630 | In_select (e, _) -> mentions a e
631 | Scalar_select _ | Exists _ -> false
632 | Collate (e, _) -> mentions a e
633 | Func (_, args) -> List.exists (mentions a) args
634 | Distinct_agg (_, e) -> mentions a e
635 | Filter (x, p) -> mentions a x || mentions a p
636 | Ordered_agg (x, ob) ->
637 mentions a x || List.exists (fun (e, _) -> mentions a e) ob
638 | Window (x, w) ->
639 mentions a x
640 || List.exists (mentions a) w.partition
641 || List.exists (fun (e, _) -> mentions a e) w.order
642 | Cast (e, _) -> mentions a e
643 | Case (base, branches, els) ->
644 Option.fold ~none:false ~some:(mentions a) base
645 || List.exists (fun (c, r) -> mentions a c || mentions a r) branches
646 || Option.fold ~none:false ~some:(mentions a) els
647
648(* Columns of the join's inner table [ialias] equated, in [on], to something
649 that does not reference the inner table -- the structural view used to
650 explain an index-driven join. *)
651let join_eq_columns ialias on =
652 let rec go acc = function
653 | Binary (And, a, b) -> go (go acc a) b
654 | Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
655 ->
656 c :: acc
657 | Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
658 ->
659 c :: acc
660 | _ -> acc
661 in
662 go [] on
663
664(* The inner column -> outer expression map of a join's ON equalities: like
665 {!join_eq_columns} but keeping the other side of each equality, so a hash
666 probe key can be precomputed once and only evaluated per outer row. *)
667let join_probe_map ialias on =
668 let rec go acc = function
669 | Binary (And, a, b) -> go (go acc a) b
670 | Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
671 ->
672 (c, e) :: acc
673 | Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
674 ->
675 (c, e) :: acc
676 | _ -> acc
677 in
678 go [] on
679
680(* Every table alias a join's ON clause references. A join can only run once the
681 relations it mentions are already in scope, so this bounds reordering. *)
682let rec on_aliases = function
683 | Col (Some q, _) | Qualified_star q -> [ q ]
684 | Col (None, _) | Lit _ | Param _ | Star -> []
685 | Unop_not e | Is_null e | Is_not_null e | Cast (e, _) -> on_aliases e
686 | Binary (_, a, b) | Is (a, b) -> on_aliases a @ on_aliases b
687 | In_list (e, l) -> on_aliases e @ List.concat_map on_aliases l
688 | In_select (e, _) -> on_aliases e
689 | Scalar_select _ | Exists _ -> []
690 | Collate (e, _) -> on_aliases e
691 | Func (_, args) -> List.concat_map on_aliases args
692 | Distinct_agg (_, e) -> on_aliases e
693 | Filter (x, p) -> on_aliases x @ on_aliases p
694 | Ordered_agg (x, ob) ->
695 on_aliases x @ List.concat_map (fun (e, _) -> on_aliases e) ob
696 | Window (x, w) ->
697 on_aliases x
698 @ List.concat_map on_aliases w.partition
699 @ List.concat_map (fun (e, _) -> on_aliases e) w.order
700 | Case (b, brs, el) ->
701 Option.fold ~none:[] ~some:on_aliases b
702 @ List.concat_map (fun (c, r) -> on_aliases c @ on_aliases r) brs
703 @ Option.fold ~none:[] ~some:on_aliases el
704
705let join_alias (j : join) = Option.value j.table.alias ~default:j.table.name
706
707(* sqlite3 lets a [WHERE] or [ORDER BY] reference a select-list alias ([SELECT a
708 AS x ... WHERE x>1 ORDER BY x] resolves x to a). Substitute each such alias
709 with the expression it names, unless a real column of a scanned table shadows
710 it (a real column wins). Subqueries are not descended into -- they have their
711 own scope. An aggregate alias substituted into WHERE then raises, as sqlite3
712 does (an aggregate is not allowed in WHERE). *)
713let resolve_where_aliases cat (s : select) =
714 match (s.where, s.order_by) with
715 | None, [] -> s
716 | _ ->
717 let table_cols (tr : table_ref) =
718 match tr.subquery with None -> cat.columns tr.name | Some _ -> []
719 in
720 let real_cols =
721 (match s.from with Table tr -> table_cols tr | _ -> [])
722 @ List.concat_map (fun (j : join) -> table_cols j.table) s.joins
723 in
724 let aliases =
725 List.filter_map
726 (fun (rc : result_col) ->
727 match rc.alias with
728 | Some a when not (List.mem a real_cols) -> Some (a, rc.expr)
729 | _ -> None)
730 s.cols
731 in
732 if aliases = [] then s
733 else
734 let rec sub e =
735 match e with
736 | Col (None, name) -> (
737 match List.assoc_opt name aliases with Some e' -> e' | None -> e)
738 | Binary (op, a, b) -> Binary (op, sub a, sub b)
739 | Unop_not a -> Unop_not (sub a)
740 | Is_null a -> Is_null (sub a)
741 | Is_not_null a -> Is_not_null (sub a)
742 | Is (a, b) -> Is (sub a, sub b)
743 | In_list (a, l) -> In_list (sub a, List.map sub l)
744 | Cast (a, t) -> Cast (sub a, t)
745 | Collate (a, c) -> Collate (sub a, c)
746 | Func (n, args) -> Func (n, List.map sub args)
747 | Case (b, brs, el) ->
748 Case
749 ( Option.map sub b,
750 List.map (fun (c, r) -> (sub c, sub r)) brs,
751 Option.map sub el )
752 | Distinct_agg (n, a) -> Distinct_agg (n, sub a)
753 | Filter (a, b) -> Filter (sub a, sub b)
754 | Ordered_agg (a, ob) ->
755 Ordered_agg (sub a, List.map (fun (e, d) -> (sub e, d)) ob)
756 | Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _
757 | Scalar_select _ | Exists _ | Window _ ->
758 e
759 in
760 {
761 s with
762 where = Option.map sub s.where;
763 order_by = List.map (fun (e, d) -> (sub e, d)) s.order_by;
764 }
765
766(* Cost-based join ordering (Leis et al., VLDB 2015: join ordering dominates).
767 Inner joins commute, so reorder them cheapest-first by an exact-cardinality
768 cost model -- an index-covered ON is a lookup (cost 0), otherwise the inner
769 table's row count -- subject to each join's ON dependencies being in scope.
770 Outer joins are not reorderable, so a query containing one keeps FROM
771 order. *)
772let plan_joins cat from_alias joins =
773 if joins = [] || List.exists (fun j -> j.type_ <> Inner || j.natural) joins
774 then joins
775 else
776 let cost j =
777 let eq = join_eq_columns (join_alias j) j.on in
778 if eq <> [] && cat.index_for j.table.name eq <> None then 0
779 else List.length (cat.rows j.table.name)
780 in
781 let ready avail j =
782 List.for_all
783 (fun q -> q = join_alias j || List.mem q avail)
784 (on_aliases j.on)
785 in
786 let rec go avail remaining acc =
787 match remaining with
788 | [] -> List.rev acc
789 | _ ->
790 let candidates =
791 match List.filter (ready avail) remaining with
792 | [] -> remaining (* a cross/unsatisfiable join: do not stall *)
793 | r -> r
794 in
795 let best =
796 List.fold_left
797 (fun b j -> if cost j < cost b then j else b)
798 (List.hd candidates) (List.tl candidates)
799 in
800 go (join_alias best :: avail)
801 (List.filter (fun j -> j != best) remaining)
802 (best :: acc)
803 in
804 go [ from_alias ] joins []
805
806(* The chosen access path for the [from] table: an index narrowing when one
807 covers the equalities, else a full scan. The narrowed rows are still passed
808 through the row filter, so the choice is a pure optimisation. *)
809let from_access cat params (tr : table_ref) where =
810 let alias = Option.value tr.alias ~default:tr.name in
811 match collect_eqs params alias where with
812 | [] -> None
813 | eqs -> cat.index_scan tr.name eqs
814
815(* The output column names of a select, for use as a derived table's columns:
816 the explicit alias, else the bare column name, else a positional name. A
817 [SELECT *] expands to every column in scope -- the FROM table plus each
818 joined table, recursing into a derived (subquery) operand. *)
819let rec select_columns cat s =
820 let table_cols (tr : table_ref) =
821 match tr.subquery with
822 | Some q -> select_columns cat q
823 | None -> cat.columns tr.name
824 in
825 let star_cols () =
826 let from_cols =
827 match s.from with
828 | Unit -> []
829 | Table tr -> table_cols tr
830 | Select { fs_select; _ } -> select_columns cat fs_select
831 | Values (r :: _) -> List.mapi (fun j _ -> Fmt.str "column%d" (j + 1)) r
832 | Values [] -> []
833 | Table_function { tf_name; _ } -> table_function_columns tf_name
834 in
835 from_cols @ List.concat_map (fun (j : join) -> table_cols j.table) s.joins
836 in
837 List.concat
838 (List.mapi
839 (fun i (rc : result_col) ->
840 match rc.expr with
841 | Star -> star_cols ()
842 | Qualified_star q -> cat.columns q
843 | _ -> (
844 match rc.alias with
845 | Some a -> [ a ]
846 | None -> (
847 match rc.expr with
848 | Col (_, c) -> [ c ]
849 | _ -> [ Fmt.str "column%d" (i + 1) ])))
850 s.cols)
851
852(* The output expressions of [s] in order, expanding [*]/[t.*] to a column
853 reference per underlying column. Used to resolve an ORDER BY ordinal to the
854 expression of that output column. *)
855let output_exprs cat (s : select) =
856 let star () =
857 select_columns cat { s with cols = [ { expr = Star; alias = None } ] }
858 in
859 List.concat_map
860 (fun (rc : result_col) ->
861 match rc.expr with
862 | Star -> List.map (fun c -> Col (None, c)) (star ())
863 | Qualified_star q -> List.map (fun c -> Col (Some q, c)) (cat.columns q)
864 | e -> [ e ])
865 s.cols
866
867(* sqlite3 lets ORDER BY and GROUP BY use a 1-based output-column ordinal
868 ([ORDER BY 2] / [GROUP BY 2] use the second result column). Replace each
869 integer-literal key with the expression of that output column, so the normal
870 machinery uses it; an out-of-range or non-integer key is left as is. *)
871let resolve_ordinals cat (s : select) =
872 if s.order_by = [] && s.group_by = [] then s
873 else
874 let outs = Array.of_list (output_exprs cat s) in
875 let n = Array.length outs in
876 (* A 1-based ordinal becomes its output expression; [ORDER BY k COLLATE c]
877 parses as a [Collate] around the ordinal, so look through it (the
878 collation stays, wrapping the resolved column). *)
879 let rec nth = function
880 | Lit (Int i) when i >= 1L && Int64.to_int i <= n ->
881 outs.(Int64.to_int i - 1)
882 | Collate (e, c) -> Collate (nth e, c)
883 | e -> e
884 in
885 (* An ORDER BY key may name an explicit output-column alias; the alias takes
886 precedence over an input column (sqlite3), so resolve it to that output
887 expression -- this is how [ORDER BY n] reaches an aggregate aliased
888 [n]. *)
889 let alias_expr name =
890 List.find_map
891 (fun (rc : result_col) ->
892 match rc.alias with Some a when a = name -> Some rc.expr | _ -> None)
893 s.cols
894 in
895 let rec order_key = function
896 | Collate (e, c) -> Collate (order_key e, c)
897 | Col (None, name) as e -> (
898 match alias_expr name with Some x -> x | None -> nth e)
899 | e -> nth e
900 in
901 {
902 s with
903 order_by = List.map (fun (e, d) -> (order_key e, d)) s.order_by;
904 group_by = List.map nth s.group_by;
905 }
906
907let collation_bases (s : select) =
908 let of_ref (tr : table_ref) =
909 match tr.subquery with
910 | None -> [ (Option.value tr.alias ~default:tr.name, tr.name) ]
911 | Some _ -> []
912 in
913 (match s.from with Table tr -> of_ref tr | _ -> [])
914 @ List.concat_map (fun (j : join) -> of_ref j.table) s.joins
915
916let collation_for cat bases = function
917 | Col (Some q, name) -> (
918 match List.assoc_opt q bases with
919 | Some tbl -> cat.collation tbl name
920 | None -> None)
921 | Col (None, name) -> (
922 let cols_of tbl = try cat.columns tbl with Failure _ -> [] in
923 match
924 List.find_opt (fun (_, tbl) -> List.mem name (cols_of tbl)) bases
925 with
926 | Some (_, tbl) -> cat.collation tbl name
927 | None -> None)
928 | _ -> None
929
930let has_explicit_collation = function Collate _ -> true | _ -> false
931let is_col_expr = function Col _ -> true | _ -> false
932
933let collation_cmp_operands col_coll a b =
934 if has_explicit_collation a || has_explicit_collation b then (a, b)
935 else if is_col_expr a then
936 match col_coll a with Some c -> (Collate (a, c), b) | None -> (a, b)
937 else if is_col_expr b then
938 match col_coll b with Some c -> (a, Collate (b, c)) | None -> (a, b)
939 else (a, b)
940
941let collation_lhs col_coll e =
942 if has_explicit_collation e then e
943 else match col_coll e with Some c -> Collate (e, c) | None -> e
944
945let rec resolve_collation_expr col_coll = function
946 | Binary (((And | Or) as op), a, b) ->
947 Binary
948 ( op,
949 resolve_collation_expr col_coll a,
950 resolve_collation_expr col_coll b )
951 | Unop_not a -> Unop_not (resolve_collation_expr col_coll a)
952 | Binary (((Eq | Neq | Lt | Le | Gt | Ge) as op), a, b) ->
953 let a, b = collation_cmp_operands col_coll a b in
954 Binary (op, a, b)
955 (* [x IN ..] uses the left operand's collation, like [x = ..]. *)
956 | In_list (e, l) -> In_list (collation_lhs col_coll e, l)
957 | In_select (e, sub) -> In_select (collation_lhs col_coll e, sub)
958 | e -> e
959
960(* Apply each base-table column's declared COLLATE sequence to the comparisons
961 of [s]'s WHERE/ON/HAVING and to its ORDER BY keys, by wrapping the column in
962 an explicit [Collate] node -- which the existing collation machinery then
963 honours. sqlite3's rule: an explicit COLLATE on either operand wins;
964 otherwise the left operand's column collation, else the right's. Only bare
965 columns of a scanned base table carry a declared collation (a
966 subquery/derived source has none). *)
967let resolve_collations cat (s : select) =
968 let bases = collation_bases s in
969 if bases = [] then s
970 else
971 let col_coll = collation_for cat bases in
972 let rw = resolve_collation_expr col_coll in
973 let lhs_coll = collation_lhs col_coll in
974 let order_key (e, dir) = (lhs_coll e, dir) in
975 {
976 s with
977 where = Option.map rw s.where;
978 having = Option.map rw s.having;
979 group_by = List.map lhs_coll s.group_by;
980 order_by = List.map order_key s.order_by;
981 joins = List.map (fun (j : join) -> { j with on = rw j.on }) s.joins;
982 }
983
984(* Does select [s] read from a table named [name] (directly, via a join, a
985 FROM-subquery, or a compound arm)? Used to spot a self-referential CTE. *)
986let rec references_table name (s : select) =
987 (match s.from with
988 | Unit -> false
989 | Table tr -> tr.name = name
990 | Select { fs_select; _ } -> references_table name fs_select
991 | Values _ | Table_function _ -> false)
992 || List.exists
993 (fun (j : join) ->
994 j.table.name = name
995 ||
996 match j.table.subquery with
997 | Some q -> references_table name q
998 | None -> false)
999 s.joins
1000 || List.exists (fun (_, arm) -> references_table name arm) s.compound
1001
1002(* Combine compound arms by their set operator. UNION/EXCEPT/INTERSECT yield
1003 distinct rows; UNION ALL keeps duplicates. *)
1004let set_op op left right =
1005 match op with
1006 | Union_all -> left @ right
1007 | Union -> dedup (left @ right)
1008 | Except -> dedup (List.filter (fun r -> not (List.mem r right)) left)
1009 | Intersect -> dedup (List.filter (fun r -> List.mem r right) left)
1010
1011(* ── Evaluation and SELECT execution ─────────────────────────── *)
1012
1013(* Pick how to find the inner rows for a join: a full scan, an index lookup, or
1014 a hash table keyed on the equijoin columns. *)
1015let join_strategy cat ialias env_of eq_cols (j : Ast.join) =
1016 if eq_cols = [] then `Scan
1017 else
1018 match cat.index_for (j.table : table_ref).name eq_cols with
1019 | Some _ -> `Index
1020 | None ->
1021 let tbl : (value list, value list) Hashtbl.t = Hashtbl.create 256 in
1022 List.iter
1023 (fun vals ->
1024 let row = [ env_of vals ] in
1025 let key = List.map (fun c -> lookup row (Some ialias) c) eq_cols in
1026 Hashtbl.add tbl key vals)
1027 (cat.rows j.table.name);
1028 `Hash tbl
1029
1030(* Resolve each NATURAL join's implicit ON -- equality on the columns common to
1031 the declared-order left and the joined table -- and return, per join in
1032 declared order, a triple of: the resolved join, the common columns to drop
1033 from its frame (so [SELECT *] lists each common column once), and the left
1034 frame template (alias, columns) accumulated before it (used to NULL-pad the
1035 left of an unmatched right row in a RIGHT/FULL join). *)
1036let resolve_natural cat base_frame joins =
1037 let _, acc =
1038 List.fold_left
1039 (fun (lframes, acc) (j : Ast.join) ->
1040 let ialias, icols = frag cat j.table in
1041 let entry =
1042 if (not j.natural) && j.using = [] then (j, [], lframes)
1043 else
1044 let owner c =
1045 List.find_map
1046 (fun (a, cs) -> if List.mem c cs then Some a else None)
1047 lframes
1048 in
1049 let common =
1050 if j.natural then List.filter (fun c -> owner c <> None) icols
1051 else j.using
1052 in
1053 let eqs =
1054 List.filter_map
1055 (fun c ->
1056 Option.map
1057 (fun a ->
1058 Binary (Eq, Col (Some a, c), Col (Some ialias, c)))
1059 (owner c))
1060 common
1061 in
1062 let on =
1063 match eqs with
1064 | [] -> Lit (Int 1L)
1065 | e :: r -> List.fold_left (fun acc x -> Binary (And, acc, x)) e r
1066 in
1067 ({ j with on }, common, lframes)
1068 in
1069 (lframes @ [ (ialias, icols) ], acc @ [ entry ]))
1070 ([ base_frame ], []) joins
1071 in
1072 acc
1073
1074(* The distinct [Window] nodes appearing anywhere in [cols] (window functions do
1075 not nest, so a Window is not descended into). Pure syntax -- no executor
1076 dependencies, so it sits outside the evaluation rec group. *)
1077let window_exprs cols =
1078 let acc = ref [] in
1079 let rec go e =
1080 match e with
1081 | Window _ -> if not (List.mem e !acc) then acc := !acc @ [ e ]
1082 | Binary (_, a, b) | Filter (a, b) | Is (a, b) ->
1083 go a;
1084 go b
1085 | Unop_not a
1086 | Is_null a
1087 | Is_not_null a
1088 | Cast (a, _)
1089 | Distinct_agg (_, a)
1090 | Collate (a, _) ->
1091 go a
1092 | In_list (a, l) ->
1093 go a;
1094 List.iter go l
1095 | Func (_, args) -> List.iter go args
1096 | Ordered_agg (a, ob) ->
1097 go a;
1098 List.iter (fun (e, _) -> go e) ob
1099 | Case (b, brs, el) ->
1100 Option.iter go b;
1101 List.iter
1102 (fun (c, r) ->
1103 go c;
1104 go r)
1105 brs;
1106 Option.iter go el
1107 | In_select _ | Scalar_select _ | Exists _ | Lit _ | Col _ | Param _ | Star
1108 | Qualified_star _ ->
1109 ()
1110 in
1111 List.iter (fun (rc : Ast.result_col) -> go rc.expr) cols;
1112 !acc
1113
1114(* Replace every [Window] node in [e] with the literal [lookup] gives for it. *)
1115let rec subst_windows lookup e =
1116 let r = subst_windows lookup in
1117 match e with
1118 | Window _ -> Lit (lookup e)
1119 | Binary (op, a, b) -> Binary (op, r a, r b)
1120 | Is (a, b) -> Is (r a, r b)
1121 | Unop_not a -> Unop_not (r a)
1122 | Is_null a -> Is_null (r a)
1123 | Is_not_null a -> Is_not_null (r a)
1124 | In_list (a, l) -> In_list (r a, List.map r l)
1125 | Cast (a, t) -> Cast (r a, t)
1126 | Collate (a, c) -> Collate (r a, c)
1127 | Func (n, args) -> Func (n, List.map r args)
1128 | Case (b, brs, el) ->
1129 Case
1130 ( Option.map r b,
1131 List.map (fun (c, x) -> (r c, r x)) brs,
1132 Option.map r el )
1133 | ( Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _
1134 | Scalar_select _ | Exists _ | Distinct_agg _ | Filter _ | Ordered_agg _ )
1135 as e ->
1136 e
1137
1138(* The frame [lo, hi] (ordered positions, clamped to the partition) for the row
1139 at [pos]: from the explicit ROWS/RANGE clause, else the default frame (whole
1140 partition with no ORDER BY, else UNBOUNDED PRECEDING to the current peer
1141 group). RANGE offsets are not value-based here; they fall back to the peer
1142 group, which agrees with RANGE for distinct order keys. [evcur] evaluates a
1143 bound offset against the current row. *)
1144let window_frame ~pos ~k ~peer_start ~peer_end ~evcur w =
1145 let off e = Int64.to_int (intify (evcur e)) in
1146 let lo, hi =
1147 match w.frame with
1148 | None -> (0, if w.order = [] then k - 1 else peer_end.(pos))
1149 | Some f ->
1150 let rows = f.rows in
1151 let resolve at_start = function
1152 | Unbounded_preceding -> 0
1153 | Unbounded_following -> k - 1
1154 | Current_row ->
1155 if rows then pos
1156 else if at_start then peer_start.(pos)
1157 else peer_end.(pos)
1158 | Preceding e -> if rows then pos - off e else peer_start.(pos)
1159 | Following e -> if rows then pos + off e else peer_end.(pos)
1160 in
1161 (resolve true f.start, resolve false f.end_)
1162 in
1163 (max 0 lo, min (k - 1) hi)
1164
1165(* Wrap [cat] so [name] resolves to the given materialised [cols]/[rows] (no
1166 index), shadowing any real table -- the mechanism behind CTEs and derived
1167 tables in JOIN position. *)
1168let bind_relation cat name cols rows =
1169 {
1170 columns = (fun n -> if n = name then cols else cat.columns n);
1171 rows = (fun n -> if n = name then rows else cat.rows n);
1172 rows_rowid =
1173 (fun n ->
1174 if n = name then List.map (fun r -> (None, r)) rows
1175 else cat.rows_rowid n);
1176 index_scan = (fun n eqs -> if n = name then None else cat.index_scan n eqs);
1177 index_for = (fun n cs -> if n = name then None else cat.index_for n cs);
1178 collation = (fun n c -> if n = name then None else cat.collation n c);
1179 }
1180
1181let is_col_node = function Col _ -> true | _ -> false
1182
1183let subquery_column ?(scope = []) cat params s =
1184 !cat_subquery_runner cat scope s params
1185 |> List.map (function v :: _ -> v | [] -> Null)
1186
1187let eval_scalar_select cat params env s =
1188 (* A scalar subquery yields the first column of its first row (NULL if it
1189 returns none). Correlated via the same outer [env] scope. *)
1190 match !cat_subquery_runner cat (bindings_of_frames env) s params with
1191 | (v :: _) :: _ -> v
1192 | [] :: _ | [] -> Null
1193
1194let eval_exists cat params env s =
1195 bool
1196 (match !cat_subquery_runner cat (bindings_of_frames env) s params with
1197 | _ :: _ -> true
1198 | [] -> false)
1199
1200let rec eval cat params env = function
1201 | Lit v -> v
1202 | Param i -> if i < Array.length params then params.(i) else Null
1203 | Col (q, n) -> lookup env q n
1204 | Star | Qualified_star _ -> failwith "'*' is only valid as a select item"
1205 | Unop_not e -> not_value (eval cat params env e)
1206 | Binary (op, a, b) -> eval_binary cat params env op a b
1207 | Collate (e, _) -> eval cat params env e
1208 | Is_null e -> bool (eval cat params env e = Null)
1209 | Is_not_null e -> bool (eval cat params env e <> Null)
1210 | Is (a, b) -> is_value (eval cat params env a) (eval cat params env b)
1211 | In_list (e, l) -> eval_in_list cat params env e l
1212 | In_select (e, s) -> eval_in_select cat params env e s
1213 | Scalar_select s -> eval_scalar_select cat params env s
1214 | Exists s -> eval_exists cat params env s
1215 (* Aggregates are computed by {!aggregate} over the whole group; reaching one
1216 here means it was used as a scalar (in WHERE, ON, or ORDER BY). *)
1217 | Func (name, args) when is_agg name args ->
1218 Fmt.failwith
1219 "%s() is an aggregate function and is only valid as a select item, not \
1220 in WHERE, ON, or ORDER BY"
1221 name
1222 | Distinct_agg (name, _) ->
1223 Fmt.failwith
1224 "%s() is an aggregate function and is only valid as a select item, not \
1225 in WHERE, ON, or ORDER BY"
1226 name
1227 | Filter _ | Ordered_agg _ ->
1228 failwith
1229 "an aggregate FILTER/ORDER BY is only valid as a select item, not in \
1230 WHERE, ON, or ORDER BY"
1231 | Window _ ->
1232 failwith
1233 "a window function is only valid in the select list, not in WHERE, ON, \
1234 or GROUP BY"
1235 (* iif(C, T, F) is sugar for CASE and short-circuits, so it is evaluated
1236 before its branches rather than as an ordinary (eager-argument)
1237 function. *)
1238 | Func ("iif", [ c; t; f ]) ->
1239 if tri_of (eval cat params env c) = T then eval cat params env t
1240 else eval cat params env f
1241 | Func (name, args) -> apply name (List.map (eval cat params env) args)
1242 | Cast (e, ty) -> cast ty (eval cat params env e)
1243 (* CASE: the base (simple form) is evaluated once and matched with [=]
1244 semantics, so a NULL base matches no WHEN -- including WHEN NULL. First
1245 match wins; no match and no ELSE is NULL. *)
1246 | Case (base, branches, els) -> eval_case cat params env base branches els
1247
1248and eval_binary cat params env op a b =
1249 match op with
1250 | And | Or | Like | Glob | Concat | Json_get | Json_get_text ->
1251 binop_value op (eval cat params env a) (eval cat params env b)
1252 | Add | Sub | Mul | Div | Mod | Bit_and | Bit_or | Shl | Shr ->
1253 arith op (eval cat params env a) (eval cat params env b)
1254 | _ ->
1255 let coll =
1256 match explicit_collation a with
1257 | Some _ as c -> c
1258 | None -> explicit_collation b
1259 in
1260 let va = eval cat params env a and vb = eval cat params env b in
1261 compare_with_affinity ?coll ~a_col:(is_col_node a) ~b_col:(is_col_node b)
1262 op va vb
1263
1264and eval_in_list cat params env e l =
1265 let v = eval cat params env e in
1266 let cands = List.map (eval cat params env) l in
1267 (* The membership test uses the left operand's collation (a declared COLLATE
1268 made explicit by [resolve_collations]) and its affinity. *)
1269 let coll = explicit_collation e in
1270 let bare =
1271 match e with Collate (inner, c) when c <> "BINARY" -> inner | _ -> e
1272 in
1273 in_list_value ?coll ~e_col:(is_col_node bare) v cands
1274
1275and eval_in_select cat params env e s =
1276 (* The subquery sees the current row as its outer scope, so a correlated [IN
1277 (SELECT ... WHERE inner.x = outer.y)] resolves [outer.y]. *)
1278 let scope = bindings_of_frames env in
1279 in_eval (eval cat params env e) (subquery_column ~scope cat params s)
1280
1281and eval_case cat params env base branches els =
1282 let bv = Option.map (eval cat params env) base in
1283 let hit cond =
1284 match bv with
1285 | Some b ->
1286 equal_value (compare_op Eq b (eval cat params env cond)) (Int 1L)
1287 | None -> tri_of (eval cat params env cond) = T
1288 in
1289 let rec go = function
1290 | (c, r) :: rest -> if hit c then eval cat params env r else go rest
1291 | [] -> ( match els with Some e -> eval cat params env e | None -> Null)
1292 in
1293 go branches
1294
1295(* Inner-table equalities [col = e] in a join's ON clause where [e], evaluated
1296 against the current outer row, gives a concrete value -- the bindings that
1297 drive an index-nested-loop join. *)
1298let join_eqs cat params env ialias on =
1299 let rec go acc = function
1300 | Binary (And, a, b) -> go (go acc a) b
1301 | Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
1302 ->
1303 (c, eval cat params env e) :: acc
1304 | Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
1305 ->
1306 (c, eval cat params env e) :: acc
1307 | _ -> acc
1308 in
1309 go [] on
1310
1311(* RIGHT/FULL OUTER: the inner table's unmatched rows must also survive, so the
1312 left stream is materialised and every inner row is scanned for any match.
1313 FULL additionally keeps unmatched left rows (NULL inner), like LEFT. The
1314 emission order is not specified by SQL; callers that care add ORDER BY. *)
1315let right_full_join cat params (j : Ast.join) envs ~env_of ~trim ~null_frame
1316 ~left_template =
1317 let lefts = envs in
1318 let inners = Array.of_list (cat.rows j.table.name) in
1319 let hit = Array.make (Array.length inners) false in
1320 let null_left =
1321 match lefts with
1322 | e :: _ -> List.map null_pad_frame e
1323 | [] ->
1324 List.map
1325 (fun (a, cs) -> Pos (a, cs, List.map (fun _ -> Null) cs, None))
1326 left_template
1327 in
1328 let out = ref [] in
1329 List.iter
1330 (fun env ->
1331 let any = ref false in
1332 Array.iteri
1333 (fun k vals ->
1334 match tri_of (eval cat params (env @ [ env_of vals ]) j.on) with
1335 | T ->
1336 any := true;
1337 hit.(k) <- true;
1338 out := (env @ [ trim (env_of vals) ]) :: !out
1339 | F | U -> ())
1340 inners;
1341 if (not !any) && j.type_ = Full then out := (env @ [ null_frame ]) :: !out)
1342 lefts;
1343 Array.iteri
1344 (fun k vals ->
1345 if not hit.(k) then out := (null_left @ [ trim (env_of vals) ]) :: !out)
1346 inners;
1347 List.rev !out
1348
1349(* Add one joined table to the running row stream, picking the access strategy
1350 once for the whole join (not per outer row): - index-nested-loop when a
1351 unique index covers the ON equi-columns; - hash join when the ON has
1352 equi-columns but no index: build a hash table on the inner relation keyed by
1353 those columns once, then probe per outer row (O(inner + outer) instead of the
1354 O(inner x outer) nested-loop); - plain nested-loop scan otherwise (no
1355 equi-column, e.g. a cross join). The full ON predicate is always re-checked,
1356 so the strategy only narrows candidates and NULL keys (which never
1357 equi-match) fall out. *)
1358let join_with ?(drop = []) ?(left_template = []) cat params (j : Ast.join) envs
1359 =
1360 let ialias, icols = frag cat j.table in
1361 let env_of vals = Pos (ialias, icols, vals, None) in
1362 (* A NATURAL join lists each common column once: the ON is evaluated on the
1363 full inner frame, but [drop]ped columns are removed from the frame stored
1364 in the row (they survive on the left and are equal there). With nothing to
1365 drop (the common non-NATURAL case) this is the identity, avoiding a per-row
1366 copy of the frame. *)
1367 let trim = if drop = [] then Fun.id else trim_frame drop in
1368 (* A LEFT JOIN keeps an outer row that matched nothing, with the inner table's
1369 columns all NULL. *)
1370 let null_frame =
1371 trim (Pos (ialias, icols, List.map (fun _ -> Null) icols, None))
1372 in
1373 let eq_cols = join_eq_columns ialias j.on in
1374 let strategy = join_strategy cat ialias env_of eq_cols j in
1375 (* The hash probe key as expressions over the outer row, resolved once (in
1376 [eq_cols] order) so each outer row only evaluates them -- no per-row
1377 [(col,value)] list rebuilt and re-looked-up. *)
1378 let probe_exprs =
1379 match strategy with
1380 | `Hash _ ->
1381 let m = join_probe_map ialias j.on in
1382 List.map (fun c -> List.assoc c m) eq_cols
1383 | _ -> []
1384 in
1385 let candidates env =
1386 match strategy with
1387 | `Scan -> cat.rows j.table.name
1388 | `Index -> (
1389 match
1390 cat.index_scan j.table.name (join_eqs cat params env ialias j.on)
1391 with
1392 | Some (_, rows) -> rows
1393 | None -> cat.rows j.table.name)
1394 | `Hash tbl ->
1395 let key = List.map (eval cat params env) probe_exprs in
1396 Hashtbl.find_all tbl key
1397 in
1398 let matched env =
1399 List.filter_map
1400 (fun vals ->
1401 (* Build the inner frame once and reuse it for both the ON test and the
1402 emitted row. *)
1403 let frame = env_of vals in
1404 match tri_of (eval cat params (env @ [ frame ]) j.on) with
1405 | T -> Some (env @ [ trim frame ])
1406 | F | U -> None)
1407 (candidates env)
1408 in
1409 match j.type_ with
1410 | Inner -> List.concat_map matched envs
1411 | Left ->
1412 List.concat_map
1413 (fun env ->
1414 match matched env with [] -> [ env @ [ null_frame ] ] | rows -> rows)
1415 envs
1416 | Right | Full ->
1417 right_full_join cat params j envs ~env_of ~trim ~null_frame ~left_template
1418
1419let project cat params (s : Ast.select) env =
1420 (* A star-free select list (the common case) maps one value per item -- no
1421 per-item singleton list and no [concat_map] to flatten. Only [*] and [t.*],
1422 which expand to a whole frame, need the general path. *)
1423 let is_star (rc : Ast.result_col) =
1424 match rc.expr with Star | Qualified_star _ -> true | _ -> false
1425 in
1426 if List.exists is_star s.cols then
1427 List.concat_map
1428 (fun (rc : Ast.result_col) ->
1429 match rc.expr with
1430 | Star -> List.concat_map frame_values env
1431 | Qualified_star q -> (
1432 match aliased_ci (String.uppercase_ascii q) env with
1433 | Some f -> frame_values f
1434 | None -> Fmt.failwith "no such table: %s" q)
1435 | e -> [ eval cat params env e ])
1436 s.cols
1437 else
1438 List.map (fun (rc : Ast.result_col) -> eval cat params env rc.expr) s.cols
1439
1440(* Fold one aggregate call over the group [envs]. With [distinct], the non-NULL
1441 argument values are deduplicated (preserving first-seen order) before the
1442 fold -- [count(DISTINCT x)], [sum(DISTINCT x)], etc. *)
1443let agg_call ?(distinct = false) cat params envs name args =
1444 let arg1 = function [ a ] -> a | _ -> Star in
1445 let dedup vs = if distinct then distinct_values vs else vs in
1446 let agg_vals arg =
1447 dedup
1448 (List.filter_map
1449 (fun env ->
1450 match eval cat params env arg with Null -> None | v -> Some v)
1451 envs)
1452 in
1453 match (name, args) with
1454 | "count", args -> (
1455 match arg1 args with
1456 | Star -> Int (Int64.of_int (List.length envs))
1457 | a -> Int (Int64.of_int (List.length (agg_vals a))))
1458 | ("group_concat" | "string_agg"), args -> (
1459 (* group_concat(X [, sep]) / string_agg(X, sep): non-NULL X values joined
1460 by sep (default ","); NULL over an empty group. *)
1461 let arg, sep =
1462 match args with
1463 | [ a ] -> (a, ",")
1464 | a :: s :: _ ->
1465 ( a,
1466 match envs with
1467 | env :: _ -> text_of_value (eval cat params env s)
1468 | [] -> "," )
1469 | [] -> (Star, ",")
1470 in
1471 match agg_vals arg with
1472 | [] -> Null
1473 | vals -> Text (String.concat sep (List.map text_of_value vals)))
1474 | _ -> numeric_agg name (agg_vals (arg1 args))
1475
1476(* Evaluate one expression over a group [envs] with aggregate semantics: every
1477 aggregate call (even nested in a larger expression, e.g. [sum(x) > 5]) is
1478 folded over the group and substituted by its value; the rest is then read
1479 from an arbitrary row of the group. Used for select-list columns and
1480 HAVING. *)
1481let agg_value ?(empty = []) ?rep cat params envs e =
1482 (* FILTER (WHERE p) restricts the group rows; ORDER BY sorts them (only
1483 order-sensitive aggregates like group_concat observe the order). *)
1484 let filtered p envs =
1485 List.filter (fun env -> tri_of (eval cat params env p) = T) envs
1486 in
1487 let sorted ob envs =
1488 let rec cmp a b = function
1489 | [] -> 0
1490 | (e, dir) :: rest ->
1491 let c = compare_values (eval cat params a e) (eval cat params b e) in
1492 let c = match dir with Asc -> c | Desc -> -c in
1493 if c <> 0 then c else cmp a b rest
1494 in
1495 List.stable_sort (fun a b -> cmp a b ob) envs
1496 in
1497 (* Compute an aggregate expression's value over [envs], peeling FILTER/ORDER
1498 BY decorations down to the core Func / Distinct_agg call. *)
1499 let rec agg_core envs = function
1500 | Func (name, args) -> agg_call ~distinct:false cat params envs name args
1501 | Distinct_agg (name, arg) ->
1502 agg_call ~distinct:true cat params envs name [ arg ]
1503 | Filter (inner, p) -> agg_core (filtered p envs) inner
1504 | Ordered_agg (inner, ob) -> agg_core (sorted ob envs) inner
1505 | _ -> Null
1506 in
1507 let rec subst e =
1508 match e with
1509 | e when is_agg_expr e -> Lit (agg_core envs e)
1510 | Unop_not a -> Unop_not (subst a)
1511 | Binary (op, a, b) -> Binary (op, subst a, subst b)
1512 | Is (a, b) -> Is (subst a, subst b)
1513 | Is_null a -> Is_null (subst a)
1514 | Is_not_null a -> Is_not_null (subst a)
1515 | In_list (a, l) -> In_list (subst a, List.map subst l)
1516 | Cast (a, ty) -> Cast (subst a, ty)
1517 | Collate (a, c) -> Collate (subst a, c)
1518 | Case (base, branches, els) ->
1519 Case
1520 ( Option.map subst base,
1521 List.map (fun (c, r) -> (subst c, subst r)) branches,
1522 Option.map subst els )
1523 (* Recurse into a non-aggregate function's args for a nested aggregate. *)
1524 | Func (n, args) -> Func (n, List.map subst args)
1525 | (Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _) as e ->
1526 e
1527 | (Scalar_select _ | Exists _) as e -> e
1528 | (Distinct_agg _ | Filter _ | Ordered_agg _ | Window _) as e -> e
1529 in
1530 let e = subst e in
1531 (* Bare columns: from [rep] (the min/max row), else an arbitrary or empty
1532 row. *)
1533 let row =
1534 match rep with
1535 | Some r -> r
1536 | None -> ( match envs with e :: _ -> e | [] -> empty)
1537 in
1538 eval cat params row e
1539
1540let aggregate ?(empty = []) ?rep cat params (s : Ast.select) envs =
1541 (* [*] in a grouped/aggregated select expands to the columns of the group's
1542 representative row (the min/max row when one is chosen, else an arbitrary
1543 member), just as a bare column does. *)
1544 let rep_row () =
1545 match rep with
1546 | Some r -> r
1547 | None -> ( match envs with e :: _ -> e | [] -> empty)
1548 in
1549 let has_star =
1550 List.exists
1551 (fun (rc : Ast.result_col) ->
1552 match rc.expr with Star | Qualified_star _ -> true | _ -> false)
1553 s.cols
1554 in
1555 if not has_star then
1556 List.map
1557 (fun (rc : Ast.result_col) ->
1558 agg_value ~empty ?rep cat params envs rc.expr)
1559 s.cols
1560 else
1561 List.concat_map
1562 (fun (rc : Ast.result_col) ->
1563 match rc.expr with
1564 | Star -> List.concat_map frame_values (rep_row ())
1565 | Qualified_star q -> (
1566 match aliased_ci (String.uppercase_ascii q) (rep_row ()) with
1567 | Some f -> frame_values f
1568 | None -> Fmt.failwith "no such table: %s" q)
1569 | e -> [ agg_value ~empty ?rep cat params envs e ])
1570 s.cols
1571
1572(* The representative row for bare (non-aggregate) columns: sqlite3 takes them
1573 from the row achieving a lone [min()]/[max()] in the select list (NULLs are
1574 ignored, as by the aggregate). [None] when there is no such aggregate, so the
1575 caller uses an arbitrary row. *)
1576let minmax_rep cat params (s : select) envs =
1577 let target =
1578 List.find_map
1579 (fun (rc : Ast.result_col) ->
1580 match rc.expr with
1581 | Func ("min", [ a ]) -> Some (`Min, a)
1582 | Func ("max", [ a ]) -> Some (`Max, a)
1583 | _ -> None)
1584 s.cols
1585 in
1586 match (target, envs) with
1587 | None, _ | _, [] -> None
1588 | Some (dir, arg), e0 :: rest ->
1589 let better cur env =
1590 let cv = eval cat params cur arg and ev = eval cat params env arg in
1591 if ev = Null then false
1592 else if cv = Null then true
1593 else
1594 let c = compare_values ev cv in
1595 match dir with `Min -> c < 0 | `Max -> c > 0
1596 in
1597 Some
1598 (List.fold_left
1599 (fun best env -> if better best env then env else best)
1600 e0 rest)
1601
1602let order_cmp cat params order_by e1 e2 =
1603 let rec cmp = function
1604 | [] -> 0
1605 | (oe, dir) :: rest ->
1606 let va = eval cat params e1 oe and vb = eval cat params e2 oe in
1607 let c =
1608 match explicit_collation oe with
1609 | Some name -> compare_values_coll name va vb
1610 | None -> compare_values va vb
1611 in
1612 let c = match dir with Asc -> c | Desc -> -c in
1613 if c <> 0 then c else cmp rest
1614 in
1615 cmp order_by
1616
1617let order cat params s envs =
1618 if s.order_by = [] then envs
1619 else List.stable_sort (order_cmp cat params s.order_by) envs
1620
1621(* Partition rows into groups by the GROUP BY key tuple, keeping the groups in
1622 first-appearance order; each group is the list of its rows. *)
1623let group_envs cat params keys envs =
1624 (* Two rows fall in the same group when their key values are equal under the
1625 key's collation: a NOCASE GROUP BY key folds case. [resolve_collations] has
1626 already made a column's declared collation explicit, so a non-default
1627 sequence shows up as a [Collate] wrapper. *)
1628 let group_key env =
1629 List.map
1630 (fun e ->
1631 match (explicit_collation e, eval cat params env e) with
1632 | Some c, Text s -> collation_key c (Text s)
1633 | _, v -> v)
1634 keys
1635 in
1636 let tbl = Hashtbl.create 16 in
1637 let seen = ref [] in
1638 List.iter
1639 (fun env ->
1640 let k = group_key env in
1641 match Hashtbl.find_opt tbl k with
1642 | Some r -> r := env :: !r
1643 | None ->
1644 Hashtbl.add tbl k (ref [ env ]);
1645 seen := k :: !seen)
1646 envs;
1647 List.rev_map (fun k -> List.rev !(Hashtbl.find tbl k)) !seen
1648
1649(* One row's window value: ranking from its position, navigation/aggregate over
1650 the frame [lo, hi] (ordered positions). [at i e] evaluates [e] at the i-th
1651 ordered row. *)
1652let window_lag_lead ~name ~args ~k ~pos ~at ~evcur =
1653 let off =
1654 match List.nth_opt args 1 with
1655 | Some o -> Int64.to_int (intify (evcur o))
1656 | None -> 1
1657 in
1658 let dflt =
1659 match List.nth_opt args 2 with Some d -> evcur d | None -> Null
1660 in
1661 let t = if name = "lag" then pos - off else pos + off in
1662 if t >= 0 && t < k then at t (List.hd args) else dflt
1663
1664let window_nth_value ~args ~lo ~hi ~at ~evcur =
1665 let nn = Int64.to_int (intify (evcur (List.nth args 1))) in
1666 let t = lo + (nn - 1) in
1667 if nn >= 1 && t <= hi then at t (List.hd args) else Null
1668
1669let window_ntile ~args ~k ~pos ~evcur =
1670 let nb = max 1 (Int64.to_int (intify (evcur (List.hd args)))) in
1671 let base = k / nb and rem = k mod nb in
1672 let big = rem * (base + 1) in
1673 let b = if pos < big then pos / (base + 1) else rem + ((pos - big) / base) in
1674 Int (Int64.of_int (b + 1))
1675
1676let frame_rows ~envs_a ~oa ~lo ~hi =
1677 if lo > hi then []
1678 else List.init (hi - lo + 1) (fun r -> envs_a.(oa.(lo + r)))
1679
1680let window_value cat params ~name ~args ~distinct ~envs_a ~oa ~peer_start ~k
1681 ~dense ~pos ~lo ~hi =
1682 let at i e = eval cat params envs_a.(oa.(i)) e in
1683 let evcur e = eval cat params envs_a.(oa.(pos)) e in
1684 match name with
1685 | "row_number" -> Int (Int64.of_int (pos + 1))
1686 | "rank" -> Int (Int64.of_int (peer_start.(pos) + 1))
1687 | "dense_rank" -> Int (Int64.of_int dense)
1688 | "first_value" -> if lo <= hi then at lo (List.hd args) else Null
1689 | "last_value" -> if lo <= hi then at hi (List.hd args) else Null
1690 | "lag" | "lead" -> window_lag_lead ~name ~args ~k ~pos ~at ~evcur
1691 | "nth_value" -> window_nth_value ~args ~lo ~hi ~at ~evcur
1692 | "ntile" -> window_ntile ~args ~k ~pos ~evcur
1693 | _ ->
1694 let frame = frame_rows ~envs_a ~oa ~lo ~hi in
1695 agg_call ~distinct cat params frame name args
1696
1697(* Compute one partition's window values into [arr]: order [idxs] by the
1698 window's ORDER BY, find peer-group bounds (peers share a rank and a frame),
1699 and write each row's value (ranking by position, aggregate over its
1700 frame). *)
1701let fill_window_partition cat params ~name ~args ~distinct w envs_a arr idxs =
1702 let oa =
1703 Array.of_list
1704 (List.stable_sort
1705 (fun i j -> order_cmp cat params w.order envs_a.(i) envs_a.(j))
1706 idxs)
1707 in
1708 let k = Array.length oa in
1709 let peer_start = Array.make k 0 and peer_end = Array.make k 0 in
1710 let p = ref 0 in
1711 while !p < k do
1712 let q = ref !p in
1713 while
1714 !q + 1 < k
1715 && order_cmp cat params w.order envs_a.(oa.(!p)) envs_a.(oa.(!q + 1)) = 0
1716 do
1717 incr q
1718 done;
1719 for r = !p to !q do
1720 peer_start.(r) <- !p;
1721 peer_end.(r) <- !q
1722 done;
1723 p := !q + 1
1724 done;
1725 let dense = ref 0 and prev_start = ref (-1) in
1726 for pos = 0 to k - 1 do
1727 if peer_start.(pos) <> !prev_start then begin
1728 incr dense;
1729 prev_start := peer_start.(pos)
1730 end;
1731 let evcur e = eval cat params envs_a.(oa.(pos)) e in
1732 let lo, hi = window_frame ~pos ~k ~peer_start ~peer_end ~evcur w in
1733 arr.(oa.(pos)) <-
1734 window_value cat params ~name ~args ~distinct ~envs_a ~oa ~peer_start ~k
1735 ~dense:!dense ~pos ~lo ~hi
1736 done
1737
1738(* Evaluate the window function [Window (f, w)] over [envs], returning a value
1739 per env (aligned to [envs] order). Rows are partitioned by [w.partition],
1740 ordered within each partition by [w.order]; ranking functions use the
1741 position, aggregates use the default frame (the whole partition with no ORDER
1742 BY, else running through the current row's peer group). *)
1743let eval_window cat params we envs =
1744 let fexpr, w = match we with Window (f, w) -> (f, w) | _ -> assert false in
1745 let name, args, distinct =
1746 match fexpr with
1747 | Func (n, a) -> (n, a, false)
1748 | Distinct_agg (n, a) -> (n, [ a ], true)
1749 | _ -> failwith "window: not a function call"
1750 in
1751 let envs_a = Array.of_list envs in
1752 let n = Array.length envs_a in
1753 let arr = Array.make n Null in
1754 (* partition the row indices by the partition-key tuple *)
1755 let tbl = Hashtbl.create 16 and keys = ref [] in
1756 Array.iteri
1757 (fun i env ->
1758 let k = List.map (eval cat params env) w.partition in
1759 match Hashtbl.find_opt tbl k with
1760 | Some r -> r := i :: !r
1761 | None ->
1762 Hashtbl.add tbl k (ref [ i ]);
1763 keys := k :: !keys)
1764 envs_a;
1765 let parts = List.rev_map (fun k -> List.rev !(Hashtbl.find tbl k)) !keys in
1766 List.iter
1767 (fun idxs ->
1768 fill_window_partition cat params ~name ~args ~distinct w envs_a arr idxs)
1769 parts;
1770 arr
1771
1772(* Project [envs] when the select list has window functions: compute each window
1773 value per env, then project, substituting the windows. The outer ORDER BY
1774 sorts after the windows are computed (their frames are independent of it). *)
1775let window_project ~ordered cat params (s : Ast.select) envs =
1776 let wins =
1777 List.map
1778 (fun we -> (we, eval_window cat params we envs))
1779 (window_exprs s.cols)
1780 in
1781 let indexed = List.mapi (fun i env -> (i, env)) envs in
1782 let indexed =
1783 if ordered then
1784 List.stable_sort
1785 (fun (_, e1) (_, e2) -> order_cmp cat params s.order_by e1 e2)
1786 indexed
1787 else indexed
1788 in
1789 List.map
1790 (fun (i, env) ->
1791 let lookup we = (List.assoc we wins).(i) in
1792 List.concat_map
1793 (fun (rc : Ast.result_col) ->
1794 match rc.expr with
1795 | Star -> List.concat_map frame_values env
1796 | Qualified_star q -> (
1797 match aliased_ci (String.uppercase_ascii q) env with
1798 | Some f -> frame_values f
1799 | None -> Fmt.failwith "no such table: %s" q)
1800 | e -> [ eval cat params env (subst_windows lookup e) ])
1801 s.cols)
1802 indexed
1803
1804(* Run one SELECT/VALUES core to output rows: combine, filter, group/aggregate
1805 or project, distinct. [~order] applies the core's own ORDER BY (true for a
1806 plain select; false for a compound's cores, whose ordering is the
1807 compound-wide ORDER BY applied to the combined rows). *)
1808(* Turn the WHERE-filtered row environments [envs] into output rows: a GROUP BY
1809 folds each group's aggregates (ordering the groups when [ordered]); an
1810 aggregate select list or HAVING with no GROUP BY is one implicit group; a
1811 window select projects through {!window_project}; otherwise it is an ordinary
1812 sort-and-project. Used by {!aggregate_scan}, which is handed already-scanned
1813 rows for the grouping / window post-pass. *)
1814let core_rows ~ordered cat params s envs =
1815 (* The all-NULL schema env for an empty implicit group (an empty table with no
1816 GROUP BY), so a bare column in HAVING/the select list reads as NULL. *)
1817 let empty = schema_env cat s in
1818 (* HAVING keeps a group only when its (aggregate) predicate is true; a NULL
1819 result is untrue and drops the group. *)
1820 let keep_group g =
1821 match s.having with
1822 | None -> true
1823 | Some h -> tri_of (agg_value ~empty cat params g h) = T
1824 in
1825 if s.group_by <> [] then
1826 let groups = group_envs cat params s.group_by envs in
1827 let groups =
1828 if not ordered then groups
1829 (* a compound arm: combine_compound re-orders, so leave first-seen *)
1830 else
1831 (* sqlite3 emits GROUP BY result rows in the group key's ascending order
1832 when there is no ORDER BY; an explicit ORDER BY overrides it. *)
1833 let keys =
1834 if s.order_by <> [] then s.order_by
1835 else List.map (fun e -> (e, Asc)) s.group_by
1836 in
1837 List.stable_sort
1838 (fun g1 g2 -> order_cmp cat params keys (List.hd g1) (List.hd g2))
1839 groups
1840 in
1841 List.filter_map
1842 (fun g ->
1843 let rep = minmax_rep cat params s g in
1844 if keep_group g then Some (aggregate ?rep cat params s g) else None)
1845 groups
1846 else if List.exists is_aggregate s.cols || s.having <> None then
1847 (* No GROUP BY but an aggregate select list or a HAVING clause: the whole
1848 input is one implicit group (lang_select.html). *)
1849 let rep = minmax_rep cat params s envs in
1850 if keep_group envs then [ aggregate ~empty ?rep cat params s envs ] else []
1851 else if window_exprs s.cols <> [] then
1852 window_project ~ordered cat params s envs
1853 else
1854 let envs = if ordered then order cat params s envs else envs in
1855 List.map (project cat params s) envs
1856
1857(* ORDER BY over a compound's output rows: a bare integer is an ordinal (1-based
1858 output column), a bare name is an output column, anything else is evaluated
1859 against the row keyed by the output column names. *)
1860let compound_order cat params names order_by rows =
1861 if order_by = [] then rows
1862 else
1863 let nth row i = Option.value (List.nth_opt row i) ~default:Null in
1864 let col_index name =
1865 let rec go i = function
1866 | [] -> None
1867 | x :: _ when x = name -> Some i
1868 | _ :: r -> go (i + 1) r
1869 in
1870 go 0 names
1871 in
1872 (* [ORDER BY k COLLATE c] wraps the ordinal in [Collate]; the collation is
1873 read by [cmp] below, so here just look through it to the key itself. *)
1874 let rec key row oe =
1875 match oe with
1876 | Lit (Int n) -> nth row (Int64.to_int n - 1)
1877 | Col (_, name) -> (
1878 match col_index name with Some i -> nth row i | None -> Null)
1879 | Collate (e, _) -> key row e
1880 | _ -> eval cat params [ Pos ("", names, row, None) ] oe
1881 in
1882 List.stable_sort
1883 (fun r1 r2 ->
1884 let rec cmp = function
1885 | [] -> 0
1886 | (oe, dir) :: rest ->
1887 let c =
1888 match explicit_collation oe with
1889 | Some name -> compare_values_coll name (key r1 oe) (key r2 oe)
1890 | None -> compare_values (key r1 oe) (key r2 oe)
1891 in
1892 let c = match dir with Asc -> c | Desc -> -c in
1893 if c <> 0 then c else cmp rest
1894 in
1895 cmp order_by)
1896 rows
1897
1898let apply_limit cat params s rows =
1899 (* OFFSET first, then LIMIT. A negative/NULL offset skips nothing; a negative
1900 LIMIT is unbounded; LIMIT 0 yields no rows (lang_select.html). *)
1901 (* An offset/limit beyond the row count (up to int64 max) must not overflow
1902 [Int64.to_int]; compare against the length first. *)
1903 let count = Int64.of_int (List.length rows) in
1904 let rows =
1905 match s.offset with
1906 | None -> rows
1907 | Some e -> (
1908 match eval cat params [] e with
1909 | Int n when n >= count -> []
1910 | Int n when n > 0L -> drop (Int64.to_int n) rows
1911 | _ -> rows)
1912 in
1913 match s.limit with
1914 | None -> rows
1915 | Some e -> (
1916 match eval cat params [] e with
1917 | Int n when n < 0L -> rows
1918 | Int n when n >= Int64.of_int (List.length rows) -> rows
1919 | Int n -> take (Int64.to_int n) rows
1920 | Null -> rows
1921 | _ -> failwith "LIMIT must be an integer")
1922
1923(* Materialise each join operand that is a subquery [(q) alias] under its alias,
1924 so the join machinery sees it as an ordinary named relation. *)
1925let bind_join_subqueries ?(scope = []) cat params joins =
1926 List.fold_left
1927 (fun cat (j : Ast.join) ->
1928 match j.table.subquery with
1929 | None -> cat
1930 | Some sub ->
1931 let cols = select_columns cat sub in
1932 let rows = !cat_subquery_runner cat scope sub params in
1933 bind_relation cat j.table.name cols rows)
1934 cat joins
1935
1936let combine ?(scope = []) cat params s : env list =
1937 let cat = bind_join_subqueries ~scope cat params s.joins in
1938 let no_rowid = List.map (fun r -> (None, r)) in
1939 let alias, cols, from_rows =
1940 match s.from with
1941 | Unit -> ("", [], [ (None, []) ])
1942 | Table tr ->
1943 let alias, cols = frag cat tr in
1944 (* A full scan carries each row's rowid (for the implicit rowid column);
1945 an index-narrowed scan drops it, so rowid stays unresolvable
1946 there. *)
1947 let rows =
1948 match from_access cat params tr s.where with
1949 | Some (_, rows) -> no_rowid rows
1950 | None -> cat.rows_rowid tr.name
1951 in
1952 (alias, cols, rows)
1953 | Select { fs_select; fs_alias } ->
1954 let alias = Option.value fs_alias ~default:"" in
1955 let cols = select_columns cat fs_select in
1956 (alias, cols, no_rowid (!cat_subquery_runner cat scope fs_select params))
1957 | Values tuples ->
1958 let n = match tuples with r :: _ -> List.length r | [] -> 0 in
1959 let cols = List.init n (fun i -> Fmt.str "column%d" (i + 1)) in
1960 let env = frames_of_scope scope in
1961 ("", cols, no_rowid (List.map (List.map (eval cat params env)) tuples))
1962 | Table_function { tf_name; tf_args; tf_alias } ->
1963 let alias = Option.value tf_alias ~default:tf_name in
1964 let env = frames_of_scope scope in
1965 let cols, rows =
1966 table_function tf_name (List.map (eval cat params env) tf_args)
1967 in
1968 (alias, cols, no_rowid rows)
1969 in
1970 let base =
1971 List.map (fun (rid, vals) -> [ Pos (alias, cols, vals, rid) ]) from_rows
1972 in
1973 let resolved = resolve_natural cat (alias, cols) s.joins in
1974 let info_of j =
1975 match List.find_opt (fun (j', _, _) -> j' == j) resolved with
1976 | Some (_, d, lt) -> (d, lt)
1977 | None -> ([], [])
1978 in
1979 let joined =
1980 List.fold_left
1981 (fun envs j ->
1982 let drop, left_template = info_of j in
1983 join_with cat params ~drop ~left_template j envs)
1984 base
1985 (plan_joins cat alias (List.map (fun (j, _, _) -> j) resolved))
1986 in
1987 (* The outer [scope] sits at the tail: inner tables shadow it for unqualified
1988 names, but a qualified [outer.col] / [OLD.col] / [NEW.col] still
1989 resolves. *)
1990 if scope = [] then joined
1991 else
1992 let tail = frames_of_scope scope in
1993 List.map (fun env -> env @ tail) joined
1994
1995(* Recursive CTE by semi-naive (delta) evaluation -- the SQLite / differential
1996 algorithm: seed with the non-recursive arm; each round runs the recursive
1997 arm(s) over only the previous round's new rows ([working]), so work is the
1998 delta, not the whole accumulated relation. UNION dedups new rows against the
1999 full result; UNION ALL keeps them. [cat] already binds [name] (to be rebound
2000 per round). A row cap guards against a non-terminating recursion. *)
2001let run_recursive cat name cols params query =
2002 let op = match query.compound with (op, _) :: _ -> op | [] -> Union_all in
2003 let dedup_union = op = Union in
2004 let strip s = { s with compound = []; order_by = []; limit = None } in
2005 let initial = strip query in
2006 let arms = List.map (fun (_, arm) -> strip arm) query.compound in
2007 let rebind rows = bind_relation cat name cols rows in
2008 (* The seed and each recursive arm are stripped non-compound cores; run them
2009 on the catalog VM (the injected runner), so recursive-CTE evaluation never
2010 reaches the tree-walker. *)
2011 let run cat' s = !cat_subquery_runner cat' [] s params in
2012 let seed = run (rebind []) initial in
2013 let rec loop result working =
2014 if working = [] then result
2015 else
2016 let cat' = rebind working in
2017 let delta = List.concat_map (fun arm -> run cat' arm) arms in
2018 let delta =
2019 if dedup_union then
2020 dedup (List.filter (fun r -> not (List.mem r result)) delta)
2021 else delta
2022 in
2023 if delta = [] then result
2024 else if List.length result + List.length delta > 1_000_000 then
2025 failwith "recursive CTE exceeded 1,000,000 rows"
2026 else loop (result @ delta) delta
2027 in
2028 loop seed seed
2029
2030(* Bind each WITH table expression as a row source, materialized once (the
2031 state-of-the-art choice when a CTE is read more than once, as our nested-loop
2032 joins do). Later CTEs see the earlier ones. A recursive body evaluates to a
2033 fixpoint; a non-recursive one runs on the catalog VM (the injected
2034 runner). *)
2035let materialize_ctes cat params ctes =
2036 List.fold_left
2037 (fun cat (c : cte) ->
2038 let cols =
2039 match c.columns with [] -> select_columns cat c.query | cs -> cs
2040 in
2041 let rows =
2042 if references_table c.name c.query then
2043 run_recursive cat c.name cols params c.query
2044 else !cat_subquery_runner cat [] c.query params
2045 in
2046 bind_relation cat c.name cols rows)
2047 cat ctes
2048
2049(* Does any expression reference the implicit [rowid] pseudo-column? A subquery
2050 or window expression returns [true] conservatively (the caller then keeps such
2051 a select on the tree-walker rather than the rowid-free VM scan). *)
2052(* Whether [e] references a [rowid] column. A subquery / [EXISTS] reads as [true]
2053 (its scan is separate). A [Window] is opaque by default (the plain aggregate
2054 path cannot scan it); with [~through_window], it descends into the window's
2055 function, partition, and order keys -- the window node itself is what the
2056 window post-pass compiles, not a rowid reference, but a rowid inside its
2057 scanned components still matters. *)
2058let rec expr_references_rowid ?(through_window = false) e =
2059 let r = expr_references_rowid ~through_window in
2060 match e with
2061 | Col (_, name) -> is_rowid_name name
2062 | Lit _ | Param _ | Star | Qualified_star _ -> false
2063 | Unop_not e
2064 | Is_null e
2065 | Is_not_null e
2066 | Cast (e, _)
2067 | Collate (e, _)
2068 | Distinct_agg (_, e) ->
2069 r e
2070 | Binary (_, a, b) | Is (a, b) | Filter (a, b) -> r a || r b
2071 | In_list (e, l) -> r e || List.exists r l
2072 | Func (_, args) -> List.exists r args
2073 | Ordered_agg (a, ob) -> r a || List.exists (fun (e, _) -> r e) ob
2074 | Case (base, brs, els) ->
2075 Option.fold ~none:false ~some:r base
2076 || List.exists (fun (c, x) -> r c || r x) brs
2077 || Option.fold ~none:false ~some:r els
2078 | Window (f, w) ->
2079 through_window
2080 && (r f || List.exists r w.partition
2081 || List.exists (fun (oe, _) -> r oe) w.order)
2082 | In_select _ | Scalar_select _ | Exists _ -> true
2083
2084(* Whether [s] is an aggregate/GROUP BY select that {!aggregate_scan} can run:
2085 it groups or aggregates or has HAVING and uses no window function. The scan
2086 carries the implicit rowid column ([rowid_sentinel]) like any base-table
2087 scan, so an aggregate over [rowid] (e.g. [count(rowid)]) compiles too. *)
2088let aggregate_compilable (s : select) =
2089 (s.group_by <> [] || s.having <> None || List.exists is_aggregate s.cols)
2090 && window_exprs s.cols = []
2091
2092(* A select with a window function over a [rowid]-free projection: like an
2093 aggregate, it scans its (filtered, joined) source rows then post-processes
2094 them ({!window_project}, reached through {!aggregate_scan}). Lets the
2095 register VM run the scan instead of falling back wholesale. *)
2096let window_compilable (s : select) =
2097 let rowid = expr_references_rowid ~through_window:true in
2098 window_exprs s.cols <> []
2099 && not
2100 (List.exists (fun (rc : Ast.result_col) -> rowid rc.expr) s.cols
2101 || List.exists (fun (e, _) -> rowid e) s.order_by)
2102
2103(* Run an aggregate/GROUP BY [s] from its already-scanned source [rows] and
2104 reuse {!core_rows} for the grouping/aggregation/HAVING and ORDER BY, then
2105 dedup (DISTINCT) and apply OFFSET/LIMIT. [segments] names the join's tables
2106 in FROM order as [(alias, cols)]; each scanned row is the concatenation of
2107 its tables' columns in that order, so it is sliced back into one [Pos]
2108 binding per table -- a single-table aggregate is just a one-element
2109 [segments]. Lets the register VM do the (possibly joined) scan and reuse this
2110 aggregation. *)
2111let aggregate_scan cat params (s : select) segments rows =
2112 let bind vals =
2113 let env, _ =
2114 List.fold_left
2115 (fun (acc, rest) (alias, cols) ->
2116 let n = List.length cols in
2117 (Pos (alias, cols, take n rest, None) :: acc, drop n rest))
2118 ([], vals) segments
2119 in
2120 List.rev env
2121 in
2122 let envs = List.map bind rows in
2123 let rows = core_rows ~ordered:true cat params s envs in
2124 let rows = if s.distinct then dedup rows else rows in
2125 apply_limit cat params s rows
2126
2127(* Combine the already-computed arm rows of a compound [s] -- [base_rows] for
2128 the leading arm and [(op, rows)] for each following arm: fold the set
2129 operators, order by [s.order_by] over the output columns, then apply
2130 OFFSET/LIMIT. Lets a caller compute each arm however it likes (the register
2131 VM) and reuse this compound orchestration. *)
2132let combine_compound cat params (s : select) base_rows compound_rows =
2133 let combined =
2134 List.fold_left
2135 (fun acc (op, rows) -> set_op op acc rows)
2136 base_rows compound_rows
2137 in
2138 let ordered =
2139 compound_order cat params (select_columns cat s) s.order_by combined
2140 in
2141 apply_limit cat params s ordered
2142
2143(* Each FROM source of [s] as (alias, its column names) -- the column scope a
2144 subquery body resolves against. A name that does not resolve (e.g. a CTE
2145 absent from the base catalog) contributes no columns, so a subquery using it
2146 reads as correlated and is left for the tree-walker rather than wrongly
2147 hoisted. *)
2148let from_scope cat (s : select) : (string * string list) list =
2149 let cols_of name = try cat.columns name with Failure _ -> [] in
2150 let alias_or_name (tr : table_ref) =
2151 match tr.alias with Some a -> a | None -> tr.name
2152 in
2153 let of_ref (tr : table_ref) =
2154 match tr.subquery with
2155 | Some q -> (alias_or_name tr, select_columns cat q)
2156 | None -> (alias_or_name tr, cols_of tr.name)
2157 in
2158 let leading =
2159 match s.from with
2160 | Table tr -> [ of_ref tr ]
2161 | Select { fs_select; fs_alias } ->
2162 [ (Option.value fs_alias ~default:"", select_columns cat fs_select) ]
2163 | Values tuples ->
2164 let n = match tuples with r :: _ -> List.length r | [] -> 0 in
2165 [ ("", List.init n (fun i -> Fmt.str "column%d" (i + 1))) ]
2166 | Unit | Table_function _ -> []
2167 in
2168 leading @ List.map (fun (j : join) -> of_ref j.table) s.joins
2169
2170(* Whether [s], read as a subquery under the column scope [bound] (alias -> its
2171 columns), references a FREE column -- one bound by neither [bound] nor [s]'s
2172 own FROM. A free column makes the subquery CORRELATED to an enclosing query,
2173 so it cannot be materialised on its own. A nested subquery extends the scope,
2174 so it is checked under [scope]. Conservative: a qualified column whose alias
2175 is unknown, or an unqualified column in no in-scope table, counts as free. *)
2176let rec correlated cat bound (s : select) =
2177 let scope = bound @ from_scope cat s in
2178 let col_free = function
2179 | Col (Some q, _) -> not (List.mem_assoc q scope)
2180 | Col (None, c) ->
2181 not (List.exists (fun (_, cols) -> List.mem c cols) scope)
2182 | _ -> false
2183 in
2184 let rec free e =
2185 match e with
2186 | Col _ -> col_free e
2187 | Lit _ | Param _ | Star | Qualified_star _ -> false
2188 | Unop_not x
2189 | Is_null x
2190 | Is_not_null x
2191 | Cast (x, _)
2192 | Collate (x, _)
2193 | Distinct_agg (_, x) ->
2194 free x
2195 | Binary (_, a, b) | Is (a, b) | Filter (a, b) -> free a || free b
2196 | In_list (x, l) -> free x || List.exists free l
2197 | Func (_, args) -> List.exists free args
2198 | Ordered_agg (x, ob) -> free x || List.exists (fun (e, _) -> free e) ob
2199 | Window (x, w) ->
2200 free x
2201 || List.exists free w.partition
2202 || List.exists (fun (e, _) -> free e) w.order
2203 | Case (base, branches, els) ->
2204 Option.fold ~none:false ~some:free base
2205 || List.exists (fun (c, r) -> free c || free r) branches
2206 || Option.fold ~none:false ~some:free els
2207 | Scalar_select sub | Exists sub -> correlated cat scope sub
2208 | In_select (x, sub) -> free x || correlated cat scope sub
2209 in
2210 List.exists (fun (rc : result_col) -> free rc.expr) s.cols
2211 || Option.fold ~none:false ~some:free s.where
2212 || Option.fold ~none:false ~some:free s.having
2213 || List.exists free s.group_by
2214 || List.exists (fun (e, _) -> free e) s.order_by
2215 || List.exists (fun (j : join) -> free j.on) s.joins
2216 || List.exists (fun (_, arm) -> correlated cat bound arm) s.compound
2217
2218exception Subst_hard
2219(** Raised by {!subst_expr} on a node the simple substituter does not descend
2220 into (a nested subquery or a window), so the caller falls back. *)
2221
2222(* Rebuild [e], applying [replace qual name e] to each column reference and
2223 recursing structurally everywhere else. A nested subquery / window raises
2224 {!Subst_hard}. *)
2225let rec subst_expr ~replace e =
2226 let go = subst_expr ~replace in
2227 match e with
2228 | Col (qual, name) -> replace qual name e
2229 | Scalar_select _ | In_select _ | Exists _ | Window _ -> raise Subst_hard
2230 | Lit _ | Param _ | Star | Qualified_star _ -> e
2231 | Unop_not a -> Unop_not (go a)
2232 | Binary (op, a, b) -> Binary (op, go a, go b)
2233 | Is (a, b) -> Is (go a, go b)
2234 | Is_null a -> Is_null (go a)
2235 | Is_not_null a -> Is_not_null (go a)
2236 | In_list (a, l) -> In_list (go a, List.map go l)
2237 | Func (n, args) -> Func (n, List.map go args)
2238 | Distinct_agg (n, a) -> Distinct_agg (n, go a)
2239 | Filter (a, b) -> Filter (go a, go b)
2240 | Ordered_agg (a, ob) ->
2241 Ordered_agg (go a, List.map (fun (e, d) -> (go e, d)) ob)
2242 | Cast (a, t) -> Cast (go a, t)
2243 | Collate (a, c) -> Collate (go a, c)
2244 | Case (b, br, el) ->
2245 Case
2246 ( Option.map go b,
2247 List.map (fun (c, r) -> (go c, go r)) br,
2248 Option.map go el )
2249
2250(* Substitute each FREE column of subquery [s] -- a column bound by neither
2251 [s]'s own FROM (which shadows the outer query) nor a deeper scope -- with its
2252 value from [scope] (the enclosing row), turning a correlated subquery into an
2253 uncorrelated one that can run on its own. [None] when [s] is too tangled for
2254 the simple rule (a FROM-subquery, a nested subquery, or a window), so the
2255 caller evaluates it under [~scope] on the tree-walker instead. *)
2256let substitute_scope cat scope (s : select) : select option =
2257 let own = from_scope cat s in
2258 let own_aliases = List.map fst own in
2259 let own_cols = List.concat_map snd own in
2260 let bound qual name =
2261 match qual with
2262 | Some q -> List.mem q own_aliases
2263 | None -> List.mem name own_cols
2264 in
2265 (* Resolve a free column against [scope]. The alias matches case-insensitively
2266 (as the tree-walker's {!lookup} does, for the [OLD]/[NEW] pseudo-tables
2267 written in any case); the column name matches exactly, as
2268 {!frame_lookup}. *)
2269 let lookup qual name =
2270 let alias_eq q a =
2271 String.equal q a
2272 || String.equal (String.uppercase_ascii q) (String.uppercase_ascii a)
2273 in
2274 let rec find = function
2275 | (alias, cols) :: rest -> (
2276 match qual with
2277 | Some q when not (alias_eq q alias) -> find rest
2278 | _ -> (
2279 match List.assoc_opt name cols with
2280 | Some v -> Some v
2281 | None -> find rest))
2282 | [] -> None
2283 in
2284 find scope
2285 in
2286 (* A free column must resolve to a scope value; one that does not (a deeper
2287 correlation than [scope] carries) makes the whole substitution [None], so
2288 the caller keeps the tree-walker, rather than leaving an unbound column
2289 that would fail when the substituted select runs without a scope. *)
2290 let replace qual name e =
2291 if bound qual name then e
2292 else
2293 match lookup qual name with Some v -> Lit v | None -> raise Subst_hard
2294 in
2295 let sub = subst_expr ~replace in
2296 let sub_col (rc : Ast.result_col) = { rc with expr = sub rc.expr } in
2297 (* A FROM/join subquery is left untouched, which is sound only when it is
2298 uncorrelated; a lateral one (referencing the outer scope) falls back. *)
2299 let from_subq_ok q = not (correlated cat [] q) in
2300 try
2301 (match s.from with
2302 | Select { fs_select; _ } when not (from_subq_ok fs_select) ->
2303 raise Subst_hard
2304 | _ -> ());
2305 List.iter
2306 (fun (j : join) ->
2307 match j.table.subquery with
2308 | Some q when not (from_subq_ok q) -> raise Subst_hard
2309 | Some _ | None -> ())
2310 s.joins;
2311 Some
2312 {
2313 s with
2314 cols = List.map sub_col s.cols;
2315 where = Option.map sub s.where;
2316 group_by = List.map sub s.group_by;
2317 having = Option.map sub s.having;
2318 order_by = List.map (fun (e, d) -> (sub e, d)) s.order_by;
2319 joins = List.map (fun (j : join) -> { j with on = sub j.on }) s.joins;
2320 }
2321 with Subst_hard -> None
2322
2323(* Replace each uncorrelated scalar / [IN (SELECT ...)] / [EXISTS] subquery in
2324 [s]'s scalar-expression positions with its materialised value, so the
2325 register VM -- which has no subquery opcode -- sees a literal or IN-list
2326 instead and compiles the outer query. A correlated subquery is left untouched
2327 (the VM falls back for it). The subquery is evaluated with the outer [params]
2328 (a [?] indexes the same array) but no row scope, which is exactly its value
2329 when uncorrelated; safe to evaluate eagerly because {!eval} is itself eager
2330 on AND/OR. *)
2331let hoist_subqueries ~run cat (s : select) : select =
2332 let first_col = function v :: _ -> v | [] -> Null in
2333 let scalar sub =
2334 match run sub with (v :: _) :: _ -> Lit v | _ -> Lit Null
2335 in
2336 let rec go e =
2337 match e with
2338 | Scalar_select sub when not (correlated cat [] sub) -> scalar sub
2339 | Exists sub when not (correlated cat [] sub) -> Lit (bool (run sub <> []))
2340 | In_select (x, sub) when not (correlated cat [] sub) ->
2341 In_list (go x, List.map (fun v -> Lit v) (List.map first_col (run sub)))
2342 | Lit _ | Param _ | Col _ | Star | Qualified_star _ | Scalar_select _
2343 | Exists _ ->
2344 e
2345 | In_select (x, sub) -> In_select (go x, sub)
2346 | Unop_not x -> Unop_not (go x)
2347 | Is_null x -> Is_null (go x)
2348 | Is_not_null x -> Is_not_null (go x)
2349 | Cast (x, t) -> Cast (go x, t)
2350 | Collate (x, c) -> Collate (go x, c)
2351 | Distinct_agg (n, x) -> Distinct_agg (n, go x)
2352 | Binary (op, a, b) -> Binary (op, go a, go b)
2353 | Is (a, b) -> Is (go a, go b)
2354 | Filter (a, b) -> Filter (go a, go b)
2355 | In_list (x, l) -> In_list (go x, List.map go l)
2356 | Func (n, args) -> Func (n, List.map go args)
2357 | Ordered_agg (x, ob) ->
2358 Ordered_agg (go x, List.map (fun (e, d) -> (go e, d)) ob)
2359 | Window (x, w) ->
2360 Window
2361 ( go x,
2362 {
2363 w with
2364 partition = List.map go w.partition;
2365 order = List.map (fun (e, d) -> (go e, d)) w.order;
2366 } )
2367 | Case (base, br, els) ->
2368 Case
2369 ( Option.map go base,
2370 List.map (fun (c, r) -> (go c, go r)) br,
2371 Option.map go els )
2372 in
2373 {
2374 s with
2375 cols =
2376 List.map (fun (rc : result_col) -> { rc with expr = go rc.expr }) s.cols;
2377 where = Option.map go s.where;
2378 group_by = List.map go s.group_by;
2379 having = Option.map go s.having;
2380 order_by = List.map (fun (e, d) -> (go e, d)) s.order_by;
2381 joins = List.map (fun (j : join) -> { j with on = go j.on }) s.joins;
2382 }
2383
2384(* The join-row environments of a bare [FROM from joins] (no projection, no
2385 WHERE) -- each is a [binding list] usable as an outer [~scope]. This drives
2386 [UPDATE ... FROM], whose auxiliary tables are visible to SET and WHERE. *)
2387let from_bindings ?(scope = []) cat params from joins =
2388 let s =
2389 {
2390 ctes = [];
2391 distinct = false;
2392 cols = [ { expr = Star; alias = None } ];
2393 from;
2394 joins;
2395 where = None;
2396 group_by = [];
2397 having = None;
2398 compound = [];
2399 order_by = [];
2400 limit = None;
2401 offset = None;
2402 }
2403 in
2404 List.map bindings_of_frames (combine ~scope cat params s)
2405
2406(* The access path the executor takes, one line per table. Structural (no
2407 parameter values): the from table uses an index when one covers its
2408 equalities (the same columns {!from_access} narrows on, so EXPLAIN and run
2409 agree), and joins are nested-loop scans. *)
2410let explain cat (s : Ast.select) =
2411 let line tbl = function
2412 | Some descr -> Fmt.str "SEARCH %s USING %s" tbl descr
2413 | None -> Fmt.str "SCAN %s" tbl
2414 in
2415 let from_alias =
2416 match s.from with
2417 | Unit -> ""
2418 | Table tr -> Option.value tr.alias ~default:tr.name
2419 | Select { fs_alias; _ } -> Option.value fs_alias ~default:""
2420 | Values _ -> ""
2421 | Table_function { tf_name; tf_alias; _ } ->
2422 Option.value tf_alias ~default:tf_name
2423 in
2424 let from_line =
2425 match s.from with
2426 | Unit -> "SCAN (constant)"
2427 | Table tr ->
2428 line tr.name (cat.index_for tr.name (eq_columns from_alias s.where))
2429 | Select _ -> "SCAN (subquery)"
2430 | Values _ -> "SCAN (values)"
2431 | Table_function { tf_name; _ } -> Fmt.str "SCAN (%s)" tf_name
2432 in
2433 let join_line (j : Ast.join) =
2434 line j.table.name
2435 (cat.index_for j.table.name (join_eq_columns (join_alias j) j.on))
2436 in
2437 (* Explain the same order the executor runs (cost-based for inner joins). *)
2438 String.concat "\n"
2439 (from_line :: List.map join_line (plan_joins cat from_alias s.joins))
2440
2441(* ── Write-path evaluation ────────────────────────────────────── *)
2442
2443(* Evaluate an expression with no row in scope -- for INSERT ... VALUES, whose
2444 tuples are constants and bound parameters. A column reference here raises (no
2445 table is in scope), which is the correct error. *)
2446let eval_const ?(scope = []) cat params e =
2447 eval cat params (frames_of_scope scope) e
2448
2449(* Does [vals] (a row of [table], aligned to [cols]) satisfy [where]? Used to
2450 pick the rows a DELETE removes. No WHERE matches every row. *)
2451let row_matches ?(scope = []) ?rowid cat params table cols where vals =
2452 match where with
2453 | None -> true
2454 | Some w ->
2455 let env = Pos (table, cols, vals, rowid) :: frames_of_scope scope in
2456 tri_of (eval cat params env w) = T
2457
2458(* Evaluate [e] against a single [table] row ([vals] aligned to [cols]) -- the
2459 right-hand side of an UPDATE ... SET assignment, which may read the row's
2460 current column values. *)
2461let eval_in_row ?(scope = []) ?rowid cat params table cols vals e =
2462 eval cat params (Pos (table, cols, vals, rowid) :: frames_of_scope scope) e
2463
2464(* Evaluate an UPSERT DO UPDATE expression: the conflicting row's current values
2465 are in scope under [table], and the would-be-inserted values under the
2466 [excluded] pseudo-table (both aligned to [cols]). *)
2467let eval_upsert ?(scope = []) cat params ~table ~cols ~current ~excluded e =
2468 eval cat params
2469 (Pos (table, cols, current, None)
2470 :: Pos ("excluded", cols, excluded, None)
2471 :: frames_of_scope scope)
2472 e
2473
2474(* Project a RETURNING column list over each affected [row] of [table] ([cols]
2475 are the table's column names, aligned to [row]). [*] expands to the whole
2476 row; other items are expressions over the row. *)
2477let returning_rows cat params ~table ~cols returning rows =
2478 List.map
2479 (fun row ->
2480 let env = [ Pos (table, cols, row, None) ] in
2481 List.concat_map
2482 (fun (rc : Ast.result_col) ->
2483 match rc.expr with
2484 | Star | Qualified_star _ -> row
2485 | e -> [ eval cat params env e ])
2486 returning)
2487 rows