diff --git a/.github/workflows/matrix.yaml b/.github/workflows/matrix.yaml index 34f81f55..a12635d3 100644 --- a/.github/workflows/matrix.yaml +++ b/.github/workflows/matrix.yaml @@ -37,6 +37,40 @@ jobs: - name: Run tests run: prove6 -lj8 t + rakuast: + runs-on: ubuntu-latest + timeout-minutes: 15 + services: + postgres: + image: postgres:15 + env: + POSTGRES_PASSWORD: red-ci-test + ports: + - 5432:5432 + options: >- + --health-cmd="pg_isready -U postgres" + --health-interval=5s + --health-timeout=5s + --health-retries=20 + steps: + - uses: actions/checkout@v4 + - uses: Raku/setup-raku@v1 + with: + raku-version: "2026.09" + - name: Install dependencies with the legacy frontend + run: | + sudo apt-get update + sudo apt-get install -y libpq-dev + zef install --/test --test-depends --deps-only . + - name: Test the optional RakuAST compiler + env: + RAKUDO_RAKUAST: "1" + RED_DATABASE: "Pg host=127.0.0.1 port=5432 dbname=postgres user=postgres password=red-ci-test" + run: | + raku -Ilib t/37-json.rakutest + raku -Ilib t/92-rakuast-compiler.rakutest + raku -Ilib t/93-rakuast-scope.rakutest + mysql: name: MySQL (RakuAST=${{ matrix.rakuast }}) strategy: diff --git a/Changes b/Changes index ac26de14..47018ba5 100644 --- a/Changes +++ b/Changes @@ -14,6 +14,14 @@ Revision history for Red - Retain formatter coercions, repeated separators, Unicode and embedded control characters. - Read generated projection getters from the receiving storage instance instead of a ResultSeq. - Cover independent columns, instances and updated values without issuing database queries. + - Preserve arithmetic grouping and parameter order in casts and SQLite JSON array paths. + - Add opt-in CHECK-time RakuAST query compilation with symbolic fallback and private captures. + - Specialize query factories and preserve argument captures, writable returns and comparison coercions. + - Add opt-in fallback diagnostics through :warn, $*RED-COMPILER-WARN and RED_COMPILER_WARN. + - Cache SQL plans and scalar predicate shapes without sharing connections, cursors or results. + - Bound cache growth and retain parameters and comments through uncached and cyclic values. + - Use portable object identity for plan traversal and predicate cache keys. + - Add compiler, cache, binding-isolation tests and query construction benchmarks. - schema: add named CHECK and PostgreSQL EXCLUDE constraints with driver selection - indexes: support access methods, per-key operator classes and partial predicates - pg: add range constructors and native range/regex expression helpers diff --git a/META6.json b/META6.json index eb00e738..16b032a2 100644 --- a/META6.json +++ b/META6.json @@ -39,6 +39,7 @@ "Red::AST::AddForeignKeyOnTable": "lib/Red/AST/AddForeignKeyOnTable.rakumod", "Red::AST::BeginTransaction": "lib/Red/AST/BeginTransaction.rakumod", "Red::AST::Between": "lib/Red/AST/Between.rakumod", + "Red::AST::BoundFilter": "lib/Red/AST/BoundFilter.rakumod", "Red::AST::Case": "lib/Red/AST/Case.rakumod", "Red::AST::Chained": "lib/Red/AST/Chained.rakumod", "Red::AST::ChangeColumn": "lib/Red/AST/ChangeColumn.rakumod", @@ -102,6 +103,10 @@ "Red::Cli::Table": "lib/Red/Cli/Table.rakumod", "Red::Column": "lib/Red/Column.rakumod", "Red::ColumnMethods": "lib/Red/ColumnMethods.rakumod", + "Red::Compiler::Emitter": "lib/Red/Compiler/Emitter.rakumod", + "Red::Compiler::RakuAST": "lib/Red/Compiler/RakuAST.rakumod", + "Red::Compiler::Runtime": "lib/Red/Compiler/Runtime.rakumod", + "Red::Compiler::Template": "lib/Red/Compiler/Template.rakumod", "Red::Config": "lib/Red/Config.rakumod", "Red::DB": "lib/Red/DB.rakumod", "Red::Database": "lib/Red/Database.rakumod", @@ -134,6 +139,8 @@ "Red::Phaser": "lib/Red/Phaser.rakumod", "Red::PrepareCode": "lib/Red/PrepareCode.rakumod", "Red::Projection": "lib/Red/Projection.rakumod", + "Red::QueryPlan": "lib/Red/QueryPlan.rakumod", + "Red::QueryPlan::Cache": "lib/Red/QueryPlan/Cache.rakumod", "Red::ResultAssociative": "lib/Red/ResultAssociative.rakumod", "Red::ResultSeq": "lib/Red/ResultSeq.rakumod", "Red::ResultSeq::Iterator": "lib/Red/ResultSeq/Iterator.rakumod", diff --git a/docs/index.md b/docs/index.md index 0f18ce08..dda10c93 100644 --- a/docs/index.md +++ b/docs/index.md @@ -15,6 +15,7 @@ If you are looking for tutorials, you can visit: * [Special Variables](tutorials/vars.md) * [Red Cookbook](tutorials/cookbook.md) * [Experimental](tutorials/experimental.md) +* [Optional RakuAST query compiler](tutorials/rakuast.md) * [Examples](https://github.com/FCO/Red/tree/master/examples) #### API documentation diff --git a/docs/tutorials/rakuast.md b/docs/tutorials/rakuast.md new file mode 100644 index 00000000..1d609c22 --- /dev/null +++ b/docs/tutorials/rakuast.md @@ -0,0 +1,193 @@ +# Optional RakuAST query compiler + +The optional compiler translates supported query callbacks during `CHECK`. +Enable the RakuAST frontend and explicitly opt in for each compilation unit: + +```raku +use Red:api<2>; +use Red::Compiler::RakuAST; +CHECK red-compile; + +my $minimum = 10; +my $query = Product.^all + .map({ .price + 2 }) + .grep({ $_ > $minimum }) + .map({ "price: $_" }); +``` + +Run the program with `RAKUDO_RAKUAST=1 raku -Ilib program.raku`. +This integration is experimental and tested with Rakudo 2026.09. Loading Red +without opting in keeps the existing frontend and callback behavior. + +The compiler recognizes literal blocks, pointy blocks (including tuple +parameters), placeholder parameters, and single-Whatever expressions passed to `map`, `grep`, `first`, +and `sort`. Supported expressions include model columns, constant indexes and +Hash keys, dynamic JSON indexes and key existence, scalar and container projections, arithmetic, comparisons, string +concatenation and interpolation, complete conditionals, and `defined`, +`contains`, `elems`, `starts-with`, `ends-with`, `substr`, `index`, `lc`, `uc`, +and `cast`. Membership predicates accept literal word lists, captured arrays and +subqueries. Hash projections accept both fat arrows and colonpairs. Boolean operators are translated in predicates only. +Comparisons retain the resolved Red operator, including its numeric or textual +coercions and SQL casts. + +Templates bind against the current projection, so SQL aliases and SELECT +boundaries remain the responsibility of the existing query planner. Scalar +lexical captures are read when the query is constructed and retained if the +planner needs to bind the template against another SELECT layer. + +During CHECK the compiler specializes factories that construct `Red::AST` nodes +directly, along with the required validators. Runtime query construction invokes +these factories rather than interpreting the expression plan. Factories are +shared across calls; captured values and SQL subjects remain private to each +query. CHECK time is separate from runtime query construction and execution. + +Map templates also record column and JSON assignments, arithmetic compound +assignments (`+=`, `-=`, `*=`, `/=`, `%=` and `~=`), increments, decrements and +JSON deletion. These effects use the existing update pipeline and are persisted +with `.save`. Updates are buffered until the template evaluates successfully. +Simple untyped scalar locals and sequential statements can be compiled too. +Compound assignment to a projected scalar or a local variable changes the +expression used by later statements; it does not turn that projection into a +database update. Postfix increment/decrement retains its original return value. + +Expressions independent of the query element, including constructors and function +calls, can be bound as runtime captures. Their code runs during query construction, +never during CHECK. Ordinary native receivers still execute their original callback. + +An unsupported callback is left on the existing symbolic evaluation path, +including its existing fallback policy. Named callbacks, arbitrary functions of +the query element, loops, phasers, constrained signatures, custom operators and +conditional updates are not compiled. Unsupported syntax is rejected as a complete +callback before any updates are submitted. +Translation never executes the original callback during CHECK. + +Instrumented calls check their receiver at runtime. A `ResultSeq` receives an +internal template alongside the original callback. Other receivers receive the +original arguments, preserving native dispatch, adverbs, and writable results. +The compiler does not add SQL semantics to ordinary Arrays or Seqs. + +To warn whenever an executed Red callback falls back to symbolic evaluation: + +```raku +CHECK red-compile(:warn); +``` + +Warnings include the operation, callback location, source and fallback reason. +Unsupported syntax is diagnosed when that Red query is constructed, so native +Array/Seq calls and callbacks that never run do not warn. Runtime template +validation failures are reported too, once per query stage even if a SELECT +boundary requires rebinding. The fallback still uses the original callback. + +You can also enable warnings dynamically or through the environment: + +```raku +my $*RED-COMPILER-WARN = True; +CHECK red-compile; +``` + +```sh +RED_COMPILER_WARN=1 RAKUDO_RAKUAST=1 raku -Ilib program.raku +``` + +Precedence is the explicit `:warn`/`:!warn` parameter, then a defined Boolean +`$*RED-COMPILER-WARN`, then `RED_COMPILER_WARN`. An explicit `False` disables +warnings even when the environment enables them. Environment values `1`, `true`, +`yes` and `on` enable warnings, ignoring case and surrounding whitespace; other +values disable them. The default is silent. + +The parameter applies to instrumented calls in the current compilation unit; +dynamic and environment settings also cover uncompiled Red callbacks elsewhere. +If warnings are enabled only at runtime, an uninstrumented callback reports +`No RakuAST template was supplied` with its location, instead of the precise +CHECK-time rejection reason. Set the environment before compilation or use +`:warn` to retain those rejection details. SQL plan-cache misses/bypasses are not +compilation failures, and database errors retain their normal exception behavior. + +For compilation diagnostics, pass a reporting callback: + +```raku +CHECK red-compile(:report(-> :$method, :$source, :$status, :$reason { + note "$method: $status ($reason)"; +})); +``` + +Reports distinguish translated callbacks from unsupported syntax and include the +original callback source. A compiled template can still be inapplicable to a +particular runtime projection. To observe successful template evaluation, set +`$*RED-COMPILER-REPORT` to a callable; it receives `:status`, `:plan`, and +`:engine` for generated factories, or `:status` and `:reason`. +Manually constructed templates without a factory report `:engine`. +This is useful for tests that must distinguish compilation from symbolic fallback. + +To measure factory runtime separately from CHECK, database execution, and the +query planner, run `raku -Ilib tools/benchmark-compiler.raku`. The benchmark emits +JSON samples comparing interpreted and direct factories in the same process, +with warmup and alternating measurement order. Factory specialization happens +before timing. `--iterations=1000` and `--rounds=7` control the sample size. +These measurements isolate binding and AST construction; they do not represent +the speedup of an entire query. + +## Runtime query-plan cache + +A ResultSeq automatically reuses its SQL plan when its state can be fingerprinted +safely. Opaque mutable values bypass caching. The database +is still queried each time, using a fresh statement and cursor. Changes to the +query, driver, pagination or SQL metadata select a different plan. Diagnostic +comments are attached for the current execution. `.cache` continues to materialize +query results; it is separate from this plan cache. + +The optional compiler also shares predicate trees for direct comparisons between +a model field and one captured scalar (`Int`, `Str`, `Rat` or `Num`). Each query +reads its capture once during construction and retains that private snapshot: + +```raku +sub expensive($minimum) { + Product.^all.grep({ .price > $minimum }) +} +my $first = expensive(10); +my $second = expensive(20); +``` + +After warming up, these calls reuse the predicate factory output and SQL while +keeping their parameters independent. Other callbacks, mutable captures, NULL +captures and updates retain their existing factory/fallback behavior. Comparisons +requiring scalar coercion also use ordinary factories. Caches are bounded to 128 +entries, synchronized, and live only in the current process. +Prepared statements are not shared between connections or iterators. The SELECT +wrapper and current metadata are still inspected; reusing a predicate does not +eliminate every AST allocation. Warm-up has a cost, and for small predicates the +construction cost can remain similar. Plan reuse still hydrates every row, so end-to-end +gains depend on how much of the workload is spent translating SQL. +Drivers based on CommonSQL enable plan caching; other drivers retain their +existing prepare path unless they opt in with `supports-query-plans`. + +`$*RED-COMPILER-REPORT` additionally receives `filter-hit`, `filter-miss`, +`plan-hit`, `plan-miss` and `plan-fallback` events. Plan fallback includes a reason. +For comparisons, `my $*RED-QUERY-PLAN-CACHE = False` disables both runtime caches. +Run `raku -Ilib tools/benchmark-query-plans.raku` to compare construction, +translation/planning (dry run), and execution with caching enabled and disabled. +The benchmark alternates variants and reports cold-plan and warmed measurements +in microseconds per operation as JSON. Module compilation and database setup are +excluded. A separate `prototype-samples` series compares first specialization +with the saved symbolic AST against the runtime factory, using empty predicate +caches in both variants. +For direct field/scalar comparisons, CHECK also constructs a `Red::AST` prototype +with symbolic field and parameter slots. That object is embedded in the template +and saved with the module in `.precomp`. Its first use resolves the model column, +alias and parameter type from the prototype; later calls reuse the resolved +predicate. Runtime captures, connections, query objects and SQL plans are never +saved in the module. Other expressions continue to use CHECK-generated factories; +this does not eliminate the runtime SELECT envelope or every AST allocation. + +## Measuring query construction and cache bookkeeping + +`raku -Ilib tools/benchmark-query-construction.raku` measures filters, arithmetic +projections and chained projections. It checks query results before timing construction, +warms the tasks, and alternates their order. Set `RAKUDO_RAKUAST=1` to include the +optional CHECK compiler. `--iterations` and `--rounds` control the sample size. + +`raku -Ilib tools/benchmark-query-cache.raku` isolates cache lookup costs with 1, 16 +and 128 entries. It measures both a warmed working set and continual eviction, checks +builder counts, and reports microseconds per lookup. `--iterations` and `--rounds` +control the sample size. These cache and field-access measurements isolate individual +operations; use the query-plan benchmark to evaluate their effect on SQL workloads. diff --git a/lib/Red/AST/BoundFilter.rakumod b/lib/Red/AST/BoundFilter.rakumod new file mode 100644 index 00000000..6cf5d948 --- /dev/null +++ b/lib/Red/AST/BoundFilter.rakumod @@ -0,0 +1,43 @@ +use Red::AST; +use Red::AST::Unary; +use Red::QueryPlan::Cache; + +unit module Red::AST::BoundFilter; + +#| An immutable parameter position in a shared predicate. +class Parameter does Red::AST { + has Int $.index is required; + has Mu:U $.type is required; + method returns { $!type } + method args { () } + method find-column-name { () } +} + +#| A model member resolved only after the query receiver and alias are known. +class Field does Red::AST { + has Str $.name is required; + method returns { Any } + method args { () } + method find-column-name { () } +} + +#| A bind descriptor retained by a SQL plan, never a captured value. +class Bind { + has Int $.group is required; + has Int $.index is required; +} + +class Binding {} + +#| A private set of captures attached to a shared predicate tree. +class Predicate does Red::AST { + has Binding $.binding-token .= new; + has Red::AST $.filter is required; + has List $.values is required; + has Red::QueryPlan::Cache $.cache is required; + multi method WHICH(::?CLASS:D:) { $!binding-token.WHICH } + method not { Red::AST::Not.new(self) } + method returns { Bool } + method args { $!filter } + method find-column-name { $!filter.find-column-name } +} diff --git a/lib/Red/Compiler/Emitter.rakumod b/lib/Red/Compiler/Emitter.rakumod new file mode 100644 index 00000000..e1c3ba6c --- /dev/null +++ b/lib/Red/Compiler/Emitter.rakumod @@ -0,0 +1,285 @@ +use Red::AST; +use Red::AST::Value; +use Red::AST::Infixes; +use Red::AST::Unary; +use Red::AST::IsDefined; +use Red::AST::Case; +use Red::AST::JsonItem; +use Red::AST::JsonOperation; +use Red::Projection; +use Red::Type::Json; +use Red::Compiler::Template; + +#| Specialize query factories at CHECK time, without runtime opcode dispatch. +unit class Red::Compiler::Emitter; + +method build(@plan --> Callable:D) { + given @plan[0] { + when 'literal' { + my $value = @plan[1]; + return -> $template, $subject { $value }; + } + when 'capture' { + my $index = @plan[1]; + return -> $template, $subject { $template.values[$index] }; + } + when 'subject' { + return -> $template, $subject { + my $locals = try %*RED-COMPILER-LOCALS; + $locals.DEFINITE && ($locals:exists) ?? $locals !! $subject + }; + } + when 'local' { + my $index = @plan[1]; + return -> $template, $subject { %*RED-COMPILER-LOCALS{$index} }; + } + when 'field' { + my &parent = self.build(@plan[1]); + my $name = @plan[2]; + return -> $template, $subject { + my $value = parent($template, $subject); + $template.unsupported("Unknown model member: $name") + unless $value ~~ ::('Red::Model') && !$value.DEFINITE + && ($value.^columns.first({ .name.substr(2) eq $name }).DEFINITE + || $value.^relationships.keys.first({ .name.substr(2) eq $name }).DEFINITE); + $value."$name"() + }; + } + when 'index' { + my &parent = self.build(@plan[1]); + my $key = @plan[2]; + return -> $template, $subject { + my $value = parent($template, $subject); + if $value ~~ Red::AST && $value.returns ~~ Json { + $value = $value but ::('Red::ColumnMethods') + unless $value ~~ ::('Red::ColumnMethods'); + $key ~~ Int ?? $value.AT-POS($key) !! $value.AT-KEY($key) + } elsif $value ~~ Associative { + $template.unsupported("Unknown projected key: $key") + unless $value{$key}:exists; + $value{$key} + } elsif $value ~~ Positional && $key ~~ Int && 0 <= $key < $value.elems { + $value[$key] + } else { + $template.unsupported('The projected element does not support this index') + } + }; + } + when 'sequence' { + my @builders = @plan.skip(1).map({ self.build($_) }); + return -> $template, $subject { + my $result; + $result = $_($template, $subject) for @builders; + $result + }; + } + when 'topic-assign' { + my &value = self.build(@plan[1]); + return -> $template, $subject { + %*RED-COMPILER-LOCALS = value($template, $subject) + }; + } + when 'let' { + my $index = @plan[1]; + my &value = self.build(@plan[2]); + return -> $template, $subject { + %*RED-COMPILER-LOCALS{$index} = value($template, $subject) + }; + } + when 'assign' { + my @target = @plan[1].list; + my &receiver = self.build(@target[1]); + my &value = self.build(@plan[2]); + if @target[0] eq 'field' { + my $name = @target[2]; + return -> $template, $subject { + my $result = value($template, $subject); + receiver($template, $subject)."$name"() = $result; + $result + }; + } + my &key = @target[0] eq 'index' + ?? self.build(['literal', @target[2]]) !! self.build(@target[2]); + return -> $template, $subject { + my $result = value($template, $subject); + my $receiver = receiver($template, $subject); + my $key = key($template, $subject); + if $key ~~ Int || ($key ~~ Red::AST && $key.returns ~~ Int) { + $receiver.AT-POS($key) = $result; + } else { + $receiver.AT-KEY($key) = $result; + } + $result + }; + } + when 'delete' { + my &receiver = self.build(@plan[1]); + my &key = self.build(@plan[2]); + return -> $template, $subject { + my $receiver = receiver($template, $subject); + my $key = key($template, $subject); + $receiver = $receiver but ::('Red::ColumnMethods') + unless $receiver ~~ ::('Red::ColumnMethods'); + $key ~~ Int || ($key ~~ Red::AST && $key.returns ~~ Int) + ?? $receiver.DELETE-POS($key) !! $receiver.DELETE-KEY($key) + }; + } + when 'lookup' | 'exists' { + my &receiver = self.build(@plan[1]); + my &key = self.build(@plan[2]); + my $exists = @plan[0] eq 'exists'; + return -> $template, $subject { + my $value = receiver($template, $subject); + $template.unsupported('Dynamic indexing and existence require a JSON expression') + unless $value ~~ Red::AST && $value.returns ~~ Json; + my $key = ast-value(key($template, $subject)); + $template.unsupported('A JSON index must be a string or integer expression') + unless $key.returns ~~ Str | Int; + my $item = Red::AST::JsonItem.new($value, $key); + $exists ?? Red::AST::JsonOperation.new(:operation, :value($item)) + !! ($item but ::('Red::ColumnMethods')) + }; + } + when 'array' | 'list' { + my @builders = @plan.skip(1).map({ self.build($_) }); + return @plan[0] eq 'array' + ?? -> $template, $subject { + @builders.map({ $_($template, $subject).item }).Array + } + !! -> $template, $subject { + @builders.map({ $_($template, $subject).item }).List + }; + } + when 'hash' { + my @keys = @plan.skip(1).map(*[0]); + my @builders = @plan.skip(1).map({ self.build(.[1]) }); + return -> $template, $subject { + @keys.kv.map(-> $i, $key { $key => @builders[$i]($template, $subject) }).Hash + }; + } + when 'string' { + my @builders = @plan.skip(1).map({ self.build($_) }); + return -> $template, $subject { + my @parts = @builders.map({ + my $part = ast-value($_($template, $subject)); + $part.returns ~~ Str ?? $part !! Red::AST::Cast.new($part, 'text') + }); + my $result = @parts.shift // ast-value(''); + $result = Red::AST::Concat.new($result, $_) for @parts; + $result + }; + } + when 'op' { + my $type = ::('Red::AST::' ~ @plan[1]); + my &left = self.build(@plan[2]); + my &right = self.build(@plan[3]); + my &comparison = @plan[5] ~~ Callable ?? @plan[5] !! Callable; + my $membership = @plan[1] eq any(); + return -> $template, $subject { + my $left = left($template, $subject); + my $right = right($template, $subject); + if &comparison.DEFINITE { + comparison($left, $right) + } else { + $left = ast-value($left); + if $membership { + $right = $right.ast(:sub-select) if $right ~~ ::('Red::ResultSeq'); + $right = $right.as-sub-select if $right ~~ ::('Red::AST::Select'); + } + $type.new($left, ast-value($right)) + } + }; + } + when 'so' { + my &value = self.build(@plan[1]); + return -> $template, $subject { + Red::AST::So.new(ast-value(value($template, $subject))) + }; + } + when 'not' { + my &value = self.build(@plan[1]); + return -> $template, $subject { + Red::AST::Not.new(ast-value(value($template, $subject))) + }; + } + when 'negate' { + my &value = self.build(@plan[1]); + return -> $template, $subject { + Red::AST::Mul.new(ast-value(-1), ast-value(value($template, $subject))) + }; + } + when 'call' { + my $name = @plan[1]; + my &receiver = self.build(@plan[2]); + my @builders = @plan.skip(3).map({ self.build($_) }); + return -> $template, $subject { + my $value = receiver($template, $subject); + my @args = @builders.map({ $_($template, $subject) }); + $value = $value but ::('Red::ColumnMethods') + if $value ~~ Red::AST && $value !~~ ::('Red::ColumnMethods'); + $value."$name"(|@args) + }; + } + when 'case' { + my &condition = self.build(@plan[1]); + my &yes = self.build(@plan[2]); + my &no = self.build(@plan[3]); + return -> $template, $subject { + my $condition = ast-value(condition($template, $subject)); + my $yes = Red::Projection.from-value(yes($template, $subject)); + my $no = Red::Projection.from-value(no($template, $subject)); + $template.unsupported('Conditional projections must have the same shape') + unless $yes.signature eq $no.signature; + my @no = $no.leaves; + my @leaves = $yes.leaves.kv.map(-> $i, $value { + my Red::AST %when{Red::AST}; + %when{$condition} = $value; + Red::AST::Case.new(:%when, :else(@no[$i])) + }); + $yes.construct(@leaves) + }; + } + default { + X::Red::Compiler::Unsupported.new(:reason('Unknown compiled query expression')).throw + } + } +} + +method validator(@plan --> Callable:D) { + return -> $template, $subject { Nil } if @plan[0] eq any(); + return self.build(@plan) if @plan[0] eq any(); + if @plan[0] eq any() { + my &receiver = self.build(@plan[1]); + my &key = self.validator(@plan[2]); + return -> $template, $subject { + my $value = receiver($template, $subject); + $template.unsupported('Dynamic indexing and existence require a JSON expression') + unless $value ~~ Red::AST && $value.returns ~~ Json; + key($template, $subject) + }; + } + my @children = @plan[0] eq 'hash' + ?? @plan.skip(1).map(*[1]) !! @plan.skip(1).grep(* ~~ Array); + my @validators = @children.map({ self.validator($_) }); + my &check = -> $template, $subject { + $_($template, $subject) for @validators; + }; + if @plan[0] eq 'topic-assign' { + return -> $template, $subject { + $template.unsupported('Only scalar projection parameters can be reassigned') + unless $subject ~~ Red::AST; + check($template, $subject) + }; + } + if @plan[0] eq 'assign' { + my &target = @plan[1][0] eq any() + ?? self.build(@plan[1]) !! -> $template, $subject { Any }; + return -> $template, $subject { + my $target = target($template, $subject); + $template.unsupported('A read-only column cannot be updated') + if $target ~~ ::('Red::Column') && !$target.attr.rw; + check($template, $subject) + }; + } + &check +} diff --git a/lib/Red/Compiler/RakuAST.rakumod b/lib/Red/Compiler/RakuAST.rakumod new file mode 100644 index 00000000..7c257c03 --- /dev/null +++ b/lib/Red/Compiler/RakuAST.rakumod @@ -0,0 +1,532 @@ +use nqp; +use Red::Compiler::Template; +use Red::Compiler::Emitter; +use Red::Compiler::Runtime; +use X::Red::Exceptions; + +#| Optional CHECK-time translation of query callbacks. No RakuAST types are +#| resolved while loading this module on the legacy frontend. +unit module Red::Compiler::RakuAST; + +sub node(Str $name, |args) { ::('RakuAST::' ~ $name).new(|args) } +sub literal($value) { ::('RakuAST::Literal').from-value($value) } +sub invocation(&code, @arguments) { + node('ApplyPostfix', :operand(literal(&code)), + :postfix(node('Call::Term', :args(node('ArgList', |@arguments))))) +} +sub runtime-target($receiver) { Red::Compiler::Runtime.new(:$receiver) } +sub attach-getters($template, *@getters) { $template.clone(:@getters) } +sub template(Bool $operators, @plan, Bool :$captures = False, Bool :$warn, + Str :$query-method = '', Str :$source = '') { + sub has-effects(@part) { + return True if @part[0] eq any(); + return False if @part[0] eq any(); + return so @part.skip(1).grep({ has-effects($_[1]) }) if @part[0] eq 'hash'; + so @part.skip(1).grep({ $_ ~~ Array && has-effects($_) }) + } + Red::Compiler::Template.new(:$operators, :@plan, :$warn, :$query-method, :$source, + :builder(Red::Compiler::Emitter.build(@plan)), + :validator(Red::Compiler::Emitter.validator(@plan)), + :prevalidate(so ($captures || has-effects(@plan)))) +} + +class Translation { + has %.parameters; + has @.captures; + has %!capture-index; + has Bool $.predicate = False; + has Bool $.updating = False; + has %!locals; + has Int $!next-local = 0; + + method unsupported(Str $reason = "Unsupported callback syntax") { + X::Red::Compiler::Unsupported.new(:$reason).throw + } + method parameter($parameter) { + self.unsupported if $parameter.type.DEFINITE || $parameter.optional + || $parameter.slurpy.DEFINITE || $parameter.default.DEFINITE + || $parameter.where.DEFINITE || $parameter.signature-constraint.DEFINITE + || $parameter.names.elems; + } + method operator($operator) { + self.unsupported('Metaoperators and mutations use symbolic evaluation') + unless $operator.^name eq any(); + self.unsupported('Unresolved operator') unless $operator.is-resolved; + my $code = $operator.resolution.compile-time-value; + my @candidates = $code.^can("candidates") ?? $code.candidates !! ($code,); + self.unsupported unless @candidates.map({ + .file.starts-with("SETTING::") + || .file.ends-with("/Red/Operators.rakumod (Red::Operators)") + }).all; + $code + } + method type($value, Str $name --> Bool:D) { $value.^name eq 'RakuAST::' ~ $name } + method children($value) { + my @children; + $value.visit-children(-> $child { @children.push: $child }); + @children + } + method statements($value) { + my @statements = $value.statements; + self.unsupported('Multiple statements use symbolic evaluation') + unless @statements.elems == 1; + @statements[0] + } + method block($value) { + my %outer-locals = %!locals; + LEAVE %!locals = %outer-locals; + my @statements = $value.body.statement-list.statements; + self.unsupported('Empty callback') unless @statements; + return self.expression(@statements[0]) if @statements.elems == 1; + ['sequence', |@statements.map({ self.expression($_) })] + } + method assignment(@target, @value) { + self.unsupported('Updates are only compiled for map') unless $!updating; + return ['let', @target[1], @value.Array] if @target[0] eq 'local'; + return ['topic-assign', @value.Array] if @target[0] eq 'subject'; + self.unsupported('Assignment target is not a column or JSON path') + unless @target[0] eq any(); + ['assign', @target.Array, @value.Array] + } + method capture($value, Str $key) { + return ['capture', %!capture-index{$key}] if %!capture-index{$key}:exists; + my $index = @!captures.elems; + %!capture-index{$key} = $index; + @!captures.push: $value; + ['capture', $index] + } + method interpolation($value) { + if self.type($value, 'Block') { + self.unsupported('Block phasers or parameters') + if $value.has-any-phasers || $value.has-placeholder-parameters; + return self.block($value); + } + self.expression($value) + } + method independent($value --> Bool:D) { + my $independent = True; + $value.visit(-> $part { + my $name = $part.^name; + $independent = False if $name eq any() + || $name.starts-with('RakuAST::VarDeclaration::'); + if $name eq 'RakuAST::Var::Lexical' { + my $variable = $part.name; + $independent = False if $variable eq '$_' + || (%!parameters{$variable}:exists) || (%!locals{$variable}:exists); + } + True + }); + $independent + } + method parameters($signature, @path = ['subject']) { + my @parameters = $signature.parameters; + self.unsupported unless @parameters.elems == 1 || @path[0] eq 'index'; + for @parameters.kv -> $i, $parameter { + self.parameter($parameter); + my @position = @path[0] eq 'index' ?? ['index', @path[1], $i] !! @path; + if $parameter.sub-signature.DEFINITE { + my @nested = $parameter.sub-signature.parameters; + for @nested.kv -> $j, $nested { + self.parameter($nested); + self.unsupported unless $nested.target.^can('name') + && !$nested.sub-signature.DEFINITE; + %!parameters{$nested.target.name} = ['index', @position.Array, $j]; + } + } else { + self.unsupported unless $parameter.target.^can('name'); + %!parameters{$parameter.target.name} = @position.Array; + } + } + } + method method-call($method, @receiver) { + self.unsupported('Special method dispatch') + if $method.dispatch.chars || !$method.name.is-identifier; + self.unsupported('Method adverbs') if $method.colonpairs.DEFINITE + && $method.colonpairs.elems; + my $name = $method.name.canonicalize; + my @args = $method.args.args; + my %arity = defined => [0], contains => [1], elems => [0], + starts-with => [1], ends-with => [1], substr => [1, 2], index => [1], + lc => [0], uc => [0], cast => [1]; + if %arity{$name}:exists { + self.unsupported('Unsupported method arguments') + unless @args.elems == any(%arity{$name}.list); + return ['call', $name, @receiver.Array, |@args.map({ self.expression($_) })]; + } + self.unsupported if @args.elems || @receiver[0] ne any(); + ['field', @receiver.Array, $name] + } + method postfix($postfix, @receiver) { + if self.type($postfix, 'Postfix') && $postfix.operator eq any(<++ -->) { + self.operator($postfix); + my @update = self.assignment(@receiver, ['op', + $postfix.operator eq '++' ?? 'Sum' !! 'Sub', @receiver.Array, ['literal', 1]]); + my $old-value = $!next-local++; + return ['sequence', ['let', $old-value, @receiver.Array], + @update.Array, ['local', $old-value]]; + } + return self.method-call($postfix, @receiver) if self.type($postfix, 'Call::Method'); + if $postfix.^name eq any(< + RakuAST::Postcircumfix::ArrayIndex RakuAST::Postcircumfix::HashIndex + RakuAST::Postcircumfix::LiteralHashIndex + >) { + my $assignee = $postfix.^can('assignee') ?? $postfix.assignee !! Any; + my @adverbs = $postfix.colonpairs.DEFINITE ?? $postfix.colonpairs.list !! (); + my $existence = False; + my $deletion = False; + my $negated = False; + if @adverbs { + self.unsupported('Unsupported index adverb (including deletion)') + unless @adverbs.elems == 1 && @adverbs[0].key eq any() + && @adverbs[0].^name eq any(< + RakuAST::ColonPair::True RakuAST::ColonPair::False>); + $deletion = @adverbs[0].key eq 'delete' + && @adverbs[0].^name eq 'RakuAST::ColonPair::True'; + self.unsupported('Deletion is only compiled for map') if $deletion && !$!updating; + $existence = @adverbs[0].key eq 'exists'; + $negated = $existence && @adverbs[0].^name eq 'RakuAST::ColonPair::False'; + } + my $index = $postfix.index; + $index = self.statements($index) if $index.^can('statements'); + my @key = self.expression($index); + if self.type($postfix, 'Postcircumfix::LiteralHashIndex') && @key[0] eq 'list' { + self.unsupported('Index slices use symbolic evaluation') unless @key.elems == 2; + @key = @key[1].list; + } + self.unsupported('Index slices use symbolic evaluation') + if @key[0] eq any(); + my @result = @key[0] eq 'literal' && @key[1] ~~ Str | Int && !$existence + ?? ['index', @receiver.Array, @key[1]] + !! [$existence ?? 'exists' !! 'lookup', @receiver.Array, @key.Array]; + return self.assignment(@result, self.expression($assignee)) if $assignee.DEFINITE; + return ['delete', @receiver.Array, @key.Array] if $deletion; + return $negated ?? ['not', @result.Array] !! @result.Array; + } + self.unsupported + } + method expression($value) { + my $name = $value.^name; + given $name { + when 'RakuAST::Statement::Expression' { + self.unsupported('Statement modifiers use symbolic evaluation') + if $value.condition-modifier.DEFINITE || $value.loop-modifier.DEFINITE; + return self.expression($value.expression); + } + when 'RakuAST::IntLiteral' | 'RakuAST::NumLiteral' | 'RakuAST::RatLiteral' + | 'RakuAST::StrLiteral' { + return ['literal', $value.compile-time-value]; + } + when 'RakuAST::VarDeclaration::Simple' { + self.unsupported('Only untyped scalar local initializers are compiled') + unless $value.scope eq 'my' && !$value.traits.elems + && $value.sigil eq '$' && !$value.twigil.chars + && !$value.type.DEFINITE + && $value.initializer.^name eq 'RakuAST::Initializer::Assign'; + my @initial = self.expression($value.initializer.expression); + my $variable = '$' ~ $value.desigilname.canonicalize; + self.unsupported('Local variable shadows a callback parameter') + if %!parameters{$variable}:exists; + my $id = $!next-local++; + %!locals{$variable} = $id; + return ['let', $id, @initial.Array]; + } + when 'RakuAST::VarDeclaration::Placeholder::Positional' { + my $variable = $value.lexical-name; + self.unsupported('Unbound placeholder') unless %!parameters{$variable}:exists; + return %!parameters{$variable}; + } + when 'RakuAST::Block' { + self.unsupported('Block values use symbolic evaluation'); + } + when 'RakuAST::StatementPrefix::Do' { + return self.interpolation($value.blorst); + } + when 'RakuAST::Var::Lexical' | 'RakuAST::Var::Dynamic' { + my $variable = $value.name; + return ['local', %!locals{$variable}] if %!locals{$variable}:exists; + return %!parameters{$variable} if %!parameters{$variable}:exists; + return ['subject'] if $variable eq '$_'; + self.unsupported unless $variable.substr(0, 1) eq any(<$ @ %>); + return self.capture($value, $variable); + } + when 'RakuAST::Term::Whatever' { return ['subject'] } + when 'RakuAST::WhateverCode::Argument' { + self.unsupported('HyperWhatever is not a scalar parameter') if $value.is-hyper; + return ['subject']; + } + when 'RakuAST::Term::TopicCall' { + return self.postfix(self.children($value)[0], ['subject']); + } + when 'RakuAST::ApplyPostfix' { + if self.independent($value) { + return self.capture($value, 'expression:' ~ $value.WHICH); + } + return self.postfix($value.postfix, self.expression($value.operand)); + } + when 'RakuAST::ApplyListInfix' { + self.unsupported('Unsupported list operator') unless $value.infix.operator eq ','; + self.operator($value.infix); + return ['list', |$value.operands.map({ self.expression($_) })]; + } + when 'RakuAST::ApplyInfix' { + if self.type($value.infix, 'MetaInfix::Assign') { + my $operator = $value.infix.infix; + self.operator($operator); + my %operations = '+' => 'Sum', '-' => 'Sub', '*' => 'Mul', + '/' => 'Div', '%' => 'Mod', '~' => 'Concat'; + self.unsupported('Unsupported compound assignment') + unless %operations{$operator.operator}:exists; + my @target = self.expression($value.left); + return self.assignment(@target, + ['op', %operations{$operator.operator}, @target.Array, + self.expression($value.right)]); + } + if self.type($value.infix, 'Infix') && $value.infix.operator eq '=' { + return self.assignment(self.expression($value.left), self.expression($value.right)); + } + my %operators = '+' => 'Sum', '-' => 'Sub', '*' => 'Mul', '/' => 'Div', + '%' => 'Mod', 'div' => 'IDiv', '%%' => 'Divisible', '~' => 'Concat', '==' => 'Eq', '!=' => 'Ne', + '<' => 'Lt', '<=' => 'Le', '>' => 'Gt', '>=' => 'Ge', + 'eq' => 'Eq', 'ne' => 'Ne', 'lt' => 'Lt', 'le' => 'Le', + 'gt' => 'Gt', 'ge' => 'Ge', + 'in' => 'In', '⊂' => 'In', '(<)' => 'In', + '⊃' => 'NotIn', '(>)' => 'NotIn'; + %operators<&&> = 'AND' if $!predicate; + %operators<||> = 'OR' if $!predicate; + my &implementation = self.operator($value.infix); + my $operator = $value.infix.operator; + self.unsupported unless %operators{$operator}:exists; + my @comparison = $operator eq any('==', '!=', '<', '<=', '>', '>=', + 'eq', 'ne', 'lt', 'le', 'gt', 'ge') + ?? [$operator, &implementation] !! []; + return ['op', %operators{$operator}, self.expression($value.left), + self.expression($value.right), |@comparison]; + } + when 'RakuAST::ApplyPrefix' { + self.operator($value.prefix); + my $operator = $value.prefix.operator; + if $operator eq any(<++ -->) { + my @target = self.expression($value.operand); + return self.assignment(@target, ['op', + $operator eq '++' ?? 'Sum' !! 'Sub', @target.Array, ['literal', 1]]); + } + self.unsupported('Unsupported prefix operator') + unless $operator eq any(<- +>) + || ($operator eq any() && $!predicate); + return self.expression($value.operand) if $operator eq '+'; + return ['so', self.expression($value.operand)] if $operator eq 'so'; + return [$operator eq '-' ?? 'negate' !! 'not', + self.expression($value.operand)]; + } + when 'RakuAST::QuotedString' { + my @segments = $value.segments; + if @segments.map(*.^name).all eq 'RakuAST::StrLiteral' { + my $text = @segments.map(*.compile-time-value).join; + if $value.processors.grep(* eq 'words') { + self.unsupported('Unsupported word quoting processor') + if $value.processors.grep({ $_ ne any() }); + return ['list', |$text.words.map({ + ['literal', $value.processors.grep(* eq 'val') ?? val($_) !! $_] + })]; + } + self.unsupported('Unsupported string processor') if $value.processors.elems; + return ['literal', $text]; + } + self.unsupported if $value.processors.elems; + return ['string', |@segments.map({ self.interpolation($_) })]; + } + when 'RakuAST::Circumfix::Parentheses' | 'RakuAST::Circumfix::ArrayComposer' { + my $content = self.children($value)[0]; + my @statements = $content.statements; + return [$name.ends-with('ArrayComposer') ?? 'array' !! 'list'] + unless @statements; + self.unsupported unless @statements.elems == 1; + my $expression = @statements[0].expression; + my @elements = self.type($expression, 'ApplyListInfix') + && $expression.infix.operator eq ',' ?? $expression.operands !! ($expression,); + return self.expression($expression) if @elements.elems == 1 + && $name.ends-with('Parentheses'); + return [$name.ends-with('ArrayComposer') ?? 'array' !! 'list', + |@elements.map({ self.expression($_) })]; + } + when 'RakuAST::Contextualizer::Hash' | 'RakuAST::Circumfix::HashComposer' { + my $expression; + if self.type($value, 'Circumfix::HashComposer') { + self.unsupported('Object Hash projections') if $value.object-hash; + return ['hash'] unless $value.expression.DEFINITE; + $expression = $value.expression; + } else { + my $content = self.children($value)[0]; + my @statements = $content.statements; + return ['hash'] unless @statements; + self.unsupported('Hash with multiple statements') unless @statements.elems == 1; + $expression = @statements[0].expression; + } + my @pairs = self.type($expression, 'ApplyListInfix') + && $expression.infix.operator eq ',' ?? $expression.operands !! ($expression,); + my @items = @pairs.map(-> $pair { + if self.type($pair, 'FatArrow') { + [$pair.key, self.expression($pair.value)] + } elsif $pair.^name eq any() { + [$pair.key, self.expression($pair.value)] + } elsif $pair.^name eq any() { + [$pair.key, ['literal', $pair.simple-compile-time-quote-value]] + } else { + self.unsupported('Unsupported Hash member'); + } + }); + return ['hash', |@items]; + } + when 'RakuAST::Ternary' { + return ['case', self.expression($value.condition), + self.expression($value.then), self.expression($value.else)]; + } + when 'RakuAST::Statement::If' { + self.unsupported unless $value.else.DEFINITE && !$value.elsifs.elems; + return ['case', self.expression($value.condition), + self.block($value.then), self.block($value.else)]; + } + when 'RakuAST::Term::Name' | 'RakuAST::Term::Enum' { + my $term = $value.name.canonicalize; + my %constants = True => True, False => False, Any => Any, Nil => Nil; + self.unsupported unless %constants{$term}:exists; + return ['literal', %constants{$term}]; + } + when 'RakuAST::Call::Name' | 'RakuAST::Call::Name::WithoutParentheses' + | 'RakuAST::Type::Simple' { + self.unsupported('Control-flow functions use symbolic evaluation') + if $value.^can('name') + && $value.name.canonicalize eq any(); + self.unsupported('A function call depends on the query element') + unless self.independent($value); + return self.capture($value, 'expression:' ~ $value.WHICH); + } + default { self.unsupported("Unsupported RakuAST node: $name") } + } + } + method translate($block) { + if self.type($block, 'PointyBlock') { + self.parameters($block.signature); + return self.block($block); + } + if self.type($block, 'Block') { + self.unsupported('Block phasers') if $block.has-any-phasers; + self.parameters($block.placeholder-signature) if $block.has-placeholder-parameters; + return self.block($block); + } + my $whatevers = 0; + sub count($part) { + $whatevers++ if $part.^name eq any(); + $part.visit-children(-> $child { count($child) }); + } + count($block); + self.unsupported unless $whatevers == 1 && !self.type($block, 'Term::Whatever'); + self.expression($block) + } +} + +#| Translate supported callbacks in the caller's current compilation unit. +sub red-compile($cu = $*CU, :&report, Bool :$warn) is export { + X::Red::Projection.new(:reason( + 'red-compile requires the RakuAST frontend (RAKUDO_RAKUAST=1)' + )).throw unless $cu.^name eq 'RakuAST::CompUnit'; + my $resolver = $cu.resolver.clone; + my @candidates; + sub discover($current, @scopes) { + my @nested = @scopes; + @nested.push: $current if $current ~~ ::('RakuAST::LexicalScope'); + $current.visit-children(-> $child { discover($child, @nested) }); + my $dotty = $current.^name eq 'RakuAST::ApplyDottyInfix' + && $current.infix.^name eq 'RakuAST::DottyInfix::Call'; + return unless $dotty || $current.^name eq 'RakuAST::ApplyPostfix'; + my $call = $dotty ?? $current.right !! $current.postfix; + return unless $call.^name eq 'RakuAST::Call::Method' && !$call.dispatch.chars + && $call.name.is-identifier + && $call.name.canonicalize eq any(); + my @args = $call.args.args; + return unless @args.elems && @args.skip(1).map({ + .^name eq any() + }).all; + return if @args.skip(1).grep({ .key eq 'red-ast' }).elems; + my $translation = Translation.new( + :predicate(so $call.name.canonicalize eq any()), + :updating($call.name.canonicalize eq 'map')); + my @plan; + my $unsupported = False; + my $reason = ''; + try { + @plan = $translation.translate(@args[0]); + sub check-effects(@part, Bool $conditional = False) { + return if @part[0] eq any(); + if @part[0] eq 'hash' { + check-effects($_[1], $conditional) for @part.skip(1); + return; + } + $translation.unsupported('Conditional updates require conditional effect merging') + if $conditional && @part[0] eq any(); + for @part.skip(1).grep(* ~~ Array) -> $child { + check-effects($child, $conditional || @part[0] eq 'case'); + } + } + check-effects(@plan); + CATCH { + when X::Red::Compiler::Unsupported { + $unsupported = True; + $reason = .reason; + } + } + } + my $method = $call.name.canonicalize; + my Bool $instrument = !$unsupported || $warn.DEFINITE || compiler-warnings-enabled(); + my $source = $instrument || &report.DEFINITE + ?? ((try @args[0].DEPARSE) // '') !! ''; + report(:$method, :$source, + :status($unsupported ?? 'unsupported' !! 'compiled'), :$reason) + if &report.DEFINITE; + if $instrument { + @candidates.push: [$current, @plan.Array, + ($unsupported ?? [] !! $translation.captures.Array), @nested.Array, + $unsupported, $reason, $source, $method]; + } + } + discover($cu, []); + for @candidates -> $candidate { + my $current = $candidate[0]; + my @plan = $candidate[1].list; + my @captures = $candidate[2].list; + my @scopes = $candidate[3].list; + $resolver.push-scope($_) for @scopes; + my $operators = so $resolver.resolve-lexical('&__RED_OPERATOR_LOADED__'); + my @getters = @captures.map(-> $capture { + my $getter = node('Block', :implicit-topic(False), :body(node('Blockoid', + node('StatementList', node('Statement::Expression', :expression($capture)))))); + $getter.IMPL-BEGIN($resolver, $cu.context); + $getter.IMPL-CHECK($resolver, $cu.context); + $getter + }); + $resolver.pop-scope for @scopes; + # Capture-free templates contain no closure state and can be shared across calls. + my $prototype = $candidate[4] + ?? Red::Compiler::Template.new(:$operators, :$warn, + :unsupported-reason($candidate[5]), :source($candidate[6]), + :query-method($candidate[7])) + !! template($operators, @plan.Array, :captures(so @getters), :$warn, + :source($candidate[6]), :query-method($candidate[7])); + my $factory = @getters + ?? invocation(&attach-getters, [literal($prototype), |@getters]) + !! literal($prototype); + if $current.^name eq 'RakuAST::ApplyDottyInfix' { + $current.right.args.push(node('ColonPair::Value', :key, :value($factory))); + nqp::bindattr(nqp::decont($current), nqp::decont(::('RakuAST::ApplyDottyInfix')), '$!left', + invocation(&runtime-target, [$current.left])); + } else { + $current.postfix.args.push(node('ColonPair::Value', :key, :value($factory))); + $current.set-operands(nqp::list(invocation(&runtime-target, [$current.operand]))); + } + } + Nil +} diff --git a/lib/Red/Compiler/Runtime.rakumod b/lib/Red/Compiler/Runtime.rakumod new file mode 100644 index 00000000..902689de --- /dev/null +++ b/lib/Red/Compiler/Runtime.rakumod @@ -0,0 +1,25 @@ +use Red::Compiler::Template; +use Red::HiddenFromSQLCommenting; + +#| Dispatches an instrumented call without passing Red metadata to other receivers. +unit class Red::Compiler::Runtime; + +has $.receiver; + +method dispatch(Str $method, Capture $arguments) is raw is hidden-from-sql-commenting { + my $allowed = try $*RED-DONT-FAIL-WITHOUT-OPERATORS; + if $!receiver ~~ ::('Red::ResultSeq') { + my $template = $arguments; + my $*RED-DONT-FAIL-WITHOUT-OPERATORS = so ($allowed || $template.operators); + $!receiver."$method"(|$arguments) + } else { + my %named = $arguments.hash; + %named:delete; + $!receiver."$method"(|$arguments.list, |%named) + } +} + +method map(|args) is raw is hidden-from-sql-commenting { self.dispatch('map', args) } +method grep(|args) is raw is hidden-from-sql-commenting { self.dispatch('grep', args) } +method first(|args) is raw is hidden-from-sql-commenting { self.dispatch('first', args) } +method sort(|args) is raw is hidden-from-sql-commenting { self.dispatch('sort', args) } diff --git a/lib/Red/Compiler/Template.rakumod b/lib/Red/Compiler/Template.rakumod new file mode 100644 index 00000000..a3ba4bb5 --- /dev/null +++ b/lib/Red/Compiler/Template.rakumod @@ -0,0 +1,360 @@ +use Red::AST; +use Red::DB; +use Red::AST::BoundFilter; +use Red::QueryPlan::Cache; +use Red::AST::Value; +use Red::AST::Infixes; +use Red::AST::Unary; +use Red::AST::IsDefined; +use Red::AST::Case; +use Red::AST::JsonItem; +use Red::AST::JsonOperation; +use Red::AST::Divisible; +use Red::Projection; +use Red::Type::Json; +use X::Red::Exceptions; + +unit class Red::Compiler::Template; + +sub compiler-warnings-enabled(Bool $explicit = Bool --> Bool:D) is export { + return $explicit if $explicit.DEFINITE; + my $dynamic = DYNAMIC::<$*RED-COMPILER-WARN>; + return $dynamic if $dynamic ~~ Bool:D; + my $environment = %*ENV; + return False unless $environment.DEFINITE && $environment.chars; + so $environment.trim.lc eq any(<1 true yes on>) +} + +sub emit-compiler-warning(&callback, $template, Str:D :$method!, Str:D :$reason! + --> Bool:D) is export { + my $explicit = $template.DEFINITE ?? $template.warn !! Bool; + return False unless compiler-warnings-enabled($explicit); + my $name = $template.DEFINITE && $template.query-method.chars + ?? $template.query-method !! $method; + my $source = $template.DEFINITE && $template.source.chars + ?? $template.source !! ((try &callback.raku) // ''); + my $file = (try &callback.file) // ''; + my $line = (try &callback.line) // 0; + warn "red-compile: $name at $file:$line uses symbolic evaluation: $reason\n$source"; + True +} + +#| A query expression compiled independently of SQL aliases and closure instances. + +has @.plan; +has @.getters; +has @.values; +has Bool $.bound = False; +has Bool $.operators = False; +has Bool $.prevalidate = True; +has Bool $.warn; +has Str $.query-method = ''; +has Str $.source = ''; +has Str $.unsupported-reason; +has &.builder; +has &.validator; +has Red::QueryPlan::Cache $.filter-cache .= new; +has Red::QueryPlan::Cache $.sql-cache .= new; +has Str $!filter-shape-key; +has Red::AST $.filter-prototype; + +submethod TWEAK() { + $!filter-shape-key = @!plan.raku; + # This object is constructed at CHECK by the RakuAST compiler and embedded + # in its template literal. Only symbolic slots enter the precompilation. + if @!plan.elems && @!plan[0] eq 'op' && @!plan[1] eq any() { + my ($left, $right) = @!plan[2, 3]; + sub slot($part) { + return Red::AST::BoundFilter::Field.new(:name($part[2])) + if $part[0] eq 'field' && $part[1][0] eq 'subject'; + return Red::AST::BoundFilter::Parameter.new(:index($part[1]), :type(Any)) + if $part[0] eq 'capture'; + Nil + } + my $a = slot($left); + my $b = slot($right); + $!filter-prototype = ::('Red::AST::' ~ @!plan[1]).new($a, $b) + if $a.DEFINITE && $b.DEFINITE; + } +} + +method unsupported(Str $reason) { + X::Red::Compiler::Unsupported.new(:$reason).throw +} + +method path(@plan, $subject) { + given @plan[0] { + when 'subject' { + my $locals = try %*RED-COMPILER-LOCALS; + $locals.DEFINITE && ($locals:exists) ?? $locals !! $subject + } + when 'field' { + my $value = self.path(@plan[1], $subject); + my $name = @plan[2]; + self.unsupported("Unknown model member: $name") + unless $value ~~ ::('Red::Model') && !$value.DEFINITE + && ($value.^columns.first({ .name.substr(2) eq $name }).DEFINITE + || $value.^relationships.keys.first({ .name.substr(2) eq $name }).DEFINITE); + $value."$name"() + } + when 'index' { + my $value = self.path(@plan[1], $subject); + my $key = @plan[2]; + if $value ~~ Red::AST && $value.returns ~~ Json { + $value ~~ ::('Red::ColumnMethods') + ?? ($key ~~ Int ?? $value.AT-POS($key) !! $value.AT-KEY($key)) + !! ($key ~~ Int ?? ($value but ::('Red::ColumnMethods')).AT-POS($key) + !! ($value but ::('Red::ColumnMethods')).AT-KEY($key)) + } elsif $value ~~ Associative { + self.unsupported("Unknown projected key: $key") unless $value{$key}:exists; + $value{$key} + } elsif $value ~~ Positional && $key ~~ Int && 0 <= $key < $value.elems { + $value[$key] + } else { + self.unsupported('The projected element does not support this index') + } + } + default { self.unsupported('A model path must start at the block parameter') } + } +} + +method validate(@plan, $subject) { + if @plan[0] eq 'topic-assign' { + self.unsupported('Only scalar projection parameters can be reassigned') + unless $subject ~~ Red::AST; + } + if @plan[0] eq 'assign' { + my $target = @plan[1][0] eq any() + ?? self.path(@plan[1], $subject) !! Any; + self.unsupported('A read-only column cannot be updated') + if $target ~~ ::('Red::Column') && !$target.attr.rw; + } + return if @plan[0] eq 'local'; + return if @plan[0] eq any(); + if @plan[0] eq 'hash' { + self.validate($_[1], $subject) for @plan.skip(1); + return; + } + return self.path(@plan, $subject) if @plan[0] eq any(); + if @plan[0] eq any() { + my $value = self.path(@plan[1], $subject); + self.unsupported('Dynamic indexing and existence require a JSON expression') + unless $value ~~ Red::AST && $value.returns ~~ Json; + return self.validate(@plan[2], $subject); + } + for @plan.skip(1) -> $part { + self.validate($part, $subject) if $part ~~ Array; + } +} + +#| Bind captures once; rebinding SQL aliases does not read the captures again. +method bind($subject --> Red::Compiler::Template:D) { + self.unsupported($!unsupported-reason) if $!unsupported-reason.DEFINITE; + my $*RED-INTERNAL = True; + my %*RED-COMPILER-LOCALS; + # Pure capture-free plans validate paths during evaluation. Captures and + # mutations must still be checked before any getters or effects run. + if $!prevalidate { + &!validator.DEFINITE ?? &!validator(self, $subject) !! self.validate(@!plan, $subject); + } + return self unless @!getters; + my @values = @!getters.map(-> &getter { + my $value; + { + $value = getter(); + CONTROL { + default { self.unsupported('Control flow in a captured expression') } + } + } + $value.item + }); + self.clone(:bound, :@values) +} + +method evaluate(@plan, $subject) { + given @plan[0] { + when 'sequence' { + my $result; + $result = self.evaluate($_, $subject) for @plan.skip(1); + $result + } + when 'topic-assign' { + %*RED-COMPILER-LOCALS = self.evaluate(@plan[1], $subject) + } + when 'let' { + %*RED-COMPILER-LOCALS{@plan[1]} = self.evaluate(@plan[2], $subject) + } + when 'local' { %*RED-COMPILER-LOCALS{@plan[1]} } + when 'assign' { + my @target = @plan[1].list; + my $value = self.evaluate(@plan[2], $subject); + if @target[0] eq 'field' { + my $receiver = self.path(@target[1], $subject); + $receiver."{@target[2]}"() = $value; + } else { + my $receiver = self.path(@target[1], $subject); + my $key = @target[0] eq 'index' + ?? @target[2] !! self.evaluate(@target[2], $subject); + if $key ~~ Int || ($key ~~ Red::AST && $key.returns ~~ Int) { + $receiver.AT-POS($key) = $value; + } else { + $receiver.AT-KEY($key) = $value; + } + } + $value + } + when 'delete' { + my $receiver = self.path(@plan[1], $subject); + my $key = self.evaluate(@plan[2], $subject); + $receiver = $receiver but ::('Red::ColumnMethods') + unless $receiver ~~ ::('Red::ColumnMethods'); + $key ~~ Int || ($key ~~ Red::AST && $key.returns ~~ Int) + ?? $receiver.DELETE-POS($key) !! $receiver.DELETE-KEY($key) + } + when 'literal' { @plan[1] } + when 'capture' { @!values[@plan[1]] } + when 'subject' | 'field' | 'index' { self.path(@plan, $subject) } + when 'lookup' | 'exists' { + my $value = self.path(@plan[1], $subject); + self.unsupported('Dynamic indexing and existence require a JSON expression') + unless $value ~~ Red::AST && $value.returns ~~ Json; + my $key = ast-value(self.evaluate(@plan[2], $subject)); + self.unsupported('A JSON index must be a string or integer expression') + unless $key.returns ~~ Str | Int; + my $item = Red::AST::JsonItem.new($value, $key); + @plan[0] eq 'exists' + ?? Red::AST::JsonOperation.new(:operation, :value($item)) + !! ($item but ::('Red::ColumnMethods')) + } + when 'array' { @plan.skip(1).map({ self.evaluate($_, $subject).item }).Array } + when 'list' { @plan.skip(1).map({ self.evaluate($_, $subject).item }).List } + when 'hash' { + @plan.skip(1).map({ .[0] => self.evaluate(.[1], $subject) }).Hash + } + when 'string' { + my @parts = @plan.skip(1).map({ + my $part = ast-value(self.evaluate($_, $subject)); + $part.returns ~~ Str ?? $part !! Red::AST::Cast.new($part, 'text') + }); + my $result = @parts.shift // ast-value(''); + $result = Red::AST::Concat.new($result, $_) for @parts; + $result + } + when 'op' { + my $left = self.evaluate(@plan[2], $subject); + my $right = self.evaluate(@plan[3], $subject); + return @plan[5]($left, $right) if @plan[5] ~~ Callable; + $left = ast-value($left); + if @plan[1] eq any() { + $right = $right.ast(:sub-select) if $right ~~ ::('Red::ResultSeq'); + $right = $right.as-sub-select if $right ~~ ::('Red::AST::Select'); + } + $right = ast-value($right); + ::('Red::AST::' ~ @plan[1]).new($left, $right) + } + when 'so' { Red::AST::So.new(ast-value(self.evaluate(@plan[1], $subject))) } + when 'not' { Red::AST::Not.new(ast-value(self.evaluate(@plan[1], $subject))) } + when 'negate' { + Red::AST::Mul.new(ast-value(-1), ast-value(self.evaluate(@plan[1], $subject))) + } + when 'call' { + my $value = self.evaluate(@plan[2], $subject); + my @args = @plan.skip(3).map({ self.evaluate($_, $subject) }); + $value = $value but ::('Red::ColumnMethods') + if $value ~~ Red::AST && $value !~~ ::('Red::ColumnMethods'); + $value."{@plan[1]}"(|@args) + } + when 'case' { + my $condition = ast-value(self.evaluate(@plan[1], $subject)); + my $yes = Red::Projection.from-value(self.evaluate(@plan[2], $subject)); + my $no = Red::Projection.from-value(self.evaluate(@plan[3], $subject)); + self.unsupported('Conditional projections must have the same shape') + unless $yes.signature eq $no.signature; + my @yes = $yes.leaves; + my @no = $no.leaves; + my @leaves = @yes.kv.map(-> $i, $value { + my Red::AST %when{Red::AST}; + %when{$condition} = $value; + Red::AST::Case.new(:%when, :else(@no[$i])) + }); + $yes.construct(@leaves) + } + default { self.unsupported('Unknown compiled query expression') } + } +} + +# Only direct field/scalar comparisons are value-independent in this first version. +# All other expressions retain the existing factory and fallback behavior. +method cached-filter($subject, :$driver = try get-RED-DB) { + my $*RED-INTERNAL = True; + my $enabled = DYNAMIC::<$*RED-QUERY-PLAN-CACHE>; + return Nil if $enabled.WHAT === Bool && !$enabled; + return Nil unless $driver.DEFINITE && $driver.?supports-query-plans; + return Nil unless @!plan[0] eq 'op' + && @!plan[1] eq any() && $subject ~~ ::('Red::Model') + && !$subject.DEFINITE; + my ($field, $capture) = @!plan[2, 3]; + ($field, $capture) = ($capture, $field) if $field[0] eq 'capture'; + return Nil unless $field[0] eq 'field' && $field[1][0] eq 'subject' + && $capture[0] eq 'capture' && @!values.elems == 1; + my $value = @!values[$capture[1]]; + return Nil unless $value.DEFINITE && ($value.WHAT === Int + || $value.WHAT === Str || $value.WHAT === Rat || $value.WHAT === Num); + return Nil if $value ~~ Int && ($value < -(2 ** 63) || $value >= 2 ** 63); + return Nil if $value ~~ Numeric && ($value.Num.isNaN || $value.Num.abs == Inf); + my $column = $subject.^columns.first({ .name.substr(2) eq $field[2] }); + return Nil unless $column.DEFINITE && ($column.type === Int + || $column.type === Str || $column.type === Rat || $column.type === Num); + # Parameter slots cannot replace scalar coercions performed by the source operator. + my $source-op = @!plan[4] // ''; + return Nil if $source-op eq any('==', '!=', '<', '<=', '>', '>=') + && !($column.type ~~ Numeric && $value ~~ Numeric); + return Nil if $source-op eq any() + && !($column.type === Str && $value.WHAT === Str); + my $key = $subject.WHERE.Str ~ '|' ~ $value.WHAT.WHICH.Str + ~ '|' ~ $column.WHICH.Str ~ '|' ~ $column.args.raku ~ '|' ~ $!filter-shape-key; + my $entry = $!filter-cache.fetch($key, { + if $!filter-prototype.DEFINITE { + my $parameter = Red::AST::BoundFilter::Parameter.new( + :index($capture[1]), :type($value.WHAT)); + my $member = $subject."{$field[2]}"(); + my $left-is-field = $!filter-prototype.left + ~~ Red::AST::BoundFilter::Field; + my $left = $left-is-field ?? $member !! $parameter; + my $right = $left-is-field ?? $parameter !! $member; + @!plan[5] ~~ Callable ?? @!plan[5]($left, $right) + !! $!filter-prototype.clone(:$left, :$right) + } else { + my @values = Red::AST::BoundFilter::Parameter.new( + :index($capture[1]), :type($value.WHAT)); + self.clone(:@values).branches($subject).values.head + } + }); + my $report = DYNAMIC::<$*RED-COMPILER-REPORT>; + $report(:status('filter-' ~ $entry.key), + :prototype($!filter-prototype.DEFINITE)) if $report ~~ Callable; + Red::AST::BoundFilter::Predicate.new(:filter($entry.value), + :values(@!values.List), :cache($!sql-cache)) +} + +method branches($subject --> Hash:D) { + my $*RED-INTERNAL = True; + my $outer-updates = try @*UPDATE; + my @updates; + my $value; + { + my @*UPDATE := @updates; + my %*RED-COMPILER-LOCALS; + $value = &!builder.DEFINITE ?? &!builder(self, $subject) + !! self.evaluate(@!plan, $subject); + } + self.unsupported('Update effects require a map update context') + if @updates && !$outer-updates.DEFINITE; + $outer-updates.append: @updates if @updates; + my Red::AST %branches{Red::AST}; + %branches{Red::AST} = ast-value($value); + my $report = DYNAMIC::<$*RED-COMPILER-REPORT>; + $report(:status, :plan(@!plan), + :engine(&!builder.DEFINITE ?? 'direct' !! 'interpreted')) if $report ~~ Callable; + %branches +} diff --git a/lib/Red/Driver.rakumod b/lib/Red/Driver.rakumod index 424261fe..961af3ab 100644 --- a/lib/Red/Driver.rakumod +++ b/lib/Red/Driver.rakumod @@ -1,4 +1,5 @@ use Red::AST; +use Red::QueryPlan; use Red::Column; use Red::SchemaReader; use X::Red::Exceptions; @@ -115,6 +116,17 @@ multi method prepare(Red::AST $query) { } } +method supports-query-plans(--> Bool:D) { False } + +#| Compile independently of the lifetime of a connection or statement. +method compile-query(Red::AST:D $query, :@parameters = [] --> Red::QueryPlan:D) { + Red::QueryPlan.compile(self, $query, :@parameters) +} + +multi method prepare(Red::QueryPlan:D $plan, :@parameters = [], :@comments = []) { + $plan.prepare(self, :@parameters, :@comments) +} + #| Checks if a name is a valid table name multi method is-valid-table-name(Str --> Bool) { True } diff --git a/lib/Red/Driver/CommonSQL.rakumod b/lib/Red/Driver/CommonSQL.rakumod index 8cda4143..87b814af 100644 --- a/lib/Red/Driver/CommonSQL.rakumod +++ b/lib/Red/Driver/CommonSQL.rakumod @@ -19,6 +19,7 @@ use Red::AST::IsDefined; use Red::AST::CreateTable; use Red::AST::CreateIndex; use Red::AST::Native; +use Red::AST::BoundFilter; use Red::Index; use Red::AST::CreateView; use Red::AST::LastInsertedRow; @@ -54,6 +55,8 @@ use MetamodelX::Red::VirtualView; use UUID; unit role Red::Driver::CommonSQL does Red::Driver; +method supports-query-plans(--> Bool:D) { True } + method reserved-words {< A ABORT ABS ABSOLUTE ACCESS ACTION ADA ADD ADMIN AFTER AGGREGATE ALIAS ALL ALLOCATE ALSO ALTER ALWAYS ANALYSE ANALYZE AND ANY ARE ARRAY AS ASC ASENSITIVE ASSERTION ASSIGNMENT ASYMMETRIC AT ATOMIC ATTRIBUTE ATTRIBUTES @@ -351,6 +354,26 @@ multi method translate(Red::AST::Exclude $_, $context?) { index-error("EXCLUDE is unsupported on {self.driver-name}") } +multi method translate(Red::AST::BoundFilter::Predicate $predicate, $context?) { + my @*RED-BOUND-VALUES = $predicate.values; + my $collect = try $*RED-COLLECT-PLAN-BINDS; + my $*RED-PLAN-GROUP = $collect.WHAT =:= Bool && $collect + ?? %*RED-PLAN-GROUPS{$predicate.binding-token.WHICH.Str} !! 0; + self.translate($predicate.filter, $context) +} + +method translate-query-parameter(Red::AST::BoundFilter::Parameter $parameter, $context?) { + my $collect = try $*RED-COLLECT-PLAN-BINDS; + my $value = $collect.WHAT =:= Bool && $collect + ?? Red::AST::BoundFilter::Bind.new(:group($*RED-PLAN-GROUP), :index($parameter.index)) + !! @*RED-BOUND-VALUES[$parameter.index]; + self.wildcard => [$value] +} + +multi method translate(Red::AST::BoundFilter::Parameter $parameter, $context?) { + self.translate-query-parameter($parameter, $context) +} + multi method translate(Red::AST::Native::Operator $_, $context?) { index-error("Native operator {.operator} requires PostgreSQL") } @@ -943,7 +966,9 @@ multi method translate(Red::AST::Cast $_, $context?) { .bind ?? self.translate(.value, "bind") !! qq|'{ .value }'| => [] } default { - self.translate: .value, .bind ?? "bind" !! $context + my $translated = self.translate: .value, .bind ?? "bind" !! $context; + (.value ~~ Red::AST::Infix ?? "({$translated.key})" !! $translated.key) + => $translated.value } } diff --git a/lib/Red/Driver/Pg.rakumod b/lib/Red/Driver/Pg.rakumod index 2dd42461..8034fa22 100644 --- a/lib/Red/Driver/Pg.rakumod +++ b/lib/Red/Driver/Pg.rakumod @@ -14,6 +14,7 @@ use Red::AST::JsonSetItem; use Red::LockType; use Red::Index; use Red::AST::Native; +use Red::AST::BoundFilter; use Red::AST::CreateIndex; use Red::AST::Constraints; need UUID; @@ -45,6 +46,14 @@ method validate-index-definition($definition) { && $definition.using ne any('', 'btree'); } +multi method translate(Red::AST::BoundFilter::Parameter $parameter, $context?) { + my $translated = self.translate-query-parameter($parameter, $context); + my $cast = $parameter.type ~~ Int ?? 'bigint' + !! $parameter.type ~~ Num ?? 'double precision' + !! $parameter.type ~~ Rat ?? 'numeric' !! ''; + ($cast ?? "{$translated.key}::$cast" !! $translated.key) => $translated.value +} + multi method translate(Red::AST::Native::Operator $_, $context?) { my $ddl = ($context // '') eq 'index'; my $left = self.translate(.left, diff --git a/lib/Red/Driver/SQLite.rakumod b/lib/Red/Driver/SQLite.rakumod index 1759d045..51f0fe48 100644 --- a/lib/Red/Driver/SQLite.rakumod +++ b/lib/Red/Driver/SQLite.rakumod @@ -212,7 +212,7 @@ method sqlite-json-path(Red::AST $path) { .key, .value }; if $item.returns ~~ Int { - @sql.push: "('[' || CASE WHEN $sql < 0 THEN '#' ELSE '' END || $sql || ']')"; + @sql.push: "('[' || CASE WHEN ($sql) < 0 THEN '#' ELSE '' END || ($sql) || ']')"; @bind.append: |@values, |@values; } else { @sql.push: "('.' || JSON_QUOTE($sql))"; diff --git a/lib/Red/QueryPlan.rakumod b/lib/Red/QueryPlan.rakumod new file mode 100644 index 00000000..12e21029 --- /dev/null +++ b/lib/Red/QueryPlan.rakumod @@ -0,0 +1,168 @@ +use Red::AST; +use Red::AST::BoundFilter; + +#| SQL and parameter positions only. Connections, cursors and captures stay private. +unit class Red::QueryPlan; + +has List $.statements is required; + +# Fingerprint actual state, including mutable AST attributes. Unknown values bypass +# caching rather than trusting object identity for mutable user data. +method describe(Red::AST:D $ast --> Hash:D) { + # Resolve optional dependencies once per traversal, not for every AST node. + my $model-type = ::('Red::Model'); + my $column-type = ::('Red::Column'); + my $value-type = ::('Red::AST::Value'); + my Bool $safe = True; + my %active; + my @parameters; + my @comments; + my @reasons; + my $shared-cache; + sub frame(Mu $part --> Str) { + return 's' ~ $part.chars ~ ':' ~ $part if $part.DEFINITE && $part.WHAT === Str; + my $source = $part.raku; + 'r' ~ $source.chars ~ ':' ~ $source + } + sub walk(Mu $value --> Str) { + # After a cache veto, keep finding bindings and comments but stop encoding keys. + unless $value.DEFINITE { + return '' unless $safe; + return 'model:' ~ $value.WHICH.Str ~ ':' ~ $value.^table ~ ':' ~ $value.^as + if $value ~~ $model-type && $value.HOW.^can('table'); + return 'U:' ~ $value.WHICH.Str; + } + my $type = $value.WHAT; + return $safe ?? 'Str:' ~ $value.chars ~ ':' ~ $value !! '' if $type === Str; + return $safe ?? $type.^name ~ ':' ~ $value.raku !! '' + if $type === Int || $type === Rat + || $type === Num || $type === Bool || $value ~~ Enumeration; + if $value ~~ Callable || $value ~~ Attribute { + return $safe ?? $value.WHICH.Str !! ''; + } + if $value ~~ Red::AST::BoundFilter::Predicate { + @parameters.push: $value; + $shared-cache //= $value.cache; + return 'bound:' ~ walk($value.filter); + } + if $value ~~ Red::AST { + if $value ~~ $column-type { + unless $value.class.HOW.^can('table') { + $safe = False; + return ''; + } + unless $safe { + walk($value.computation); + return ''; + } + my @parts = + $value.class.WHICH.Str, $value.class.^table, $value.class.^as, + $value.name, $value.attr-name, $value.name-alias, + $value.attr.type.WHICH.Str, walk($value.type), walk($value.computation); + return $safe ?? 'column:' ~ @parts.map(&frame).join !! ''; + } + if $value ~~ $value-type && $value.column.DEFINITE { + $safe = False; # A custom deflator can depend on mutable external state. + } + my $id = $value.WHERE; + if %active{$id}:exists { + $safe = False; + return ''; + } + %active{$id} = True; + my @parts = $value.^attributes.map(-> $attr { + my $part = $attr.get_value($value); + if $attr.name eq '@!comments' { + @comments.append: $part.list; + next; + } + my $description = walk($part); + next unless $safe; + $attr.name ~ '=' ~ $description + }); + %active{$id}:delete; + return $safe ?? $value.^name ~ '(' ~ @parts.join('|') ~ ')' !! ''; + } + if $value ~~ Positional { + return '[]' unless $value.elems; + my $id = $value.WHERE; + if %active{$id}:exists { + $safe = False; + @reasons.push: 'cyclic positional value'; + return ''; + } + %active{$id} = True; + unless $safe { + walk($_) for $value.list; + %active{$id}:delete; + return ''; + } + my $description = '[' ~ $value.list.map({ walk($_) }).join('|') ~ ']'; + %active{$id}:delete; + return $description; + } + if $value ~~ Associative { + $safe = False; + my $id = $value.WHERE; + if %active{$id}:exists { + @reasons.push: 'cyclic associative value'; + return ''; + } + %active{$id} = True; + @reasons.push: $value.^name; + for $value.kv -> $key, $item { + walk($key); + walk($item); + } + %active{$id}:delete; + return ''; + } + $safe = False; + @reasons.push: $value.^name; + '' + } + my $key = walk($ast); + # Models are type objects above; include their current SELECT column metadata. + if $ast.^can('of') && $ast.of ~~ $model-type { + my $columns = $ast.of.^columns.map({ walk(.column) }).join('|'); + if $safe { + $key ~= '|columns:' ~ $columns; + $key ~= '|table:' ~ $ast.of.^table ~ '|alias:' ~ $ast.of.^as; + } + } + %(:key($safe ?? $key !! Str), :@parameters, :@comments, :$shared-cache, :@reasons) +} + +method compile($driver, Red::AST:D $ast, :@parameters = [] --> Red::QueryPlan:D) { + my %*RED-PLAN-GROUPS = @parameters.kv.map(-> $index, $predicate { + $predicate.binding-token.WHICH.Str => $index + }); + my Bool $*RED-COLLECT-PLAN-BINDS = True; + my Bool $*RED-COMMENT-SQL = False; + my &*RED-COMMENT-SQL; + my $optimized = $driver.optimize($ast); + my @statements = (|$driver.translate($optimized)).map({ + Pair.new(.key, .value.Array.List) + }); + self.new(:statements(@statements.List)) +} + +method prepare($driver, :@parameters = [], :@comments = [] --> List:D) { + my $comments = ($*RED-COMMENT-SQL || &*RED-COMMENT-SQL) + ?? @comments.map({ $driver.translate($_, 'comment').key }).join("\n") !! ''; + my @statements; + for $!statements.list -> $entry { + next unless $entry.key; + next if $*RED-DRY-RUN; + my @bind = $entry.value.map(-> $value { + my $actual = $value ~~ Red::AST::BoundFilter::Bind + ?? @parameters[$value.group].values[$value.index] !! $value; + $driver.deflate($actual) + }); + my $statement = $driver.prepare(($comments ?? "$comments\n" !! '') ~ $entry.key); + $statement.predefined-bind; + $statement.binds = @bind; + @statements.push: $statement; + } + @statements.List +} diff --git a/lib/Red/QueryPlan/Cache.rakumod b/lib/Red/QueryPlan/Cache.rakumod new file mode 100644 index 00000000..bea4a54e --- /dev/null +++ b/lib/Red/QueryPlan/Cache.rakumod @@ -0,0 +1,43 @@ +#| A bounded, synchronized cache. Clones may share it; keys describe the full plan. +unit class Red::QueryPlan::Cache; + +has UInt $.capacity = 128; +has Lock $!lock .= new; +has %!entries; +has Int %!recent; +has Int $!clock = 0; +has Str $!recent-key; + +method !touch(Str:D $key) { + return if $!recent-key.DEFINITE && $!recent-key eq $key; + %!recent{$key} = ++$!clock; + $!recent-key = $key; +} + +method fetch(Str:D $key, &build --> Pair:D) { + my $cached = $!lock.protect: { + if %!entries{$key}:exists { + self!touch($key); + 'hit' => %!entries{$key} + } else { + Nil + } + }; + return $cached if $cached.DEFINITE; + # Builders may call user diagnostics; never run those under the cache lock. + my $value = build(); + $!lock.protect: { + my $hit = %!entries{$key}:exists; + %!entries{$key} = $value unless $hit; + self!touch($key); + my $entry = ($hit ?? 'hit' !! 'miss') => %!entries{$key}; + # Hits update one timestamp; scan only when inserting beyond capacity. + while %!entries.elems > $!capacity { + my $oldest = %!recent.keys.min({ %!recent{$_} }); + %!recent{$oldest}:delete; + %!entries{$oldest}:delete; + $!recent-key = Str if $!recent-key eq $oldest; + } + $entry + } +} diff --git a/lib/Red/ResultSeq.rakumod b/lib/Red/ResultSeq.rakumod index 41fe98ac..3982500c 100644 --- a/lib/Red/ResultSeq.rakumod +++ b/lib/Red/ResultSeq.rakumod @@ -4,6 +4,7 @@ use Red::Utils; use Red::Model; use Red::Column; use Red::Driver; +use Red::QueryPlan::Cache; use Red::AST::Next; use Red::AST::Case; use Red::AST::Empty; @@ -23,6 +24,7 @@ use Red::ResultSeq::Iterator; use Red::HiddenFromSQLCommenting; use X::Red::Exceptions; use Red::PrepareCode; +use Red::Compiler::Template; use Red::Phaser; use Red::ResultSeqMethods; use Red::Formatter::ResultSeq; @@ -99,6 +101,7 @@ has Red::Driver $.with = do { has $.obj; has Red::AST::Chained $.chain handles .= new: |(:filter(.^id-filter) with $!obj); has Lock::Async $!lock .= new; +has Red::QueryPlan::Cache $!query-plan-cache .= new; has Red::LockType $.for; has @.prefetches; has Bool $.prefetches-set = False; @@ -115,7 +118,8 @@ multi method with(Str $with) { method iterator(--> Red::ResultSeq::Iterator) is hidden-from-sql-commenting { my $*RED-INTERNAL = True; - Red::ResultSeq::Iterator.new: :$.of, :$.ast, :&.post, |(:driver($_) with $!with) + Red::ResultSeq::Iterator.new: :$.of, :$.ast, :&.post, + :plan-cache($!query-plan-cache), |(:driver($_) with $!with) } #| Returns a Seq with the result of the SQL query @@ -434,8 +438,52 @@ method !create-projection(Red::Projection:D $projection, &filter) { )) but ProjectedModel[$model] } +#| Resolve a compiled callback against the current SQL stage, retaining legacy fallback. +method !query-block(&callback, $compiled is rw, $subject, Bool :$ordering = False, + Bool :$cache-filter = False, :$diagnostic, Str:D :$method!, Bool :$warned! is rw) { + my $reason = 'No RakuAST template was supplied'; + if $compiled.DEFINITE { + my $unsupported = False; + my Red::AST %branches{Red::AST}; + try { + $compiled = $compiled.bind($subject) unless $compiled.bound; + my $cached = $cache-filter ?? $compiled.cached-filter($subject, + :driver($!with.DEFINITE ?? $!with !! (try get-RED-DB))) !! Nil; + if $cached.DEFINITE { + %branches{Red::AST} = $cached; + } else { + %branches = $compiled.branches($subject); + } + CATCH { + when X::Red::Compiler::Unsupported { + $unsupported = True; + $reason = .reason; + my $report = DYNAMIC::<$*RED-COMPILER-REPORT>; + $report(:status, :reason(.reason)) if $report ~~ Callable; + } + } + } + return %branches unless $unsupported; + $compiled = Any; + } + self!compiler-warning(&callback, $diagnostic, $method, $reason, $warned); + if $ordering { + my Red::AST %branches{Red::AST}; + %branches{Red::AST} = ast-value(callback($subject)); + return %branches; + } + what-does-it-do(&callback, $subject).Hash +} + +method !compiler-warning(&callback, $diagnostic, Str:D $method, Str:D $reason, + Bool $warned is rw) { + return if $warned; + $warned = emit-compiler-warning(&callback, $diagnostic, :$method, :$reason); + Nil +} + #| Adds a new filter on the query (does not run the query) -method grep(&filter) is hidden-from-sql-commenting { +method grep(&filter, :$red-ast is copy) is hidden-from-sql-commenting { X::Red::NoOperatorsDefined.new(:meth).throw if !$*from-first && !::CALLERS::<&__RED_OPERATOR_LOADED__> && !::CALLERS::OUTERS::<&__RED_OPERATOR_LOADED__> && !$*RED-DONT-FAIL-WITHOUT-OPERATORS; my $*RED-INTERNAL = True; @@ -456,12 +504,18 @@ method grep(&filter) is hidden-from-sql-commenting { method print(|) { die "Trying to print inside the grep's block" } } my Red::AST $*RED-GREP-FILTER; + my $diagnostic = $red-ast; + my Bool $warned = False; my $input = self!projection-input(:fuse); - my Red::AST %branches{Red::AST} = what-does-it-do(&filter, $input!projection-subject).Hash; + my Red::AST %branches{Red::AST} = self!query-block( + &filter, $red-ast, $input!projection-subject, :cache-filter, + :$diagnostic, :method, :$warned); if self.chain.projection.DEFINITE && $input === self && !Red::Projection.safe-to-repeat(%branches) { $input = self!projection-input; - %branches = what-does-it-do(&filter, $input!projection-subject).Hash; + %branches = self!query-block( + &filter, $red-ast, $input!projection-subject, :cache-filter, + :$diagnostic, :method, :$warned); } my $filter = do given %branches { do if [eqv] .values { @@ -483,12 +537,12 @@ method grep(&filter) is hidden-from-sql-commenting { } #| Changes the query to return only the first row that matches the condition and run it (.grep(...).head) -multi method first(&filter) is hidden-from-sql-commenting { +multi method first(&filter, :$red-ast) is hidden-from-sql-commenting { X::Red::NoOperatorsDefined.new(:meth).throw if !::CALLERS::<&__RED_OPERATOR_LOADED__> && !::CALLERS::OUTERS::<&__RED_OPERATOR_LOADED__> && !$*RED-DONT-FAIL-WITHOUT-OPERATORS; self.create-comment-to-caller; my $*from-first = True; - self.grep(&filter).head + self.grep(&filter, :$red-ast).head } multi method first() is hidden-from-sql-commenting { @@ -522,7 +576,7 @@ multi method create-map(\SELF: *@ret where .all ~~ Red::AST, :&filter) is hidden } #| Change what will be returned (does not run the query) -method map(\SELF: &filter) is hidden-from-sql-commenting { +method map(\SELF: &filter, :$red-ast is copy) is hidden-from-sql-commenting { X::Red::NoOperatorsDefined.new(:meth).throw if !::CALLERS::<&__RED_OPERATOR_LOADED__> && !::CALLERS::OUTERS::<&__RED_OPERATOR_LOADED__> && !$*RED-DONT-FAIL-WITHOUT-OPERATORS; my $*RED-INTERNAL = True; @@ -547,14 +601,18 @@ method map(\SELF: &filter) is hidden-from-sql-commenting { my Red::AST %next{Red::AST}; my Red::AST %when{Red::AST}; my $input = SELF!projection-input(:fuse); + my $diagnostic = $red-ast; + my Bool $warned = False; my @updates = @!update; my @*UPDATE := @updates; - my Red::AST %branches{Red::AST} = what-does-it-do(&filter, $input!projection-subject).Hash; + my Red::AST %branches{Red::AST} = self!query-block( + &filter, $red-ast, $input!projection-subject, :$diagnostic, :method, :$warned); if $!chain.projection.DEFINITE && $input === SELF && !Red::Projection.safe-to-repeat(%branches) { $input = SELF!projection-input; @updates = @!update; - %branches = what-does-it-do(&filter, $input!projection-subject).Hash; + %branches = self!query-block( + &filter, $red-ast, $input!projection-subject, :$diagnostic, :method, :$warned); } for %branches -> Pair $_ { (.value ~~ (Red::AST::Next | Red::AST::Empty) ?? %next !! %when){.key} = .value @@ -595,15 +653,33 @@ multi method sort(--> Red::ResultSeq) is hidden-from-sql-commenting { } #| Defines the order of the query (does not run the query) -multi method sort(&order --> Red::ResultSeq) is hidden-from-sql-commenting { +multi method sort(&order, :$red-ast is copy --> Red::ResultSeq) is hidden-from-sql-commenting { my $*RED-INTERNAL = True; self.create-comment-to-caller; + my $diagnostic = $red-ast; + my Bool $warned = False; my $input = self!projection-input(:fuse); - my @order = order $input!projection-subject; + my @order = do if $red-ast.DEFINITE { + my $value = self!query-block(&order, $red-ast, $input!projection-subject, + :ordering, :$diagnostic, :method, :$warned).values.head; + $value ~~ Red::AST::Value ?? $value.value !! $value + } else { + self!compiler-warning(&order, $diagnostic, 'sort', + 'No RakuAST template was supplied', $warned); + order $input!projection-subject + }; if $!chain.projection.DEFINITE && $input === self && !Red::Projection.safe-to-repeat(@order) { $input = self!projection-input; - @order = order $input!projection-subject; + @order = do if $red-ast.DEFINITE { + my $value = self!query-block(&order, $red-ast, $input!projection-subject, + :ordering, :$diagnostic, :method, :$warned).values.head; + $value ~~ Red::AST::Value ?? $value.value !! $value + } else { + self!compiler-warning(&order, $diagnostic, 'sort', + 'No RakuAST template was supplied', $warned); + order $input!projection-subject + }; } $input.clone: :chain($input.chain.clone: :@order) } diff --git a/lib/Red/ResultSeq/Iterator.rakumod b/lib/Red/ResultSeq/Iterator.rakumod index 733e6d10..dc875f98 100644 --- a/lib/Red/ResultSeq/Iterator.rakumod +++ b/lib/Red/ResultSeq/Iterator.rakumod @@ -2,16 +2,41 @@ use Red::DB; use Red::AST; use Red::Driver; use Red::Utils; +use Red::QueryPlan; +use Red::QueryPlan::Cache; unit class Red::ResultSeq::Iterator does Iterator; has Mu:U $.of is required; has Red::AST $.ast is required; has &.post; has $!st-handler; has Red::Driver $.driver = get-RED-DB; +has Red::QueryPlan::Cache $.plan-cache .= new; submethod TWEAK(|) { - my $ast = $!driver.optimize: $!ast; - my @st-handler = $!driver.prepare: $ast; + my $ast = $!ast; + note $ast if $*RED-DEBUG-AST; + my $enabled = DYNAMIC::<$*RED-QUERY-PLAN-CACHE>; + my @st-handler; + if !$!driver.supports-query-plans { + @st-handler = $!driver.prepare($!driver.optimize($ast)); + } elsif $enabled.WHAT === Bool && !$enabled { + @st-handler = $!driver.prepare($ast); + } else { + my $description = Red::QueryPlan.describe($ast); + my $cache = $description // $!plan-cache; + my $key = $description; + my $entry = $key.DEFINITE + ?? $cache.fetch($!driver.WHICH.Str ~ '|' ~ $key, { + $!driver.compile-query($ast, :parameters($description)) + }) + !! ('fallback' => $!driver.compile-query($ast, + :parameters($description))); + my $report = DYNAMIC::<$*RED-COMPILER-REPORT>; + $report(:status('plan-' ~ $entry.key), :reason($description.join(', '))) + if $report ~~ Callable; + @st-handler = $!driver.prepare($entry.value, + :parameters($description), :comments($description)); + } @st-handler>>.execute unless $*RED-DRY-RUN; $!st-handler = @st-handler.tail; diff --git a/lib/X/Red/Exceptions.rakumod b/lib/X/Red/Exceptions.rakumod index eee987f5..aad79c37 100644 --- a/lib/X/Red/Exceptions.rakumod +++ b/lib/X/Red/Exceptions.rakumod @@ -3,6 +3,12 @@ use nqp; class X::Red is Exception {} +#| Internal signal for a template that cannot bind to the current projection. +class X::Red::Compiler::Unsupported is Exception { + has Str $.reason = "Unsupported compiled query"; + method message { $!reason } +} + class X::Red::Transaction is X::Red { has Str $.reason = 'Invalid transaction operation'; method message { $!reason } diff --git a/t/102-query-plans.rakutest b/t/102-query-plans.rakutest new file mode 100644 index 00000000..c1ceac67 --- /dev/null +++ b/t/102-query-plans.rakutest @@ -0,0 +1,413 @@ +use Test; +use nqp; +use Red; +use Red::Compiler::Template; +use Red::Compiler::Emitter; +use Red::Compiler::RakuAST; +use Red::QueryPlan; +use Red::QueryPlan::Cache; +use Red::AST::BoundFilter; +use Red::AST::Value; +use Red::AST::Case; + +CHECK red-compile if (%*ENV // '0') eq '1'; + +my @config = (%*ENV // 'SQLite').split(' '); +my $driver = @config.shift; +my $*RED-DB = database $driver, |%(@config.map({ + my ($key, $value) = .split('='); + $key => val($value) +})); +my $*RED-FALLBACK = False; +my %counts; +my @events; +my @sql; +my $*RED-COMPILER-REPORT = -> |event { @events.push: event.hash }; +$*RED-DB does role { + method compile-query(|args) { %counts++; callsame } + method optimize(|args) { %counts++; callsame } + method prepare(|args) { + if args.list.head ~~ Str { + %counts++; + @sql.push: args.list.head; + } + callsame + } +}; + +model QueryPlanRow { + has Int $.id is serial; + has Int $.number is rw is column; + has Str $.label is column; +} +my $schema = schema(QueryPlanRow); +$schema.drop.create; +LEAVE $schema.drop; +QueryPlanRow.^create(:number($_), :label("row$_")) for 1..4; +sub numbers($query) { $query.List.map(*.number).sort.Array } +sub reset() { %counts = (); @events = (); @sql = () } + +subtest 'Repeated execution reuses SQL, not results or cursors' => { + my $query = QueryPlanRow.^all.grep(*.number > 1); + reset; + is-deeply numbers($query), [2, 3, 4], 'First execution'; + is-deeply numbers($query), [2, 3, 4], 'Second execution'; + is %counts, 1, 'SQL is compiled once'; + is %counts, 1, 'AST is optimized once'; + is %counts, 2, 'Each execution gets its own statement'; + QueryPlanRow.^create(:number(5), :label); + is-deeply numbers($query), [2, 3, 4, 5], 'The next execution observes new data'; + QueryPlanRow.^all.grep(*.number == 5).delete; +}; + +subtest 'Clones and mutable pagination cannot reuse stale SQL' => { + my $query = QueryPlanRow.^all.sort(*.number); + reset; + is-deeply numbers($query), [1, 2, 3, 4], 'Base query'; + is-deeply numbers($query.head(2)), [1, 2], 'Limit changes the plan'; + is-deeply numbers($query.grep(*.number > 2)), [3, 4], 'Filter changes the plan'; + my $page = $query.skip(1); + is-deeply numbers($page), [2, 3, 4], 'Initial offset'; + $page.chain.offset = 2; + is-deeply numbers($page), [3, 4], 'Changing the public offset invalidates the key'; + is-deeply numbers($query), [1, 2, 3, 4], 'Earlier query remains unchanged'; +}; + +subtest 'Changing the driver cannot reuse a connection or cursor' => { + my $query = QueryPlanRow.^all.sort(*.number); + is-deeply numbers($query), [1, 2, 3, 4], 'Original connection'; + my $other = database $driver, |%(@config.map({ + my ($key, $value) = .split('='); + $key => val($value) + })); + my $sqlite = $driver eq 'SQLite'; + if $sqlite { + my $*RED-DB = $other; + QueryPlanRow.^create-table; + QueryPlanRow.^create(:number(99), :label); + } + my $changed = $query.with($other); + is-deeply numbers($changed), ($sqlite ?? [99] !! [1, 2, 3, 4]), + 'The explicit driver handles this execution'; + is-deeply numbers($query), [1, 2, 3, 4], 'Original query retains its driver behavior'; +}; + +subtest 'A bound custom driver retains its own prepare path' => { + my $mock = database 'Mock'; + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 1 }])); + my $query = QueryPlanRow.^all.with($mock).grep({ .number > 1 }, :red-ast($template)); + nok $query.filter ~~ Red::AST::BoundFilter::Predicate, + 'The explicitly bound driver decides whether parameterized predicates are supported'; +}; + +subtest 'Compiled filters share AST and SQL with private capture snapshots' => { + my $minimum = 1; + my $reads = 0; + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, + :getters([-> { $reads++; $minimum }]), + :builder(-> | { die 'The runtime AST factory ran' }), + :validator(Red::Compiler::Emitter.validator(@plan))); + sub query() { + QueryPlanRow.^all.grep(-> $row { die 'The original callback ran' }, + :red-ast($template)) + } + isa-ok $template.filter-prototype, Red::AST::Gt, 'Template retains a symbolic AST'; + isa-ok $template.filter-prototype.left, Red::AST::BoundFilter::Field; + isa-ok $template.filter-prototype.right, Red::AST::BoundFilter::Parameter; + reset; + my $first = query(); + $minimum = 2; + my $second = query(); + is $reads, 2, 'One capture read per query construction'; + isa-ok $first.filter, Red::AST::BoundFilter::Predicate; + is nqp::where($first.filter.filter), nqp::where($second.filter.filter), 'Predicate AST is shared'; + is-deeply numbers($second), [3, 4], 'Execute second query first'; + is-deeply numbers($first), [2, 3, 4], 'First query retains its captured value'; + is %counts, 1, 'SQL plan is shared between calls'; + is @events.grep(* eq 'filter-miss').elems, 1, 'Factory runs once'; + is @events.grep(* eq 'filter-hit').elems, 1, 'Second call reuses predicate'; + my $translated = $*RED-DB.translate($first.ast); + is-deeply $translated.value.Array, [1], 'Direct translation exposes real bind values'; + is-deeply numbers($first.grep(*.number < 4)), [2, 3], + 'Further composition retains the private bindings'; +}; + +subtest 'Symbolic prototypes preserve operand order' => { + my @plan = ['op', 'Lt', ['capture', 0], ['field', ['subject'], 'number']]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 2 }]), + :builder(-> | { die 'The runtime AST factory ran' })); + my $query = QueryPlanRow.^all.grep({ 2 < .number }, :red-ast($template)); + is-deeply numbers($query), [3, 4], 'Capture on the left retains comparison direction'; + isa-ok $template.filter-prototype.left, Red::AST::BoundFilter::Parameter; + isa-ok $template.filter-prototype.right, Red::AST::BoundFilter::Field; +}; + +subtest 'The CHECK compiler uses the cache automatically' => sub { + unless (%*ENV // '0') eq '1' { + plan :skip-all('Requires the RakuAST frontend'); + return; + } + sub query($minimum) { QueryPlanRow.^all.grep({ .number > $minimum }) } + reset; + my $first = query(1); + my $second = query(3); + is-deeply numbers($first), [2, 3, 4], 'First compiled query'; + is-deeply numbers($second), [4], 'Fresh parameters'; + is %counts, 1, 'Compiled callbacks share SQL automatically'; +}; + +subtest 'Compiled predicates compose without merging separate captures' => { + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 1 }])); + my $first = QueryPlanRow.^all.grep({ .number > 1 }, :red-ast($template)); + my $second-template = $template.clone(:getters([-> { 3 }])); + my $both = $first.grep({ .number > 3 }, :red-ast($second-template)); + is-deeply numbers($both), [4], 'Different bound predicates both survive AND'; + is-deeply numbers($first), [2, 3, 4], 'Composition leaves the first query independent'; +}; + +subtest 'Transaction lifetime is still checked on a cache hit' => { + my $escaped; + red-do :transaction, { + $escaped = QueryPlanRow.^all.grep(*.number > 2); + is-deeply numbers($escaped), [3, 4], 'First execution inside the transaction'; + is-deeply numbers($escaped), [3, 4], 'Cached execution inside the transaction'; + }; + throws-like { numbers($escaped) }, X::Red::Transaction, + 'A cached plan cannot revive a closed transaction'; +}; + +subtest 'Live iterators have independent statements' => { + my $query = QueryPlanRow.^all.sort(*.number); + my $first = $query.iterator; + my $second = $query.iterator; + is $first.pull-one.number, 1, 'First cursor starts at the first row'; + is $second.pull-one.number, 1, 'Second cursor starts independently'; + is $first.pull-one.number, 2, 'First cursor was not reset'; + loop { last if $first.pull-one =:= IterationEnd } + loop { last if $second.pull-one =:= IterationEnd } +}; + +subtest 'Comments are refreshed without recompiling SQL' => { + my $query = QueryPlanRow.^all.grep(*.number > 2); + my $*RED-COMMENT-SQL = True; + reset; + $query.comments.push: Red::AST::Comment.new(:msg); + numbers($query); + $query.comments.push: Red::AST::Comment.new(:msg); + numbers($query); + is %counts, 1, 'Adding diagnostic comments retains the SQL plan'; + ok @sql.tail.contains('second-marker'), 'The next statement receives the latest comment'; +}; + +subtest 'Scalar parameter types preserve comparison semantics' => { + for 5/2, 2.5e0, 2 ** 40 -> $value { + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $capture = $value; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { $capture }])); + my $query = QueryPlanRow.^all.grep({ .number > $capture }, :red-ast($template)); + is-deeply numbers($query), ($value < 4 ?? [3, 4] !! []), + "Numeric bind of type {$value.^name}"; + } + my $label = 'row2'; + my @plan = ['op', 'Eq', ['field', ['subject'], 'label'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { $label }])); + my $first = QueryPlanRow.^all.grep({ .label eq $label }, :red-ast($template)); + $label = 'row4'; + my $second = QueryPlanRow.^all.grep({ .label eq $label }, :red-ast($template)); + is-deeply numbers($first), [2], 'First string capture'; + is-deeply numbers($second), [4], 'Fresh string capture'; +}; + +subtest 'Unsupported captures use ordinary factories' => { + my $minimum = Int; + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { $minimum }])); + nok $template.bind(QueryPlanRow).cached-filter(QueryPlanRow).DEFINITE, + 'Undefined values are not substituted into a scalar parameter plan'; + $minimum = [1, 2]; + nok $template.bind(QueryPlanRow).cached-filter(QueryPlanRow).DEFINITE, + 'Mutable collections retain the existing behavior'; +}; + +subtest 'Dry run cannot poison a plan or execute statements' => { + my $query = QueryPlanRow.^all.grep(*.number > 2); + reset; + { + my $*RED-DRY-RUN = True; + $query.iterator; + } + is %counts // 0, 0, 'Dry run creates no statement'; + is-deeply numbers($query), [3, 4], 'The cached plan executes after dry run'; +}; + +subtest 'Imported modules retain compiled factories without sharing runtime captures' => sub { + unless (%*ENV // '0') eq '1' { + plan :skip-all('Requires the RakuAST frontend'); + return; + } + my $directory = $*TMPDIR.add("red-plan-precomp-{$*PID}-{1000000.rand.Int}"); + $directory.mkdir; + sub remove-tree(IO::Path:D $path) { + if $path.d && !$path.l { + remove-tree($_) for $path.dir; + $path.rmdir; + } else { + $path.unlink; + } + } + LEAVE remove-tree($directory) if $directory.DEFINITE && $directory.e; + $?FILE.IO.parent.add('lib/QueryPlanCompilerFixture.rakumod') + .copy($directory.add('QueryPlanCompilerFixture.rakumod')); + my $library = $?FILE.IO.parent.parent.add('lib').absolute; + my $program = q:to/PROGRAM/; + use Red; + use QueryPlanCompilerFixture; + say precomp-token(); + my $*RED-DB = database 'SQLite'; + my @events; + my $*RED-COMPILER-REPORT = -> |event { @events.push: event.hash }; + my $first = cached-query(1); + my $second = cached-query(2); + say $*RED-DB.translate($first.ast).value[0]; + say $*RED-DB.translate($second.ast).value[0]; + say @events.grep(* eq 'filter-miss').elems; + say @events.grep(* eq 'filter-hit').elems; + say @events.grep({ . eq 'filter-miss' && . }).elems; + PROGRAM + my $token; + for ^2 -> $invocation { + my $process = run $*EXECUTABLE, "-I$library", "-I$directory", '-e', $program, + :out, :err; + my $output = $process.out.slurp-rest; + my $errors = $process.err.slurp-rest; + is $process.exitcode + $process.signal, 0, "Module invocation $invocation succeeds"; + diag $errors if $process.exitcode || $process.signal; + my ($current-token, $results) = $output.split("\n", 2); + $token //= $current-token; + is $current-token, $token, 'Second process loads the same precompiled module'; + is $results, "1\n2\n1\n1\n1\n", 'Captures and runtime cache start fresh in each process'; + } +}; + +subtest 'Diagnostic opt-out bypasses both runtime caches' => { + my $*RED-QUERY-PLAN-CACHE = False; + my $value = 2; + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { $value }])); + nok $template.bind(QueryPlanRow).cached-filter(QueryPlanRow).DEFINITE, + 'Predicate factory caching is disabled'; + my $query = QueryPlanRow.^all.grep(*.number > 2); + reset; + is-deeply numbers($query), [3, 4], 'First uncached execution'; + is-deeply numbers($query), [3, 4], 'Second uncached execution'; + is %counts // 0, 0, 'The plan compiler is bypassed'; + is %counts, 2, 'Each execution uses the original preparation path'; +}; + +subtest 'Plan cache is bounded and does not cache failures' => { + my $cache = Red::QueryPlan::Cache.new(:capacity(2)); + $cache.fetch('a', { 1 }); + $cache.fetch('b', { 2 }); + is $cache.fetch('a', { 0 }).key, 'hit', 'Touch a cached key'; + $cache.fetch('c', { 3 }); + is $cache.fetch('b', { 4 }).key, 'miss', 'Least recently used key is evicted'; + dies-ok { $cache.fetch('error', { die 'builder failed' }) }, 'Builder failure propagates'; + is $cache.fetch('error', { 5 }).value, 5, 'Failed entries are not retained'; + my @jobs = (^8).map({ start { $cache.fetch('parallel', { 42 }).value } }); + is-deeply (await @jobs).Array, [42 xx 8], 'Concurrent lookups publish consistent values'; +}; + +subtest 'An empty cache returns builder values without retaining them' => { + my $cache = Red::QueryPlan::Cache.new(:capacity(0)); + my $builds = 0; + for ^3 { + my $entry = $cache.fetch('same-key', { ++$builds }); + is $entry.key, 'miss', 'Zero capacity always rebuilds'; + is $entry.value, $builds, 'Eviction does not discard the current result'; + } + throws-like { Red::QueryPlan::Cache.new(:capacity(-1)) }, X::TypeCheck, + 'Negative capacity is rejected'; +}; + +subtest 'Uncacheable plans retain later parameters and comments' => { + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 1 }])); + my $bound = QueryPlanRow.^all.grep({ .number > 1 }, :red-ast($template)); + my $column = QueryPlanRow.^columns.first(*.name eq '$!number').column; + my $extra = Red::AST::Eq.new($column, + Red::AST::Value.new(:value(3), :$column)); + my $query = QueryPlanRow.^all.where(Red::AST::AND.new($extra, $bound.filter)); + $query.comments.push: Red::AST::Comment.new(:msg); + my $description = Red::QueryPlan.describe($query.ast); + nok $description.DEFINITE, 'Column deflators bypass caching'; + is $description.elems, 1, 'Parameters after an uncacheable node are retained'; + my $*RED-COMMENT-SQL = True; + reset; + is-deeply numbers($query), [3], 'Fallback executes with bound parameters'; + is-deeply numbers($query), [3], 'A second execution also retains bindings'; + is %counts, 2, 'Uncacheable SQL is rebuilt each time'; + ok @sql.tail.contains('fallback-marker'), 'Fallback retains current comments'; +}; + +subtest 'Cyclic positional values bypass fingerprinting without losing later bindings' => { + my @items; + @items.push(@items); + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 1 }])); + my $query = QueryPlanRow.^all.grep({ .number > 1 }, :red-ast($template)); + my $ast = Red::AST::AND.new(ast-value(@items), $query.filter); + my $description = Red::QueryPlan.describe($ast); + nok $description.DEFINITE, 'A cyclic container is not cacheable'; + ok $description.grep(* eq 'cyclic positional value'), + 'The fallback reports the cycle'; + is $description.elems, 1, 'Later parameter groups are still collected'; + my @shared = 1, 2; + my $repeated = Red::AST::Eq.new(ast-value(@shared), ast-value(@shared)); + ok Red::QueryPlan.describe($repeated).DEFINITE, + 'Reusing an acyclic container is not mistaken for a cycle'; + @items.pop; +}; + +subtest 'Uncacheable case branches retain bound predicate parameters' => { + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { 1 }])); + my $predicate = QueryPlanRow.^all.grep({ .number > 1 }, :red-ast($template)).filter; + my Red::AST %when{Red::AST}; + %when{$predicate} = ast-value(1); + my $case = Red::AST::Case.new(:%when, :else(ast-value(0))); + my $description = Red::QueryPlan.describe($case); + nok $description.DEFINITE, 'Associative branches retain the uncached path'; + is $description.elems, 1, 'Predicate keys retain their binding groups'; + is-deeply QueryPlanRow.^all.map({ $case }).Array.sort.Array, [0, 1, 1, 1], + 'A projected case expression executes with private predicate bindings'; + my %cyclic; + %cyclic := %cyclic; + LEAVE %cyclic:delete; + my $cycle = Red::QueryPlan.describe(ast-value(%cyclic)); + nok $cycle.DEFINITE, 'A cyclic associative value is not cacheable'; + ok $cycle.grep(* eq 'cyclic associative value'), 'The cycle is reported'; +}; + +subtest 'Plan keys distinguish literal types and embedded delimiters' => { + my @values = '', '42', 42, 'a|b', 'a]b', 'a)b', 'Str:3:abc', + "a\nb", '"quoted"', "a\0b", 'ação'; + my @keys = @values.map({ Red::QueryPlan.describe(ast-value($_)) }); + is @keys.grep({ .DEFINITE }).elems, @values.elems, 'Ordinary scalar literals are cacheable'; + is @keys.unique.elems, @values.elems, 'Distinct literals have distinct keys'; + my @pairs = ['a', 'b|c'], ['a|b', 'c'], ['a)', 'b'], ['a', ')b']; + my @pair-keys = @pairs.map(-> @pair { + Red::QueryPlan.describe(Red::AST::Eq.new( + ast-value(@pair[0]), ast-value(@pair[1]))) + }); + is @pair-keys.unique.elems, @pairs.elems, 'Separators cannot merge adjacent values'; + my $column = QueryPlanRow.^columns.first.column; + my @columns = $column.clone(:name, :name-alias), + $column.clone(:name, :name-alias); + isnt Red::QueryPlan.describe(@columns[0]), + Red::QueryPlan.describe(@columns[1]), 'Column metadata boundaries remain distinct'; +}; + +done-testing; diff --git a/t/106-compiler-warnings.rakutest b/t/106-compiler-warnings.rakutest new file mode 100644 index 00000000..e052b883 --- /dev/null +++ b/t/106-compiler-warnings.rakutest @@ -0,0 +1,174 @@ +use Test; +use Red; +use Red::Compiler::RakuAST; +use Red::Compiler::Template; + +CHECK red-compile if (%*ENV // '0') eq '1'; + +temp %*ENV = ''; +my $*RED-DB = database 'SQLite'; +my $*RED-FALLBACK = False; + +model CompilerWarningRow { + has Int $.number is column; + method doubled { self.number * 2 } +} +CompilerWarningRow.^create-table; +CompilerWarningRow.^create(:number($_)) for 1..3; + +sub warnings(&task --> List:D) { + my @messages; + CONTROL { + when CX::Warn { + @messages.push: .message; + .resume; + } + } + task(); + @messages.List +} + +sub increment($value) { $value + 1 } +sub unsupported-query() { CompilerWarningRow.^all.map({ increment(.number) }) } + +subtest 'Warnings are opt-in and runtime dynamic values are observed' => { + is warnings({ unsupported-query() }).elems, 0, 'Default behavior stays silent'; + { + my $*RED-COMPILER-WARN = True; + my @messages = warnings({ unsupported-query() }); + is @messages.elems, 1, 'A runtime dynamic variable enables warnings'; + ok @messages[0].contains('red-compile: map'), 'The query operation is identified'; + ok @messages[0].contains('106-compiler-warnings.rakutest'), + 'The callback location is identified'; + is warnings({ unsupported-query(); unsupported-query() }).elems, 2, + 'Separate query constructions each warn'; + } + is warnings({ unsupported-query() }).elems, 0, 'Dynamic configuration is scoped'; +}; + +subtest 'Environment values and explicit false settings retain precedence' => { + for <1 true YES on> -> $value { + temp %*ENV = $value; + is warnings({ unsupported-query() }).elems, 1, "Enable with $value"; + } + for '', '0', 'false', 'OFF', 'no', 'invalid' -> $value { + temp %*ENV = $value; + is warnings({ unsupported-query() }).elems, 0, "Disable with '$value'"; + } + { + temp %*ENV = '1'; + my $*RED-COMPILER-WARN = False; + is warnings({ unsupported-query() }).elems, 0, + 'A dynamic False overrides the environment'; + } + { + my $*RED-COMPILER-WARN = True; + is warnings({ unsupported-query() }).elems, 1, + 'A dynamic True overrides a disabled environment'; + } +}; + +subtest 'Only query compilation fallback is warned' => { + my $*RED-COMPILER-WARN = True; + is warnings({ [1, 2].map({ increment($_) }).Array }).elems, 0, + 'Native receivers do not warn'; + my $template = Red::Compiler::Template.new( + :plan(['field', ['subject'], 'missing']), :query-method, :source('{ .missing }')); + my @messages = warnings({ + my $query = CompilerWarningRow.^all.map({ .number }, :red-ast($template)); + is-deeply $query.Array, [1, 2, 3], 'Symbolic fallback still returns the results'; + }); + is @messages.elems, 1, 'An inapplicable template warns once'; + ok @messages[0].contains('Unknown model member: missing'), 'The failure reason is included'; + ok @messages[0].contains('{ .missing }'), 'The template source is included'; + { + my $*RED-QUERY-PLAN-CACHE = False; + my $supported = Red::Compiler::Template.new(:plan(['field', ['subject'], 'number'])); + is warnings({ + CompilerWarningRow.^all.map({ .number }, :red-ast($supported)).Array; + }).elems, 0, 'Disabling the SQL plan cache is not a compilation failure'; + } + my &order = -> $row { $row.number }; + my @order-warnings = warnings({ CompilerWarningRow.^all.sort(&order) }); + is @order-warnings.elems, 1, 'An uncompiled sort also warns'; + ok @order-warnings[0].contains('red-compile: sort'), 'Sort is identified'; + my $projection; + { + my $*RED-COMPILER-WARN = False; + $projection = CompilerWarningRow.^all.map(*.number); + } + my $rebound; + is warnings({ $rebound = $projection.map({ 12 / increment($_) }) }).elems, 1, + 'A SELECT boundary does not duplicate a warning'; + cmp-ok $*RED-DB.translate($rebound.ast).key.comb(/:i SELECT/).elems, '>=', 2, + 'The query actually crosses a SELECT boundary'; + is-deeply $rebound.Array.map(*.Int).Array, [6, 4, 3], + 'Rebinding keeps the results'; + my $broken = Red::Compiler::Template.new(:plan(['capture', 0]), + :getters([-> { die 'capture failed' }])); + is warnings({ + throws-like { + CompilerWarningRow.^all.map({ .number }, :red-ast($broken)); + }, X::AdHoc, :message('capture failed'); + }).elems, 0, 'Capture errors remain exceptions rather than warnings'; +}; + +subtest 'The CHECK parameter overrides dynamic and environment configuration' => sub { + unless (%*ENV // '0') eq '1' { + plan :skip-all('Requires the RakuAST frontend'); + return; + } + my $library = $?FILE.IO.parent.parent.add('lib').absolute; + my $program = q:to/PROGRAM/; + use Red; + use Red::Compiler::RakuAST; + CHECK red-compile(WARNING_OPTION); + my $*RED-DB = database 'SQLite'; + my $*RED-FALLBACK = False; + model WarningParameterRow { + has Int $.number is column; + method doubled { self.number * 2 } + } + { + my $*RED-COMPILER-WARN = False; + WarningParameterRow.^create-table; + WarningParameterRow.^create(:number($_)) for 1..3; + } + my $*RED-COMPILER-WARN = DYNAMIC_SETTING; + sub increment($value) { $value + 1 } + sub dormant($value) { $value } + sub query() { WarningParameterRow.^all.map({ increment(.number) }) } + if False { WarningParameterRow.^all.map({ dormant(.number) }) } + say query().Array.join(','); + say query().Array.join(','); + say WarningParameterRow.^all.map({ .doubled }).Array.join(','); + say [1, 2].map({ increment($_) }).Array.join(','); + say WarningParameterRow.^all.map({ .number }).Array.join(','); + PROGRAM + for True, False -> $enabled { + my $source = $program.subst('WARNING_OPTION', $enabled ?? ':warn' !! ':!warn') + .subst('DYNAMIC_SETTING', $enabled ?? 'False' !! 'True'); + my %environment = %*ENV; + %environment = $enabled ?? '0' !! '1'; + my $process = run $*EXECUTABLE, "-I$library", '-e', $source, + :env(%environment), :out, :err; + my $output = $process.out.slurp-rest; + my $errors = $process.err.slurp-rest; + is $process.exitcode + $process.signal, 0, "Parameter $enabled succeeds"; + diag $errors if $process.exitcode || $process.signal; + is $output, "2,3,4\n2,3,4\n2,4,6\n2,3\n1,2,3\n", 'Results remain unchanged'; + my @messages = $errors.lines.grep(*.starts-with('red-compile:')); + is @messages.elems, ($enabled ?? 3 !! 0), 'The explicit parameter wins'; + if $enabled { + ok $errors.contains('A function call depends on the query element'), + 'Unsupported CHECK syntax retains its reason'; + ok $errors.contains('Unknown model member: doubled'), + 'Runtime fallback also warns'; + ok $errors.contains('increment(.number)'), 'Unsupported source is retained'; + nok $errors.contains('increment($_)'), 'Native unsupported syntax does not warn'; + nok $errors.contains('dormant'), 'Unexecuted queries do not warn'; + } + } +}; + +done-testing; diff --git a/t/87-json-operations.rakutest b/t/87-json-operations.rakutest index b686a5d5..8bfa19bd 100644 --- a/t/87-json-operations.rakutest +++ b/t/87-json-operations.rakutest @@ -85,6 +85,13 @@ subtest "Nested and dynamic paths", { is JsonDocument.^all.map({ .data[.item-index] }).head, 20, "Column-valued array index"; is JsonDocument.^all.map(*.data.AT-POS(-1)).head, 30, "Negative array index"; + is JsonDocument.^all.map({ .data[.item-index - 1] }).head, 10, + "Arithmetic array index retains grouping"; + is JsonDocument.^all.map({ .data[.item-index - 2] }).head, 30, + "Arithmetic array index can resolve to a negative index"; + my $offset = 2; + is JsonDocument.^all.map({ .data[.item-index - $offset] }).head, 30, + "Arithmetic array index retains captured parameter bindings"; JsonDocument.^all.map({ .data[.item-index] = 42 }).save; is JsonDocument.^all.map(*.data[1]).head, 42, "Dynamic array update"; JsonDocument.^all.map({ .data{.key} = 19 }).save; diff --git a/t/92-rakuast-compiler.rakutest b/t/92-rakuast-compiler.rakutest new file mode 100644 index 00000000..6a580bba --- /dev/null +++ b/t/92-rakuast-compiler.rakutest @@ -0,0 +1,316 @@ +use Test; +use Red; +use Red::Compiler::RakuAST; +use Red::Compiler::Template; +use Red::Type::Json; +use Red::AST; +use Red::AST::Value; +use Red::AST::Infixes; + +CHECK { + if (%*ENV // '0') eq '1' { + my @events; + red-compile(:report(-> |event { @events.push: event.hash })); + for '*.number', '-*', '* > 2', '{ True }', '{ %(:value(.number)) }', + '{ .payload:exists }', '{ .payload{$key}:!exists }', + '{ $^value + 2 }', '{ .number, .label }' -> $source { + my $normalized = $source.subst(/\s/, '', :g); + my @matches = @events.grep({ ..subst(/\s/, '', :g) eq $normalized }); + die "No compiled template for $source" + unless @matches && @matches.map(*).all eq 'compiled'; + } + for '{ .number += 10 }', '{ .payload = 42 }', + '{ .payload:delete }', '{ .number++ }', + '{ my $value = .number + 1; $value * 2 }' -> $source { + my $normalized = $source.subst(/\s/, '', :g); + my @matches = @events.grep({ ..subst(/\s/, '', :g) eq $normalized }); + die "A mutation was not compiled: $source" + unless @matches && @matches.map(*).all eq 'compiled'; + } + } +} + +unless (%*ENV // '0') eq '1' { + plan :skip-all('The optional compiler requires the RakuAST frontend'); + exit; +} + +my $*RED-FALLBACK = False; +my $*RED-COMPILER-REPORT = -> |event { + note event.hash.raku if %*ENV; +}; +my @config = (%*ENV // 'SQLite').split(' '); +my $driver = @config.shift; +my $*RED-DB = database $driver, |%(@config.map({ + my ($key, $value) = .split('='); + $key => val($value) +})); + +model CompiledRow { + has Int $.id is serial; + has Int $.number is rw is column; + has Str $.label is column; + has Json $.payload is column; +} + +model CompiledComparisonRow { + has Int $.number is column; + has Str $.digits is column; +} + +my $schema = schema(CompiledRow); +$schema.drop; +$schema.create; +LEAVE $schema.drop; +CompiledRow.^create(:number($_), :label("row$_"), + :payload(%(value => $_, items => [$_, $_ + 1]))) for 1..4; + +subtest 'Compiled projections and filters' => { + my $minimum = 2; + my $query = CompiledRow.^all.map({ .number + 1 }) + .grep({ $_ > $minimum }).map({ "value: $_" }); + is-deeply $query.Array, ['value: 3', 'value: 4', 'value: 5'], + 'Interpolation compiles without invoking AST.Str'; + is-deeply CompiledRow.^all.map({ "value: {.number + 1}!" }).Array, + ['value: 2!', 'value: 3!', 'value: 4!', 'value: 5!'], + 'Arithmetic interpolation retains grouping between string segments'; + my $sql = $*RED-DB.translate($query.ast).key; + is $sql.comb(/:i SELECT/).elems, 1, 'Safe stages fuse'; + my $captured = CompiledRow.^all.map({ .number }).grep({ $_ > $minimum }); + $minimum = 3; + is-deeply $captured.Array, [3, 4], 'Captures are bound when the query is built'; + is-deeply CompiledRow.^all.map({ .number }).grep({ $_ > $minimum }).Array, + [4], 'A new invocation reads current captures'; + is-deeply CompiledRow.^all.map(*.number).sort(-*).Array, [4, 3, 2, 1], + 'Whatever sorting compiles'; + is CompiledRow.^all.map(*.number).first(* > 2), 3, 'First uses the template'; +}; + +subtest 'Container and named parameter projections' => { + is-deeply CompiledRow.^all.map(-> $row { $row.number + 2 }).Array, + [3, 4, 5, 6], 'Pointy block parameters resolve'; + is-deeply CompiledRow.^all.map({ %(value => .number, label => .label) }) + .map({ . + 2 }).Array, [3, 4, 5, 6], 'Hash fields resolve'; + is-deeply CompiledRow.^all.map({ [.number, .label] }) + .map({ .[0] + 2 }).Array, [3, 4, 5, 6], 'Array indexes resolve'; + is-deeply CompiledRow.^all.map({ [.number, .label] }) + .map(-> ($number, $label) { $number + 2 }).Array, + [3, 4, 5, 6], 'Destructured parameters resolve'; + is-deeply CompiledRow.^all.grep({ .number > 1 && .number < 4 }) + .map(*.number).Array, [2, 3], 'Boolean predicates compile'; + is-deeply CompiledRow.^all.map({ .number > 2 ?? 'large' !! 'small' }).Array, + ['small', 'small', 'large', 'large'], 'Conditional projections compile'; + is-deeply CompiledRow.^all.map(*.number).map({ "$_" }).head(0).Array, [], + 'Empty pagination remains lazy'; + is-deeply CompiledRow.^all.map({ .number }).map({ "$_" }).Array, + ['1', '2', '3', '4'], 'A single interpolated value is a string'; + is-deeply CompiledRow.^all.map({ [.number, .label] }).map({ .elems }).Array, + [2, 2, 2, 2], 'Container element counts compile'; + is-deeply CompiledRow.^all.grep({ .payload == 2 }).map(*.number).Array, + [2], 'JSON paths in predicates compile'; + is-deeply CompiledRow.^all.map({ if .number > 2 { 'large' } else { 'small' } }).Array, + ['small', 'small', 'large', 'large'], 'Complete if statements compile'; + is-deeply CompiledRow.^all.map({ True }).Array, + [True, True, True, True], 'Boolean constants retain their type'; + is-deeply CompiledRow.^all.grep({ .label.contains('2') }) + .map(*.number).Array, [2], 'Known string operations compile'; + is-deeply CompiledRow.^all.grep({ so (.number > 0) }).map(*.number).Array, + [1, 2, 3, 4], 'Boolean coercion constructs a unary AST directly'; +}; + +subtest 'Compiled templates do not execute the original callback' => { + my $template = Red::Compiler::Template.new(:plan(['field', ['subject'], 'number'])); + my $query = CompiledRow.^all.map(-> $row { die 'Original callback executed' }, + :red-ast($template)); + is-deeply $query.Array, [1, 2, 3, 4], 'The original callback remains dormant'; + sub increment($value) { $value + 1 } + is-deeply CompiledRow.^all.map({ increment(.number) }).Array, [2, 3, 4, 5], + 'Unsupported calls retain existing symbolic evaluation'; + { + multi infix:<+>(Red::AST $left, Int $right) { + Red::AST::Sum.new($left, ast-value(100 + $right)) + } + is-deeply CompiledRow.^all.map({ .number + 1 }).Array, + [102, 103, 104, 105], 'Custom operators retain their implementation'; + } +}; + +subtest 'Native receivers retain native behavior' => { + is-deeply (1, 2, 3).map({ $_ + 1 }).Array, [2, 3, 4], 'Native map'; + my $minimum = 1; + is-deeply (1, 2, 3).grep({ $_ > $minimum }).Array, [2, 3], 'Native grep'; + is (1, 2, 3).first(* > 1), 2, 'Native first'; + is-deeply (1, 2, 3).sort(-*).Array, [3, 2, 1], 'Native sort'; + is-deeply (1, 2, 3).grep(* > 1, :k).Array, [1, 2], 'Native named adverbs'; + my @values = 1, 2, 3; + @values.first(* > 1) = 20; + is-deeply @values, [1, 20, 3], 'Native writable return values'; +}; + +subtest 'Capture binding and guarded dispatch' => { + my $reads = 0; + my $query = CompiledRow.^all.map(*.number).map(-> $value { die 'Called' }, + :red-ast(Red::Compiler::Template.new( + :plan(['op', 'Div', ['capture', 0], ['subject']]), + :getters([-> { $reads++; 12 }])))); + is $reads, 1, 'A SELECT boundary does not bind captures twice'; + is-deeply $query.Array, [12e0, 6e0, 4e0, 3e0], 'Bound captures survive a boundary'; + my $errors = 0; + my $broken = Red::Compiler::Template.new(:plan(['capture', 0]), + :getters([-> { $errors++; die 'Capture failed' }])); + throws-like { CompiledRow.^all.map(-> $row { die 'Callback retried' }, + :red-ast($broken)) }, X::AdHoc, :message('Capture failed'); + is $errors, 1, 'Capture errors propagate without retry'; + my $receivers = 0; + sub values() { $receivers++; [1, 2] } + is-deeply values().map({ $_ + 1 }).Array, [2, 3], 'Receiver expression works'; + is $receivers, 1, 'Receiver expression is evaluated once'; + class NativeReceiver { + method map(&callback, :$offset = 0, *%named) { + die 'Internal metadata leaked' if %named:exists; + callback(3) + $offset + } + } + is NativeReceiver.new.map({ $_ + 1 }, :offset(2)), 6, + 'Custom receiver keeps dispatch and named arguments'; +}; + +subtest 'Compiler selection and safe fallback regressions' => { + my $compiled = 0; + my $*RED-COMPILER-REPORT = -> |event { + $compiled++ if event.hash eq 'used'; + }; + is-deeply CompiledRow.^all.map(*.number).grep(* > 2).sort(-*).Array, + [4, 3], 'Whatever stages use their templates'; + is CompiledRow.^all.map(*.number).first(* > 2), 3, + 'Whatever first uses its template'; + is-deeply CompiledRow.^all.map({ %(:value(.number)) }).map({ . }).Array, + [1, 2, 3, 4], 'Hash colonpairs use their templates'; + is-deeply CompiledRow.^all.map({ True }).Array, [True, True, True, True], + 'Enum booleans use their templates'; + is-deeply CompiledRow.^all.grep({ .payload:exists }).map(*.number).Array, + [1, 2, 3, 4], 'Existence produces a predicate'; + my $key = 'missing'; + is-deeply CompiledRow.^all.grep({ .payload{$key}:!exists }).map(*.number).Array, + [1, 2, 3, 4], 'Negated existence and captured keys compile'; + is-deeply CompiledRow.^all.grep({ .payload[.number - 1]:exists }) + .map(*.number).Array, [1, 2], 'Column expressions work as JSON indexes'; + is-deeply CompiledRow.^all.map({ .number, .label }).map({ .[0] }).Array, + [1, 2, 3, 4], 'Unparenthesized list projections compile'; + is-deeply CompiledRow.^all.map(*.number).map({ $^value + 2 }).Array, + [3, 4, 5, 6], 'Placeholder parameters compile'; + is-deeply CompiledRow.^all.grep({ .label.starts-with('row') }).map(*.number).Array, + [1, 2, 3, 4], 'Known string methods compile'; + cmp-ok $compiled, '>=', 20, 'Compiled templates were actually evaluated'; +}; + +subtest 'Comparisons retain numeric and textual coercion semantics' => { + my $comparisons = 0; + my $*RED-COMPILER-REPORT = -> |event { + my %event = event.hash; + $comparisons++ if %event eq 'used' && %event[0] eq 'op' + && %event[4].DEFINITE; + }; + my $comparison-schema = schema(CompiledComparisonRow); + $comparison-schema.drop.create; + LEAVE $comparison-schema.drop; + CompiledComparisonRow.^create(:number(.key), :digits(.value)) + for 1 => '01', 2 => '2', 10 => '10'; + sub values($query) { $query.map(*.number).Array.sort.Array } + my $digits = '01'; + my $threshold = 2; + my &numeric-literal = -> $row { $row.digits == 1 }; + my &numeric-capture = -> $row { $row.digits == $digits }; + my &textual-order = -> $row { $row.number lt $threshold }; + my &textual-equality = -> $row { $row.number eq $digits }; + my &numeric-order = -> $row { $row.number > $threshold }; + for False, True -> $enabled { + my $*RED-QUERY-PLAN-CACHE = $enabled; + is-deeply values(CompiledComparisonRow.^all.grep({ .digits == 1 })), + values(CompiledComparisonRow.^all.grep(&numeric-literal)), + "Numeric comparison of a text column (cache=$enabled)"; + is-deeply values(CompiledComparisonRow.^all.grep({ .digits == $digits })), + values(CompiledComparisonRow.^all.grep(&numeric-capture)), + "Numeric coercion of a string capture (cache=$enabled)"; + is-deeply values(CompiledComparisonRow.^all.grep({ .number lt $threshold })), + values(CompiledComparisonRow.^all.grep(&textual-order)), + "Textual ordering of a numeric column (cache=$enabled)"; + is-deeply values(CompiledComparisonRow.^all.grep({ .number eq $digits })), + values(CompiledComparisonRow.^all.grep(&textual-equality)), + "Textual equality with a string capture (cache=$enabled)"; + is-deeply values(CompiledComparisonRow.^all.grep({ .number > $threshold })), + values(CompiledComparisonRow.^all.grep(&numeric-order)), + "Numeric predicate specialization retains casts (cache=$enabled)"; + } + cmp-ok $comparisons, '>=', 8, 'Coercing comparisons use compiled factories'; +}; + +subtest 'Compiled mutations retain the updating map path' => { + my $used = 0; + my $*RED-COMPILER-REPORT = -> |event { $used++ if event.hash eq 'used' }; + my $before = $used; + lives-ok { CompiledRow.^all.map({ .number += 10 }).save }, + 'Compound assignment does not break CHECK'; + is-deeply CompiledRow.^all.map(*.number).Array, [11, 12, 13, 14], + 'Compound assignment persists'; + cmp-ok $used - $before, '>=', 2, 'Compound assignment uses a template'; + lives-ok { CompiledRow.^all.map({ .payload = 42 }).save }, + 'Indexed assignment remains an update'; + is CompiledRow.^all.grep({ .payload == 42 }).elems, 4, + 'Indexed assignment persists'; + lives-ok { CompiledRow.^all.map({ .payload:delete }).save }, + 'Deletion remains an update'; + is CompiledRow.^all.grep({ .payload:exists }).elems, 0, + 'Deletion removes the JSON key'; + cmp-ok $used, '>=', 6, 'Updates, assignments, and deletion use templates'; + is-deeply CompiledRow.^all.map({ my $value = .number + 1; $value * 2 }).Array, + [24, 26, 28, 30], 'Local declarations and multiple statements compile'; + is-deeply CompiledRow.^all.grep(*.label in ).map(*.number).Array, + [11, 13], 'Quoted word lists compile as membership values'; + my @chosen = 11, 14; + is-deeply CompiledRow.^all.grep({ .number in @chosen }).map(*.number).Array, + [11, 14], 'Captured arrays compile in membership predicates'; + lives-ok { CompiledRow.^all.map({ .number++ }).save }, 'Postfix increments compile'; + is-deeply CompiledRow.^all.map(*.number).Array, [12, 13, 14, 15], + 'Postfix increment persists'; + lives-ok { CompiledRow.^all.map({ --.number }).save }, 'Prefix decrements compile'; + lives-ok { CompiledRow.^all.map({ .payload += 2 }).save }, + 'Compound JSON updates compile'; + is-deeply CompiledRow.^all.grep({ .payload >= 3 }).map(*.number).Array, + [11, 12, 13, 14], 'Compound JSON updates persist'; + is-deeply CompiledRow.^all.map({ "row: { .label }" }).Array, + ['row: row1', 'row: row2', 'row: row3', 'row: row4'], + 'Interpolation blocks compile without changing block-valued projections'; + my $retried = 0; + my $partial = Red::Compiler::Template.new(:plan([ + 'sequence', + ['assign', ['field', ['subject'], 'number'], ['literal', 1000]], + ['unsupported-test-expression'] + ])); + CompiledRow.^all.map(-> $row { $retried++; $row.number += 1 }, + :red-ast($partial)).save; + is $retried, 1, 'An unsupported runtime shape invokes the original callback once'; + is-deeply CompiledRow.^all.map(*.number).Array, [12, 13, 14, 15], + 'Abandoned template effects are discarded before fallback'; + my $constant = 0; + sub constant-value() { $constant++; 23 } + my $captured = CompiledRow.^all.map({ constant-value() }); + is $constant, 1, 'An independent function is captured when the query is built'; + is-deeply $captured.Array, [23, 23, 23, 23], 'Captured function values are reused'; + my $before-local = $used; + is-deeply CompiledRow.^all.map({ my $value = .number; $value + 1 }).Array, + [13, 14, 15, 16], 'Local expressions retain row values'; + cmp-ok $used, '>', $before-local, 'A block with local declarations uses a template'; + is-deeply CompiledRow.^all.map(*.number).map({ $_ += 10 }).Array, + [22, 23, 24, 25], 'Projected scalar parameters support compound assignment'; + is-deeply CompiledRow.^all.map({ my $value = .number; $value *= 2; $value }).Array, + [24, 26, 28, 30], 'Local compound assignment stays in the compiled expression'; + is-deeply CompiledRow.^all.map(*.number).map({ $_ += 1; $_ * 2 }).Array, + [26, 28, 30, 32], 'Later expressions read the reassigned parameter'; + is-deeply CompiledRow.^all.map(*.number).map({ $_++ }).Array, + [12, 13, 14, 15], 'A projected postfix increment returns the original value'; + is-deeply CompiledRow.^all.map({ my $value = .number; my $old = $value++; $old }).Array, + [12, 13, 14, 15], 'Local postfix increments retain the old value'; +}; + +done-testing; diff --git a/t/93-rakuast-scope.rakutest b/t/93-rakuast-scope.rakutest new file mode 100644 index 00000000..e1fd9360 --- /dev/null +++ b/t/93-rakuast-scope.rakutest @@ -0,0 +1,30 @@ +use Test; +use Red::Compiler::RakuAST; +use X::Red::Exceptions; + +CHECK { red-compile if (%*ENV // '0') eq '1' } + +unless (%*ENV // '0') eq '1' { + plan :skip-all('The optional compiler requires the RakuAST frontend'); + exit; +} + +my $*RED-FALLBACK = False; +my $*RED-DB; +my $rows; +{ + use Red; + $*RED-DB = database 'Pg'; + model ScopedCompilerRow { + has Int $.value is column; + } + $rows = ScopedCompilerRow.^all; + lives-ok { $rows.map(*.value) }, 'Compilation preserves imported operators'; +} + +throws-like { $rows.map(*.value) }, X::Red::NoOperatorsDefined, + 'Compilation does not grant operators outside their lexical scope'; +throws-like { $rows.grep(*.value > 1) }, X::Red::NoOperatorsDefined, + 'Compiled grep preserves the operator scope check'; + +done-testing; diff --git a/t/94-template-reuse.rakutest b/t/94-template-reuse.rakutest new file mode 100644 index 00000000..584b9dff --- /dev/null +++ b/t/94-template-reuse.rakutest @@ -0,0 +1,79 @@ +use Test; +use Red; +use Red::Compiler::RakuAST; +use Red::Compiler::Template; +use Red::AST::Value; + +CHECK { red-compile if (%*ENV // '0') eq '1' } + +my $*RED-FALLBACK = False; +my $*RED-DB = database 'Pg'; + +model TemplateReuseRow { + has Int $.value is column; +} + +subtest 'Capture-free bindings retain subject validation' => { + my $template = Red::Compiler::Template.new(:plan(['field', ['subject'], 'value'])); + ok $template.bind(TemplateReuseRow) === $template, + 'A capture-free binding reuses its template'; + throws-like { $template.bind(%(value => 1)) }, X::Red::Compiler::Unsupported, + 'A reused template still rejects an incompatible subject'; + lives-ok { $template.bind(TemplateReuseRow) }, + 'A failed binding does not poison later bindings'; + my $pure = Red::Compiler::Template.new(:plan(['field', ['subject'], 'value']), + :!prevalidate); + throws-like { $pure.bind(%(value => 1)).branches(%(value => 1)) }, + X::Red::Compiler::Unsupported, + 'Evaluation still rejects an incompatible subject without prevalidation'; + my $identity = Red::Compiler::Template.new(:plan(['subject']), :!prevalidate); + for 3, 7 -> $value { + my $subject = ast-value($value); + ok $identity.bind($subject).evaluate($identity.plan, $subject) === $subject, + 'Shared templates evaluate against the current subject'; + } +}; + +subtest 'Captures remain private to each binding' => { + my $value = 10; + my $reads = 0; + my $template = Red::Compiler::Template.new(:plan(['capture', 0]), + :getters([-> { $reads++; $value }])); + my $first = $template.bind(TemplateReuseRow); + $value = 20; + my $second = $template.bind(TemplateReuseRow); + is $first.evaluate($first.plan, TemplateReuseRow), 10, 'First binding keeps its value'; + is $second.evaluate($second.plan, TemplateReuseRow), 20, 'Next binding reads a fresh value'; + is $reads, 2, 'Each binding reads the capture once'; + nok $template.bound, 'The shared source template is never bound'; +}; + +subtest 'Repeated compiled calls keep their current subject' => { + sub project($rows) { $rows.map(*.value) } + my $used = 0; + my $direct = 0; + my $*RED-COMPILER-REPORT = -> |event { + $used++ if event.hash eq 'used'; + $direct++ if event.hash eq 'used' && event.hash eq 'direct'; + }; + my $first = project(TemplateReuseRow.^all); + my $second = project(TemplateReuseRow.^all); + is $*RED-DB.translate($first.ast).key, $*RED-DB.translate($second.ast).key, + 'Repeated query construction generates the same SQL'; + class NativeValue { method value { 3 } } + is-deeply project([NativeValue.new]).Array, [3], 'Native receivers keep their callback'; + is $used, 2, 'Both ResultSeq calls use the compiled template' + if (%*ENV // '0') eq '1'; + is $direct, 2, 'Instrumented calls construct Red::AST directly' + if (%*ENV // '0') eq '1'; + sub increment($rows) { $rows.map(* + 1) } + my $plain = increment(TemplateReuseRow.^all.map(*.value)); + my $shifted = increment(TemplateReuseRow.^all.map(*.value + 10)); + my $plain-sql = $*RED-DB.translate($plain.ast).key; + my $shifted-sql = $*RED-DB.translate($shifted.ast).key; + isnt $plain-sql, $shifted-sql, 'Shared templates bind to different projected expressions'; + is $*RED-DB.translate($plain.ast).key, $plain-sql, + 'A subsequent binding does not mutate an earlier query'; +}; + +done-testing; diff --git a/t/95-direct-ast-factories.rakutest b/t/95-direct-ast-factories.rakutest new file mode 100644 index 00000000..6e36cb75 --- /dev/null +++ b/t/95-direct-ast-factories.rakutest @@ -0,0 +1,110 @@ +use Test; +use Red; +use Red::Compiler::Emitter; +use Red::Compiler::Template; +use Red::AST::Value; +use Red::Type::Json; + +my $*RED-FALLBACK = False; +my $*RED-DB = database 'Pg'; + +model DirectFactoryRow { + has Int $.number is rw is column; + has Str $.label is column; + has Json $.payload is rw is column; +} + +class DirectOnlyTemplate is Red::Compiler::Template { + method evaluate(|) { die 'The expression interpreter was called' } + method validate(|) { die 'The validation interpreter was called' } + method path(|) { die 'The path interpreter was called' } +} + +sub direct(@plan, :@getters = []) { + DirectOnlyTemplate.new(:@plan, :@getters, + :builder(Red::Compiler::Emitter.build(@plan)), + :validator(Red::Compiler::Emitter.validator(@plan))) +} + +sub query($template) { + DirectFactoryRow.^all.map(-> $row { die 'The original callback was called' }, + :red-ast($template)) +} + +subtest 'Generated factories bypass all expression interpreters' => { + my @field = ['field', ['subject'], 'number']; + my @label = ['field', ['subject'], 'label']; + my @json = ['field', ['subject'], 'payload']; + my @plans = + ['literal', 42], + @field.Array, + ['op', 'Sum', @field.Array, ['literal', 2]], + ['negate', @field.Array], + ['so', @field.Array], + ['not', @field.Array], + ['array', @field.Array, @label.Array], + ['list', @field.Array, @label.Array], + ['hash', ['value', @field.Array], ['label', @label.Array]], + ['string', ['literal', 'value: '], @field.Array], + ['case', ['op', 'Gt', @field.Array, ['literal', 2]], + ['hash', ['value', @field.Array]], ['hash', ['value', ['literal', 0]]]], + ['call', 'uc', @label.Array], + ['index', @json.Array, 'value'], + ['lookup', @json.Array, ['literal', 'value']], + ['exists', @json.Array, ['literal', 'value']], + ['sequence', ['let', 0, @field.Array], + ['op', 'Sum', ['local', 0], ['literal', 1]]]; + for @plans.kv -> $index, $plan { + my $interpreted = Red::Compiler::Template.new(:plan($plan.list)); + my $expected = $*RED-DB.translate(query($interpreted).ast); + my $actual = $*RED-DB.translate(query(direct($plan)).ast); + is-deeply $actual, $expected, "Factory $index preserves SQL and bindings"; + } + throws-like { Red::Compiler::Emitter.build(['unknown']) }, + X::Red::Compiler::Unsupported, 'Unknown operations fail during specialization'; +}; + +subtest 'Direct factories preserve private captures and fallback guards' => { + my $value = 10; + my $reads = 0; + my @plan = ['op', 'Sum', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = direct(@plan, :getters([-> { $reads++; $value }])); + my $first = query($template); + my $first-sql = $*RED-DB.translate($first.ast); + $value = 20; + my $second = query($template); + isnt $*RED-DB.translate($second.ast).raku, $first-sql.raku, + 'A new binding reads the current capture'; + is-deeply $*RED-DB.translate($first.ast), $first-sql, + 'Earlier bindings retain their values'; + is $reads, 2, 'Captures are evaluated once per binding'; + my $invalid = direct(['op', 'Sum', ['field', ['subject'], 'missing'], ['capture', 0]], + :getters([-> { $reads++; 1 }])); + throws-like { $invalid.bind(DirectFactoryRow) }, X::Red::Compiler::Unsupported, + 'Invalid subjects fail during direct validation'; + is $reads, 2, 'Invalid paths do not execute getters'; + my $json-only = direct(['exists', ['subject'], ['literal', 'value']]); + $json-only = $json-only.clone(:!prevalidate); + throws-like { $json-only.branches(%(value => 1)) }, X::Red::Compiler::Unsupported, + 'A pure direct factory retains the JSON subject guard'; +}; + +subtest 'Direct mutations retain buffered update effects' => { + my @plan = ['assign', ['field', ['subject'], 'number'], ['literal', 12]]; + my $expected = query(Red::Compiler::Template.new(:@plan)); + my $actual = query(direct(@plan)); + is-deeply $*RED-DB.translate($actual.ast), $*RED-DB.translate($expected.ast), + 'Direct assignments use the same updating map path'; + my $readonly = direct(['assign', ['field', ['subject'], 'label'], ['literal', 'new']]); + throws-like { $readonly.bind(DirectFactoryRow) }, X::Red::Compiler::Unsupported, + 'Read-only columns are rejected before effects'; + my @effects; + my @*UPDATE := @effects; + my $abandoned = direct(['sequence', @plan.Array, + ['field', ['subject'], 'missing']]).clone(:!prevalidate); + throws-like { $abandoned.branches(DirectFactoryRow) }, X::Red::Compiler::Unsupported, + 'A direct factory can fail after recording an update'; + is @effects.elems, 0, 'Abandoned direct effects never reach the outer update context'; +}; + +done-testing; diff --git a/t/lib/QueryPlanCompilerFixture.rakumod b/t/lib/QueryPlanCompilerFixture.rakumod new file mode 100644 index 00000000..8c866189 --- /dev/null +++ b/t/lib/QueryPlanCompilerFixture.rakumod @@ -0,0 +1,17 @@ +unit module QueryPlanCompilerFixture; +use Red; +use Red::Compiler::RakuAST; + +CHECK red-compile if (%*ENV // '0') eq '1'; + +model PrecompiledPlanRow { + has Int $.number is column; +} + +sub cached-query(Int $minimum) is export { + PrecompiledPlanRow.^all.grep({ .number > $minimum }) +} + +# A different value would reveal recompilation in the second importing process. +my constant compilation-token = BEGIN now.Str ~ ':' ~ 1000000000.rand.Int; +sub precomp-token() is export { compilation-token } diff --git a/tools/benchmark-compiler.raku b/tools/benchmark-compiler.raku new file mode 100644 index 00000000..a14161bf --- /dev/null +++ b/tools/benchmark-compiler.raku @@ -0,0 +1,59 @@ +use Red; +use Red::Compiler::Template; +use Red::Compiler::Emitter; +use Red::Type::Json; +use JSON::Fast; + +model CompilerBenchmarkRow { + has Int $.number is column; + has Int $.other is column; + has Str $.label is column; + has Json $.payload is column; +} + +# Factory specialization and warmup are excluded from the runtime samples. +subset PositiveInt of Int where * > 0; + +sub MAIN(PositiveInt :$iterations = 1000, PositiveInt :$rounds = 7) { + my @field = ['field', ['subject'], 'number']; + my @plans = + ['field', @field.Array], + ['arithmetic', ['op', 'Mul', ['op', 'Sum', @field.Array, ['literal', 42]], + ['op', 'Sum', ['field', ['subject'], 'other'], ['literal', 2]]]], + ['conditional', ['case', ['op', 'Gt', @field.Array, ['literal', 500]], + ['op', 'Mul', @field.Array, ['literal', 2]], + ['op', 'Sum', @field.Array, ['literal', 1]]]], + ['hash', ['hash', ['value', ['op', 'Sum', @field.Array, + ['field', ['subject'], 'other']]], ['label', ['field', ['subject'], 'label']]]], + ['json', ['exists', ['field', ['subject'], 'payload'], ['literal', 'value']]], + ['capture', ['op', 'Gt', @field.Array, ['capture', 0]]]; + my @samples; + my $sink; + for @plans -> ($scenario, $plan) { + my @plan = $plan.list; + my @getters = $scenario eq 'capture' ?? (-> { 500 },) !! (); + my %templates = + interpreted => Red::Compiler::Template.new(:@plan, :@getters, + :prevalidate(so @getters)), + direct => Red::Compiler::Template.new(:@plan, :@getters, + :prevalidate(so @getters), :builder(Red::Compiler::Emitter.build(@plan)), + :validator(Red::Compiler::Emitter.validator(@plan))); + my %tasks; + for -> $variant { + my $template = %templates{$variant}; + %tasks{$variant} = -> { $sink = $template.bind(CompilerBenchmarkRow) + .branches(CompilerBenchmarkRow) }; + %tasks{$variant}() for ^100; + } + for ^$rounds -> $round { + for ($round %% 2 ?? !! ) -> $variant { + my $start = now; + %tasks{$variant}() for ^$iterations; + my $microseconds = (now - $start).Num * 1e6 / $iterations; + @samples.push: %(:$scenario, :$variant, :$round, :$microseconds); + } + } + } + say to-json(%(:rakudo($*RAKU.compiler.version.Str), :$iterations, :$rounds, + :samples(@samples)), :pretty); +} diff --git a/tools/benchmark-query-cache.raku b/tools/benchmark-query-cache.raku new file mode 100644 index 00000000..fb95be2d --- /dev/null +++ b/tools/benchmark-query-cache.raku @@ -0,0 +1,32 @@ +use Red::QueryPlan::Cache; +use JSON::Fast; + +subset PositiveInt of Int where * > 0; + +# Isolate cache bookkeeping with a hot working set or constant eviction. +sub MAIN(PositiveInt :$iterations = 5000, PositiveInt :$rounds = 7) { + my @samples; + my $sink; + for 1, 16, 128 -> $capacity { + for False, True -> $churn { + my $cache = Red::QueryPlan::Cache.new(:$capacity); + my @keys = (^(($churn ?? 2 !! 1) * $capacity)).map({ "key$_" }); + my $loops = ($iterations / @keys.elems).ceiling.Int; + my $builds = 0; + my &build = -> { $builds++; 42 }; + my &task = -> { $sink = $cache.fetch($_, &build) for @keys }; + task() for ^$loops; + my $warm-builds = $builds; + for ^$rounds -> $round { + my $start = now; + task() for ^$loops; + @samples.push: %(:$capacity, :$churn, :$round, + :microseconds((now - $start).Num * 1e6 / ($loops * @keys.elems))); + } + my $expected = $warm-builds + ($churn ?? $rounds * $loops * @keys.elems !! 0); + die 'Unexpected cache reuse' unless $builds == $expected && $sink.value == 42; + } + } + say to-json(%(:rakudo($*RAKU.compiler.version.Str), :$iterations, :$rounds, + :samples(@samples)), :pretty); +} diff --git a/tools/benchmark-query-construction.raku b/tools/benchmark-query-construction.raku new file mode 100644 index 00000000..90b3b52b --- /dev/null +++ b/tools/benchmark-query-construction.raku @@ -0,0 +1,51 @@ +use Red; +use Red::Compiler::RakuAST; +use JSON::Fast; + +CHECK red-compile if (%*ENV // '0') eq '1'; + +model QueryConstructionBenchmarkRow { + has Int $.id is serial; + has Int $.number is column; +} + +subset PositiveInt of Int where * > 0; + +# Time construction only; validate the queries before warming the measured tasks. +sub MAIN(PositiveInt :$iterations = 200, PositiveInt :$rounds = 7) { + my $*RED-DB = database 'SQLite'; + my $*RED-FALLBACK = False; + QueryConstructionBenchmarkRow.^create-table; + QueryConstructionBenchmarkRow.^create(:number($_)) for 1..3; + my $minimum = 1; + my $offset = 7; + my $projected-minimum = 8; + my %tasks = + filter => -> { QueryConstructionBenchmarkRow.^all.grep({ .number > $minimum }) }, + projection => -> { QueryConstructionBenchmarkRow.^all.map({ .number * 2 + $offset }) }, + chain => -> { + QueryConstructionBenchmarkRow.^all.map({ .number + $offset }) + .grep({ $_ > $projected-minimum }).map({ $_ * 2 }) + }; + my %expected = filter => [2, 3], projection => [9, 11, 13], chain => [18, 20]; + for -> $scenario { + my $query = %tasks{$scenario}(); + my @values = $scenario eq 'filter' + ?? $query.List.map(*.number).sort.Array !! $query.List.sort.Array; + die "Incorrect $scenario results" unless @values eqv %expected{$scenario}; + } + my $sink; + for %tasks.values -> &task { $sink = task() for ^100 } + my @samples; + for ^$rounds -> $round { + for ($round %% 2 ?? !! ) -> $scenario { + my &task = %tasks{$scenario}; + my $start = now; + $sink = task() for ^$iterations; + @samples.push: %(:$scenario, :$round, + :microseconds((now - $start).Num * 1e6 / $iterations)); + } + } + say to-json(%(:rakudo($*RAKU.compiler.version.Str), :$iterations, :$rounds, + :rakuast((%*ENV // '0') eq '1'), :samples(@samples)), :pretty); +} diff --git a/tools/benchmark-query-plans.raku b/tools/benchmark-query-plans.raku new file mode 100644 index 00000000..0f7fdabe --- /dev/null +++ b/tools/benchmark-query-plans.raku @@ -0,0 +1,76 @@ +use Red; +use Red::Compiler::Template; +use Red::Compiler::Emitter; +use Red::QueryPlan::Cache; +use JSON::Fast; + +model QueryPlanBenchmarkRow { + has Int $.id is serial; + has Int $.number is column; +} + +sub MAIN(Int :$iterations = 200, Int :$rounds = 5) { + my $*RED-DB = database 'SQLite'; + my $*RED-FALLBACK = False; + QueryPlanBenchmarkRow.^create-table; + QueryPlanBenchmarkRow.^create(:number($_)) for ^10; + my $minimum = 3; + my @plan = ['op', 'Gt', ['field', ['subject'], 'number'], ['capture', 0]]; + my $template = Red::Compiler::Template.new(:@plan, :getters([-> { $minimum }]), + :builder(Red::Compiler::Emitter.build(@plan)), + :validator(Red::Compiler::Emitter.validator(@plan))); + sub query() { + QueryPlanBenchmarkRow.^all.grep({ .number > $minimum }, :red-ast($template)) + } + my @samples; + my @prototype-samples; + my $sink; + for ^$rounds -> $round { + for ($round %% 2 ?? (False, True) !! (True, False)) -> $enabled { + my $*RED-QUERY-PLAN-CACHE = $enabled; + temp $template = $template.clone( + :filter-cache(Red::QueryPlan::Cache.new), + :sql-cache(Red::QueryPlan::Cache.new)); + my $cold-start = now; + my $query = query(); + $sink = $query.List.eager; + @samples.push: %(:stage, :$enabled, :$round, + :microseconds((now - $cold-start).Num * 1e6)); + $query.List.eager for ^5; + for -> $stage { + my &task = do given $stage { + when 'construction' { -> { $sink = query() } } + when 'translation' { + -> { + my $*RED-DRY-RUN = True; + $sink = $query.iterator + } + } + when 'execution' { -> { $sink = $query.List.eager } } + }; + my $start = now; + task() for ^$iterations; + @samples.push: %(:$stage, :$enabled, :$round, + :microseconds((now - $start).Num * 1e6 / $iterations)); + } + } + } + # Isolate the first model specialization, with an empty predicate cache. + # Both variants retain the same compiler factory and private capture binding. + for ^$rounds -> $round { + for ($round %% 2 ?? (False, True) !! (True, False)) -> $prototype-enabled { + my $*RED-QUERY-PLAN-CACHE = True; + my $source = $template.clone(:filter-prototype( + $prototype-enabled ?? $template.filter-prototype !! Red::AST)); + my $start = now; + for ^$iterations { + my $fresh = $source.clone(:filter-cache(Red::QueryPlan::Cache.new)); + $sink = $fresh.bind(QueryPlanBenchmarkRow).cached-filter(QueryPlanBenchmarkRow); + } + @prototype-samples.push: %(:$round, :$prototype-enabled, + :microseconds((now - $start).Num * 1e6 / $iterations)); + } + } + say to-json(%(:rakudo($*RAKU.compiler.version.Str), :$iterations, :$rounds, + :samples(@samples), :prototype-samples(@prototype-samples)), :pretty); +}