/rakudo

Permalink
Switch branches/tags
коледа v6.c v6.b pre-glr fpw2012 fpw12 drinkers ZA Zürich Warszawa Walnut Vladivostok Vienna Toulouse Toronto Tokyo ThousandOaks Tallinn Strasbourg Stockholm Star+0 Sonoma Sofia Singapore Shanghai Seattle SaltLake SPb Roederbergweg Riga Prague Poznan Plano Pittsburgh Pisa Perl Paris PDX Oslo Orlando Niceville NewYork Moscow Minsk Minneapolis Milan Melbourne Malmö MadMongers London Lisbon Linz Kiev Karlsruhe Houston HongKong Helsinki Gotanda Gdansk Frankfurt Erlangen Edinburgh Echt Dresden Dahut Copenhagen Columbus Cologne Cluj Chicago Bruxelles BristolBath BrazosValley Bratislava Bicycle Berlin Bend Beijing Bajor Austin Atlanta Argentina Amsterdam Albany Advent Adelaide 2018.10 2018.09 2018.08 2018.06 2018.05 2018.04.1 2018.04 2018.03 2018.02.1 2018.02 2018.01 2017.12 2017.11 2017.10
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
Raw Blame History
2991 lines (2725 sloc) 116 KB
# This file contains a bunch of classes related to static optimization of Perl
# 6 programs. It takes place after we've done all of the stuff in the grammar
# and actions, which means CHECK time is over. Thus we're allowed to assume that
# lexpads are immutable, declarations are over and done with, multi candidate
# lists won't change and so forth.
use NQPP6QRegex;
use QAST;
use Perl6::Ops;
# A null QAST node, inserted when we want to eliminate something.
my $NULL := QAST::Op.new( :op<null> );
# Represents the current set of blocks we're in and thus the symbols they
# make available, and allows for queries over them.
my class Symbols {
# The nested blocks we're in; it's the lexical chain, essentially.
has @!block_stack;
# Some interesting scopes.
has $!GLOBALish;
has $!UNIT;
has $!SETTING;
# Cached setting lookups.
has %!SETTING_CACHE;
# Some interesting symbols.
has $!Mu;
has $!Any;
has $!Block;
has $!PseudoStash;
has $!Routine;
has $!Nil;
has $!Failure;
has $!Seq;
# Top routine, for faking it when optimizing post-inline.
has $!fake_top_routine;
# Constructs a new instance of the symbols handling class.
method new($compunit) {
my $obj := nqp::create(self);
$obj.BUILD($compunit);
$obj
}
method BUILD($compunit) {
@!block_stack := [$compunit[0]];
$!GLOBALish := $compunit.ann('GLOBALish');
$!UNIT := $compunit.ann('UNIT');
%!SETTING_CACHE := {};
unless nqp::istype($!UNIT, QAST::Block) {
nqp::die("Optimizer could not find UNIT");
}
nqp::push(@!block_stack, $!UNIT);
$!Mu := self.find_lexical('Mu');
$!Any := self.find_lexical('Any');
$!Block := self.find_lexical('Block');
$!PseudoStash := self.find_lexical('PseudoStash');
$!Routine := self.find_lexical('Routine');
$!Nil := self.find_lexical('Nil');
$!Failure := self.find_lexical('Failure');
$!Seq := self.find_lexical('Seq');
nqp::pop(@!block_stack);
}
# Block handling.
method push_block($block) {
nqp::push(@!block_stack, $block);
}
method pop_block() {
nqp::pop(@!block_stack)
}
method top_block() {
@!block_stack[+@!block_stack - 1]
}
method top_routine() {
return $!fake_top_routine if $!fake_top_routine;
my int $i := nqp::elems(@!block_stack);
while $i > 0 {
$i := $i - 1;
my $co := @!block_stack[$i].ann('code_object');
if nqp::istype($co, $!Routine) {
return $co;
}
}
NQPMu
}
method faking_top_routine($fake, $run) {
$!fake_top_routine := $fake;
my $result := $run();
$!fake_top_routine := NQPMu;
$result;
}
# Accessors for interesting symbols/scopes.
method GLOBALish() { $!GLOBALish }
method UNIT() { $!UNIT }
method Mu() { $!Mu }
method Any() { $!Any }
method Block() { $!Block }
method PseudoStash() { $!PseudoStash }
method Nil() { $!Nil }
method Failure() { $!Failure }
method Seq() { $!Seq }
# The following function is a nearly 1:1 copy of World.find_symbol.
# Finds a symbol that has a known value at compile time from the
# perspective of the current scope. Checks for lexicals, then if
# that fails tries package lookup.
method find_symbol(@name) {
# Make sure it's not an empty name.
unless +@name { nqp::die("Cannot look up empty name"); }
# GLOBAL is current view of global.
if +@name == 1 && @name[0] eq 'GLOBAL' {
return $!GLOBALish;
}
# If it's a single-part name, look through the lexical
# scopes.
if +@name == 1 {
my $final_name := @name[0];
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my %sym := @!block_stack[$i].symbol($final_name);
if +%sym {
return self.force_value(%sym, $final_name, 1);
}
}
}
# If it's a multi-part name, see if the containing package
# is a lexical somewhere. Otherwise we fall back to looking
# in GLOBALish.
my $result := $!GLOBALish;
if +@name >= 2 {
my $first := @name[0];
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my %sym := @!block_stack[$i].symbol($first);
if +%sym {
$result := self.force_value(%sym, $first, 1);
@name := nqp::clone(@name);
@name.shift();
$i := 0;
}
}
}
# Try to chase down the parts of the name.
for @name {
if nqp::existskey($result.WHO, ~$_) {
$result := ($result.WHO){$_};
}
else {
nqp::die("Could not locate compile-time value for symbol " ~
join('::', @name));
}
}
$result;
}
# Locates a lexical symbol and returns its compile time value. Dies if
# it does not exist.
method find_lexical($name) {
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol($name);
if +%sym {
return self.force_value(%sym, $name, 1);
}
}
nqp::die("Optimizer: No lexical $name found");
}
method find_lexical_symbol($name) {
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol($name);
return %sym if +%sym;
}
nqp::die("Optimizer: No lexical $name found");
}
# Checks if a given lexical is declared, though it needn't have a compile
# time known value.
method is_lexical_declared($name) {
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol($name);
if +%sym {
return 1;
}
}
0
}
# Forces a value to be made available.
method force_value(%sym, $key, int $die) {
if nqp::existskey(%sym, 'value') {
%sym<value>
}
elsif nqp::existskey(%sym, 'lazy_value_from') {
%sym<value> := nqp::atkey(nqp::atkey(%sym, 'lazy_value_from'), $key)
}
else {
$die ?? nqp::die("No compile-time value for $key") !! NQPMu
}
}
# Works out how many scopes in from the outermost a given name is. A 0
# from this means the nearest declaration is from the setting; a 1 means
# it is in the mainline, etc.
method scopes_in($name) {
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol($name);
if +%sym {
return $i;
}
}
nqp::die("Symbol $name not found");
}
method is_from_core($name) {
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol($name);
if +%sym && nqp::existskey(%sym, 'value') {
my %sym := $block.symbol("!CORE_MARKER");
if +%sym {
return 1;
}
return 0;
}
}
return 0;
}
method find_in_setting($symbol) {
if !nqp::defined($!SETTING) {
my int $i := +@!block_stack;
while $i > 0 && !nqp::defined($!SETTING) {
$i := $i - 1;
my $block := @!block_stack[$i];
my %sym := $block.symbol("!CORE_MARKER");
if +%sym {
$!SETTING := $block;
}
}
if !nqp::defined($!SETTING) {
nqp::die("Optimizer couldn't find CORE while looking for $symbol.");
}
} else {
if nqp::existskey(%!SETTING_CACHE, $symbol) {
return %!SETTING_CACHE{$symbol};
}
}
my %sym := $!SETTING.symbol($symbol);
if +%sym {
return %!SETTING_CACHE{$symbol} := self.force_value(%sym, $symbol, 1);
}
nqp::die("Optimizer couldn't find $symbol in SETTING.");
}
}
# Tracks problems (errors and warnings) discovered by the optimizer as it
# does its work.
my class Problems {
# Symbols object.
has $!symbols;
# Things that should be warned about; keys are warnings, value is an array
# of line numbers.
has %!worrying;
# Typed exceptions, these are all deadly currently
has @!exceptions;
method new($symbols) {
my $obj := nqp::create(self);
$obj.BUILD($symbols);
$obj
}
method BUILD($symbols) {
$!symbols := $symbols;
%!worrying := nqp::hash();
@!exceptions := [];
}
method add_exception(@name, $op, *%opts) {
%opts<line> := HLL::Compiler.lineof($op.node.orig, $op.node.from, :cache(1));
%opts<modules> := $*W.p6ize_recursive(@*MODULES);
# get line numbers - we can't use $*W.locprepost here
# because the cursor has .from as .pos
# in contrast to node
my $pos := $op.node.from;
my $orig := $op.node.orig;
my $prestart := $pos - 40;
$prestart := 0 if $prestart < 0;
my $pre := nqp::substr($orig, $prestart, $pos - $prestart);
$pre := subst($pre, /.*\n/, "", :global);
$pre := '<BOL>' if $pre eq '';
my $postchars := $pos + 40 > nqp::chars($orig) ?? nqp::chars($orig) - $pos !! 40;
my $post := nqp::substr($orig, $pos, $postchars);
$post := subst($post, /\n.*/, "", :global);
$post := '<EOL>' if $post eq '';
%opts<pre> := nqp::box_s($pre, $!symbols.find_symbol(['Str']));
%opts<post> := nqp::box_s($post, $!symbols.find_symbol(['Str']));
%opts<is-compile-time> := nqp::hllboolfor(1, "perl6");
for %opts -> $p {
if nqp::islist($p.value) {
my @a := [];
for $p.value {
nqp::push(@a, nqp::hllizefor($_, 'perl6'));
}
%opts{$p.key} := nqp::hllizefor(@a, 'perl6');
}
else {
%opts{$p.key} := nqp::hllizefor($p.value, 'perl6');
}
}
my $file := nqp::getlexdyn('$?FILES');
%opts<filename> := nqp::box_s(
(nqp::isnull($file) ?? '<unknown file>' !! $file),
$!symbols.find_symbol(['Str'])
);
my $exsym := $!symbols.find_symbol(@name);
my $x_comp := $!symbols.find_symbol(['X', 'Comp']);
unless nqp::istype($exsym, $x_comp) {
$exsym := $exsym.HOW.mixin($exsym, $x_comp);
}
my $ex := $exsym.new(|%opts);
nqp::push(@!exceptions, $ex);
}
method add_worry($past_node, $message, @extras?) {
self.add_memo($past_node, $message, @extras, :type<worry>);
}
method add_memo($past_node, $message, @extras?, :$type!) {
my $mnode := $past_node.node;
if !nqp::can($mnode,'orig') {
# note("[DISLOCATED MESSAGE] " ~ $message);
return;
}
my $line := HLL::Compiler.lineof($mnode.orig, $mnode.from, :cache(1));
my $key := $message ~ (+@extras ?? "\n" ~ join("\n", @extras) !! "");
my %cont := %!worrying;
unless %cont{$key} {
%cont{$key} := [];
}
%cont{$key}.push($line);
}
method report() {
if +@!exceptions {
if +@!exceptions > 1 {
my $x_comp_group_sym := $!symbols.find_symbol(['X', 'Comp', 'Group']);
my @exs := [];
for @!exceptions {
nqp::push(@exs, $_);
}
my $x_comp_group := $x_comp_group_sym.new(:sorrows(@exs));
$x_comp_group.throw();
}
else {
@!exceptions[0].throw();
}
}
# We didn't die from any Exception, so we print warnings now.
if +%!worrying {
my $err := stderr();
$err.say("WARNINGS for " ~ $*W.current_file ~ ":");
my @fails;
for %!worrying {
$err.print($_.key ~ " (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
join(', ', $_.value) ~ ")\n");
}
}
}
}
# Implements analysis related to variable declarations within a block, which
# includes lexical to local handling and deciding when immediate blocks may
# be flattened into their surrounding block.
my class BlockVarOptimizer {
# Hash mapping variable names declared in the block to the QAST::Var
# of its declaration.
has %!decls;
# Usages of variables in this block, or unioned in from an inlined
# immediate block.
has %!usages_flat;
# Usages of variables in this block, or unioned in from a non-inlined
# immediate block or a declaration block.
has %!usages_inner;
# Have we seen this block (or an inner one) making calls?
has int $!calls;
# Usages of getlexouter.
has @!getlexouter_binds;
# Setup and bind (hopefully one each) of %_.
has @!autoslurpy_setups;
has @!autoslurpy_binds;
# The takedispatcher operation.
has $!takedispatcher;
# If lowering is, for some reason, poisoned.
has int $!poisoned;
# If p6bindsig is used.
has int $!uses_bindsig;
method add_decl($var) {
my str $scope := $var.scope;
if $scope eq 'lexical' || $scope eq 'lexicalref' {
%!decls{$var.name} := $var;
}
}
method add_usage($var) {
my str $scope := $var.scope;
if $scope eq 'lexical' || $scope eq 'lexicalref' {
my $name := $var.name;
my @usages := %!usages_flat{$name};
unless @usages {
@usages := [];
%!usages_flat{$name} := @usages;
}
nqp::push(@usages, $var);
}
}
method register_call() { $!calls++; }
method register_getlexouter_bind($node) {
nqp::push(@!getlexouter_binds, $node);
}
method register_autoslurpy_setup($node) {
nqp::push(@!autoslurpy_setups, $node);
}
method register_autoslurpy_bind($node) {
nqp::push(@!autoslurpy_binds, $node);
}
method register_takedispatcher($node) {
$!takedispatcher := $node;
}
method poison_lowering() { $!poisoned := 1; }
method uses_bindsig() { $!uses_bindsig := 1; }
method get_decls() { %!decls }
method get_usages_flat() { %!usages_flat }
method get_usages_inner() { %!usages_inner }
method get_calls() { $!calls }
method is_poisoned() { $!poisoned }
method is_flattenable() {
for %!decls {
my $var := $_.value;
my str $scope := $var.scope;
return 0 if $scope eq 'lexical' || $scope eq 'lexicalref';
return 0 if $var.decl eq 'param';
}
1
}
method incorporate_inner($vars_info, $flattened) {
# We'll exclude anything that the inner or flattened thing has as
# a declaration, since those are its own.
my %decls := $vars_info.get_decls;
# Inner ones always go into our inners set.
add_to_set(%!usages_inner, $vars_info.get_usages_inner, %decls);
# Flat ones depend on if we flattened this block into ourself.
add_to_set($flattened ?? %!usages_flat !! %!usages_inner,
$vars_info.get_usages_flat, %decls);
# Add up call counts.
$!calls := $!calls + $vars_info.get_calls;
sub add_to_set(%set, %to_add, %exclude) {
for %to_add {
my $name := $_.key;
next if nqp::existskey(%exclude, $name);
my @existing := %set{$name};
if @existing {
for $_.value { nqp::push(@existing, $_) }
#nqp::splice(@existing, $_.value, 0, 0);
}
else {
%set{$name} := $_.value;
}
}
}
}
method delete_unused_magicals($block) {
# Magicals are contextual, so if we call anything when we're done for.
return 0 if $!calls || $!poisoned || $!uses_bindsig;
# Otherwise see if there's any we can kill.
my %kill;
if nqp::existskey(%!decls, '$/') {
if !nqp::existskey(%!usages_flat, '$/') && !nqp::existskey(%!usages_inner, '$/') {
%kill<$/> := 1;
nqp::deletekey(%!decls, '$/');
}
}
if nqp::existskey(%!decls, '$!') {
if !nqp::existskey(%!usages_flat, '$!') && !nqp::existskey(%!usages_inner, '$!') {
%kill<$!> := 1;
nqp::deletekey(%!decls, '$!');
}
}
if nqp::existskey(%!decls, '$¢') {
if !nqp::existskey(%!usages_flat, '$¢') && !nqp::existskey(%!usages_inner, '$¢') {
%kill<$¢> := 1;
nqp::deletekey(%!decls, '$¢');
}
}
if nqp::existskey(%!decls, '$_') {
my str $decl := %!decls<$_>.decl;
if $decl eq 'var' || $decl eq 'contvar' {
if !nqp::existskey(%!usages_flat, '$_') && !nqp::existskey(%!usages_inner, '$_') {
if !@!getlexouter_binds {
%kill<$_> := 1;
nqp::deletekey(%!decls, '$_');
}
elsif nqp::elems(@!getlexouter_binds) == 1 {
my $glob := @!getlexouter_binds[0];
if $glob[0].name eq '$_' && $glob[1][0].value eq '$_' {
$glob.op('null');
$glob.shift(); $glob.shift();
%kill<$_> := 1;
nqp::deletekey(%!decls, '$_');
}
}
}
}
}
# If we found things to eliminate, do so.
if %kill {
my @setups := @($block[0]);
my int $i := 0;
my int $n := nqp::elems(@setups);
while $i < $n {
my $consider := @setups[$i];
if nqp::istype($consider, QAST::Var) && nqp::existskey(%kill, $consider.name) {
@setups[$i] := $NULL;
}
$i++;
}
}
}
method delete_unused_autoslurpy() {
if !$!poisoned && !$!uses_bindsig && nqp::existskey(%!decls, '%_')
&& nqp::elems(@!autoslurpy_setups) == 1
&& nqp::elems(@!autoslurpy_binds) == 1 {
if !nqp::existskey(%!usages_inner, '%_') && nqp::elems(%!usages_flat<%_>) == 1 {
my $to_null := @!autoslurpy_setups[0];
nqp::shift($to_null) while @($to_null);
$to_null.op('null');
$to_null := @!autoslurpy_binds[0];
nqp::shift($to_null) while @($to_null);
$to_null.op('null');
}
}
}
method simplify_takedispatcher() {
unless $!calls || $!uses_bindsig {
if $!takedispatcher {
$!takedispatcher.op('cleardispatcher');
$!takedispatcher.shift();
}
}
}
method lexical_vars_to_locals($block) {
return 0 if $!poisoned || $!uses_bindsig;
return 0 unless nqp::istype($block[0], QAST::Stmts);
for %!decls {
# We're looking for lexical var decls; these have no magical
# vivification lexical behavior and so are safe to lower.
my $qast := $_.value;
my str $decl := $qast.decl;
next unless $decl eq 'var';
my str $scope := $qast.scope;
next unless $scope eq 'lexical';
# Also ensure not dynamic.
my $qv := $qast.value;
my $dynamic := nqp::isconcrete_nd($qv) &&
try nqp::getattr($qv, nqp::what_nd($qv), '$!descriptor').dynamic;
next if $dynamic;
# Consider name. Can't lower if it's used by any nested blocks.
my str $name := $_.key;
unless nqp::existskey(%!usages_inner, $name) {
# Lowerable if it's a normal variable.
next if nqp::chars($name) < 1;
unless nqp::iscclass(nqp::const::CCLASS_ALPHABETIC, $name, 0) {
my str $sigil := nqp::substr($name, 0, 1);
next unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%';
next unless nqp::chars($name) >= 2 &&
nqp::iscclass(nqp::const::CCLASS_ALPHABETIC, $name, 1);
}
# Also must not lexicalref it.
my int $ref'd := 0;
if %!usages_flat{$name} {
for %!usages_flat{$name} {
if $_.scope eq 'lexicalref' {
$ref'd := 1;
last;
}
}
}
next if $ref'd;
# Seems good; lower it. Note we need to retain a lexical in
# case of binder failover to generate errors.
my $new_name := $qast.unique('__lowered_lex');
$block[0].unshift(QAST::Var.new( :name($qast.name), :scope('lexical'),
:decl('var'), :returns($qast.returns) ));
$qast.name($new_name);
$qast.scope('local');
if %!usages_flat{$name} {
for %!usages_flat{$name} {
$_.scope('local');
$_.name($new_name);
}
}
}
}
}
}
# Junction optimizer, responsible for flattening away simple junctions.
my class JunctionOptimizer {
# Junctions we can fold, and what short-circuit operator they fold to.
my %foldable_junction := nqp::hash(
'&infix:<|>', '&infix:<||>',
'&infix:<&>', '&infix:<&&>');
# Contexts in which we can fold a junction.
my %foldable_outer := nqp::hash(
'&prefix:<?>', 1, '&prefix:<!>', 1,
'&prefix:<so>', 1, '&prefix:<not>', 1,
'if', 1, 'unless', 1,
'while', 1, 'until', 1);
# The main optimizer.
has $!optimizer;
# Symbols lookup object.
has $!symbols;
# Constructs a new instance of the junction optimizer.
method new($optimizer, $symbols) {
my $obj := nqp::create(self);
$obj.BUILD($optimizer, $symbols);
$obj
}
method BUILD($optimizer, $symbols) {
$!optimizer := $optimizer;
$!symbols := $symbols;
}
# Check if the junction is in a context where we can optimize.
method is_outer_foldable($op) {
if $op.op eq "call" {
if nqp::existskey(%foldable_outer, $op.name) && $!symbols.is_from_core($op.name) {
return 1;
}
} elsif nqp::existskey(%foldable_outer, $op.op) {
return 1;
}
return 0;
}
# Only if a chain operator handles Any, rather than Mu, in its signature
# will autothreading actually happen.
method chain_handles_Any($op) {
my $obj;
my int $found := 0;
try {
$obj := $!symbols.find_lexical($op);
$found := 1;
}
if $found == 1 {
my @candidates;
if $obj.is_dispatcher {
my $Routine := $!symbols.find_in_setting("Routine");
@candidates := nqp::getattr($obj, $Routine, '@!dispatchees');
}
else {
@candidates := nqp::list($obj);
}
my $signature := $!symbols.find_in_setting("Signature");
my $canditer := nqp::iterator(@candidates);
while $canditer {
my $cand := nqp::shift($canditer);
my $iter := nqp::iterator(nqp::getattr($cand.signature, $signature, '@!params'));
while $iter {
my $p := nqp::shift($iter);
unless nqp::istype($p.type, $!symbols.Any) {
return 0;
}
}
}
return 1;
} else {
return 0;
}
return 0;
}
method can_chain_junction_be_warped($node) {
sub has_core-ish_junction($node) {
if nqp::istype($node, QAST::Op) && $node.op eq 'call' &&
nqp::existskey(%foldable_junction, $node.name) {
if $!symbols.is_from_core($node.name) {
# TODO: special handling for any()/all(), because they create
# a Stmts with a infix:<,> in it.
if +$node.list == 1 {
return 0;
}
return 1;
}
}
return 0;
}
if has_core-ish_junction($node[0]) {
return 0;
} elsif has_core-ish_junction($node[1]) {
return 1;
}
return -1;
}
method optimize($op) {
if self.is_outer_foldable($op) && nqp::istype($op[0], QAST::Op) {
my $proceed := 0;
my $exp-side;
if $op[0].op eq "chain" {
$exp-side := self.can_chain_junction_be_warped($op[0]);
$proceed := $exp-side != -1 && self.chain_handles_Any($op[0].name) == 1
} elsif $op[0].op eq 'callmethod' && $op[0].name eq 'ACCEPTS' {
$exp-side := self.can_chain_junction_be_warped($op[0]);
# we should only ever find the 0nd child (the invocant) to be a junction anyway.
$proceed := $exp-side == 0;
}
if $proceed {
return self.apply_transform($op, $exp-side);
}
}
return NQPMu;
}
method apply_transform($op, $exp-side) {
# TODO chain_handles_Any may get more cleverness to check only the parameters that actually have
# a junction passed to them, so that in some cases the unfolding may still happen.
my str $juncop := $op[0][$exp-side].name eq '&infix:<&>' ?? 'if' !! 'unless';
my str $juncname := %foldable_junction{$op[0][$exp-side].name};
my str $chainop := $op[0].op;
my str $chainname := $op[0].name;
my $values := $op[0][$exp-side];
my $ovalue := $op[0][1 - $exp-side];
# the first time $valop is refered to, create a bind op for a
# local var, next time create a reference var op.
my %reference;
sub refer_to($valop) {
my $id := nqp::where($valop);
if nqp::existskey(%reference, $id) {
QAST::Var.new(:name(%reference{$id}), :scope<local>);
} else {
%reference{$id} := $op.unique('junction_unfold');
QAST::Op.new(:op<bind>,
QAST::Var.new(:name(%reference{$id}),
:scope<local>,
:decl<var>),
$valop);
}
}
# create a comparison operation for the inner comparisons
sub chain($value) {
if $exp-side == 0 {
QAST::Op.new(:op($chainop), :name($chainname),
$value,
refer_to($ovalue));
} else {
QAST::Op.new(:op($chainop), :name($chainname),
refer_to($ovalue),
$value);
}
}
# create a chain of outer logical junction operators with inner comparisons
sub create_junc() {
my $junc := QAST::Op.new(:name($juncname), :op($juncop));
$junc.push(chain($values.shift()));
if +$values.list > 1 {
$junc.push(create_junc());
} else {
$junc.push(chain($values.shift()));
}
return $junc;
}
$op.shift;
$op.unshift(create_junc());
return $!optimizer.visit_op($op);
}
}
# Drives the optimization process overall.
class Perl6::Optimizer {
# Symbols tracking object.
has $!symbols;
# Stack of block variable optimizers.
has @!block_var_stack;
# Junction optimizer.
has $!junc_opt;
# Track problems we encounter.
has $!problems;
# Optimizer configuration.
has %!adverbs;
# The optimization level.
has $!level;
# How deep a chain we're in, for chaining operators.
has int $!chain_depth;
# Are we in void context?
has int $!void_context;
# Are we in a declaration?
has int $!in_declaration;
# one shared QAST tree we'll put into every block we've eliminated
has $!eliminated_block_contents;
has $!debug;
# Entry point for the optimization process.
method optimize($past, *%adverbs) {
# Initialize.
$!symbols := Symbols.new($past);
@!block_var_stack := [];
$!junc_opt := JunctionOptimizer.new(self, $!symbols);
$!problems := Problems.new($!symbols);
$!chain_depth := 0;
$!in_declaration := 0;
$!void_context := 0;
$!debug := nqp::getenvhash<RAKUDO_OPTIMIZER_DEBUG>;
my $*DYNAMICALLY_COMPILED := 0;
my $*W := $past.ann('W');
# Work out optimization level.
$!level := nqp::existskey(%adverbs, 'optimize') ??
+%adverbs<optimize> !! 2;
%!adverbs := %adverbs;
note("method optimize before\n" ~ $past.dump) if $!debug;
$!eliminated_block_contents := QAST::Op.new( :op('die_s'),
QAST::SVal.new( :value('INTERNAL ERROR: Execution of block eliminated by optimizer') ) );
# Walk and optimize the program.
self.visit_block($!symbols.UNIT);
# Report any discovered problems.
$!problems.report();
note("method optimize after\n" ~ $past.dump) if $!debug;
$past
}
# Called when we encounter a block in the tree.
method visit_block($block) {
# Push block onto block stack and create vars tracking.
$!symbols.push_block($block);
@!block_var_stack.push(BlockVarOptimizer.new);
# we don't want any "blah in sink context" warnings emitted here
get_last_stmt($block[1]).annotate: 'sink-quietly', 1
if $block.ann: 'WANTMEPLEASE';
# Visit children.
if $block.ann('DYNAMICALLY_COMPILED') {
my $*DYNAMICALLY_COMPILED := 1;
self.visit_children($block, :resultchild(+@($block) - 1),:void_default);
}
else {
self.visit_children($block, :resultchild(+@($block) - 1),:void_default);
}
# Pop block from block stack and get computed block var info.
$!symbols.pop_block();
my $vars_info := @!block_var_stack.pop();
# If this block is UNIT and we're in interactive mode, poison lexical
# to local lowering, or else we may lose symbols we need to remember.
if $block =:= $!symbols.UNIT && %!adverbs<interactive> {
$vars_info.poison_lowering();
}
# We might be able to delete some of the magical variables when they
# are trivially unused, and also simplify takedispatcher.
if $!level >= 1 {
$vars_info.delete_unused_magicals($block);
$vars_info.delete_unused_autoslurpy();
$vars_info.simplify_takedispatcher();
}
# If the block is immediate, we may be able to inline it.
my int $flattened := 0;
my $result := $block;
if $block.blocktype eq 'immediate' && $block.arity == 0
&& !$vars_info.is_poisoned && !$block.has_exit_handler {
# Scan symbols for any non-interesting ones.
my @sigsyms;
for $block.symtable() {
my $name := $_.key;
if $name ne '$_' && $name ne '$*DISPATCHER' {
@sigsyms.push($name);
}
}
# If we dynamically compiled it, then it must not contain
# any nested blocks.
if $*DYNAMICALLY_COMPILED {
for $block[0].list {
if nqp::istype($_, QAST::Block) && $_.blocktype ne 'raw' {
@sigsyms.push('');
}
}
}
# If we have no interesting ones, then we can inline the
# statements.
if +@sigsyms == 0 {
if $!level >= 2 {
my $outer := $!symbols.top_block;
$result := self.inline_immediate_block($block, $outer,
nqp::existskey($vars_info.get_decls(), '$_'));
}
}
}
# Do any possible lexical => local lowering.
if $!level >= 2 {
$vars_info.lexical_vars_to_locals($block);
}
# Incorporate this block's info into outer block's info.
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].incorporate_inner($vars_info, $flattened)
if @!block_var_stack;
$result
}
# Gets the last statement if the thing passed as a QAST::Stmts or a
# QAST::Stmt. Works recursively. Otherwise returns what was passed.
sub get_last_stmt($op) {
if nqp::istype($op, QAST::Stmt) || nqp::istype($op, QAST::Stmts) {
my int $resultchild := $op.resultchild // +@($op) - 1;
$resultchild >= 0 ?? get_last_stmt($op[$resultchild]) !! $op
}
else {
$op
}
}
# Range operators we can optimize into loops, and how to do it.
sub get_bound($node,$extra) {
# 0
if nqp::istype($node, QAST::Want) && $node[1] eq 'Ii' {
my int $value := $node[2].value + $extra;
if $value > -2147483648 && $value < 2147483647 {
return [QAST::IVal.new( :value($value) )];
}
}
# my constant \foo = 0
elsif nqp::istype($node, QAST::WVal) {
try {
if nqp::istype($node.value, $!symbols.find_in_setting("Int")) {
my int $value := $node.value + $extra;
if $value > -2147483648 && $value < 2147483647 {
return [QAST::IVal.new( :value($value) )];
}
}
}
}
# my int $foo
elsif nqp::istype($node, QAST::Var)
&& nqp::objprimspec($node.returns) == 1 {
return [$extra
?? QAST::Op.new( :op<add_i>, :returns($node.returns),
$node,
QAST::IVal.new( :value($extra) )
)
!! $node
]
}
# No way we can make this faster
[]
}
# A hash for range operators mapping to a block that returns an array
# with [first, last, step] if it is possible to optimize, or [] if not.
my %range_bounds := nqp::hash(
'&infix:<..>', -> $op {
my @lt := get_bound($op[0], 0);
my @rt := get_bound($op[1], 0);
@lt && @rt ?? [@lt[0], @rt[0], 1] !! []
},
'&infix:<..^>', -> $op {
my @lt := get_bound($op[0], 0);
my @rt := get_bound($op[1], -1);
@lt && @rt ?? [@lt[0], @rt[0], 1] !! []
},
'&infix:<^..>', -> $op {
my @lt := get_bound($op[0], 1);
my @rt := get_bound($op[1], 0);
@lt && @rt ?? [@lt[0], @rt[0], 1] !! []
},
'&infix:<^..^>', -> $op {
my @lt := get_bound($op[0], 1);
my @rt := get_bound($op[1], -1);
@lt && @rt ?? [@lt[0], @rt[0], 1] !! []
},
'&prefix:<^>', -> $op {
(my @rt := get_bound($op[0], -1))
?? [QAST::IVal.new( :value(0) ), @rt[0], 1]
!! []
},
'&infix:<...>', -> $op {
my @result;
if get_bound($op[0], 0) -> @lt { # left side ok
if nqp::istype(@lt[0],QAST::IVal) { # and is an int
if get_bound($op[1], 0) -> @rt { # right side ok
if nqp::istype(@rt[0],QAST::IVal) { # and is an int
@result.push(@lt[0]);
@result.push(@rt[0]);
@result.push(@lt[0].value > @rt[0].value ?? -1 !! 1)
}
}
}
}
elsif nqp::istype($op[0],QAST::Op)
&& $op[0].name eq '&infix:<,>' # left side is a list
&& nqp::elems(my $list := $op[0]) == 2 # with 2 elements
&& nqp::istype($list[0],QAST::Want) && nqp::istype($list[0][2],QAST::IVal) # 1st = Int
&& nqp::istype($list[1],QAST::Want) && nqp::istype($list[1][2],QAST::IVal) # 2nd = int
&& get_bound($op[1], 0) -> @rt { # right side is ok
if nqp::istype(@rt[0],QAST::IVal) { # and it is an Int
@result.push($list[0][2]);
@result.push(@rt[0]);
@result.push($list[1][2].value - $list[0][2].value);
}
}
@result
}
);
# Poisonous calls.
my %poison_calls := nqp::hash(
'EVAL', NQPMu, '&EVAL', NQPMu,
'EVALFILE', NQPMu, '&EVALFILE', NQPMu,
'callwith', NQPMu, '&callwith', NQPMu,
'callsame', NQPMu, '&callsame', NQPMu,
'nextwith', NQPMu, '&nextwith', NQPMu,
'nextsame', NQPMu, '&nextsame', NQPMu,
'samewith', NQPMu, '&samewith', NQPMu);
# Called when we encounter a QAST::Op in the tree. Produces either
# the op itself or some replacement opcode to put in the tree.
method visit_op($op) {
note("method visit_op $!void_context\n" ~ $op.dump) if $!debug;
# If it's a QAST::Op of type handle, needs some special attention.
my str $optype := $op.op;
if $optype eq 'handle' || $optype eq 'handlepayload' {
return self.visit_handle($op);
}
elsif $optype eq 'locallifetime' {
return self.visit_children($op,:first);
}
# If it's a for 1..1000000 { } we can simplify it to a while loop. We
# check this here, before the tree is transformed by call inline opts.
if ($optype eq 'p6for' || $optype eq 'p6forstmt') && $op.sunk && @($op) == 2 {
my $reverse := 0;
my $theop := $op[0];
if nqp::istype($theop, QAST::Op)
&& $theop.op eq 'callmethod'
&& $theop.name eq 'reverse' {
$reverse := 1;
$theop := $theop[0];
}
if nqp::istype($theop, QAST::Stmts) {
$theop := $theop[0]
}
if nqp::istype($theop, QAST::Op)
&& nqp::existskey(%range_bounds, $theop.name)
&& $!symbols.is_from_core($theop.name)
&& $op[1].has_ann('code_object') {
self.optimize_for_range($op, $op[1], $theop, :$reverse);
self.visit_op_children($op);
return $op;
}
}
# It could also be that the user explicitly spelled out the for loop
# with a method call to "map".
if $optype eq 'callmethod' && $op.name eq 'sink'
&& nqp::istype($op[0], QAST::Op) && $op[0].op eq 'callmethod'
&& $op[0].name eq 'map' && @($op[0]) == 2
&& $op[0][1].has_ann('code_object')
&& (
nqp::istype((my $c1 := $op[0][0]), QAST::Op)
&& nqp::existskey(%range_bounds, $c1.name)
|| nqp::istype($op[0][0], QAST::Stmts)
&& nqp::istype(($c1 := $op[0][0][0]), QAST::Op)
&& nqp::existskey(%range_bounds, $c1.name)
) && $!symbols.is_from_core($c1.name)
{
self.optimize_for_range($op, $op[0][1], $c1);
self.visit_op_children($op);
return $op;
}
elsif $optype eq 'callmethod' && $op.name eq 'new' && $!void_context {
if $op.node {
my str $op_txt := nqp::escape($op.node.Str);
my $warning := qq[Useless use of "$op_txt" in sink context];
note($warning) if $!debug;
$!problems.add_worry($op, $warning);
}
elsif nqp::istype($op[0],QAST::Var) && $op[0].scope eq 'lexical' {
my str $op_txt := $op[0].name;
my $warning := qq[Useless use of "$op_txt" in sink context];
note($warning) if $!debug;
$!problems.add_worry($op, $warning);
}
}
# Let's see if we can catch a type mismatch in assignment at compile-time.
# Especially with Num, Rat, and Int there's often surprises at run-time.
if ($optype eq 'p6assign' || $optype eq 'assign_n' || $optype eq 'assign_i')
&& nqp::istype($op[0], QAST::Var)
&& ($op[0].scope eq 'lexical' || $op[0].scope eq 'lexicalref') {
if nqp::istype($op[1], QAST::Want) {
# grab the var's symbol from our blocks
my $varsym := $!symbols.find_lexical_symbol($op[0].name);
my $type := $varsym<type>;
my $want_type := $op[1][1];
my $varname := $op[0].name;
if $want_type eq 'Ii' {
if $type =:= (my $numtype := $!symbols.find_in_setting("Num")) || nqp::objprimspec($type) == 2 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($numtype), :value($op[1][2].value), :suggestiontype<Real>,
:valuetype<Int>,
:native(!($type =:= $numtype))
);
} elsif $type =:= $!symbols.find_in_setting("Rat") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($type), :value($op[1][2].value), :suggestiontype<Real>,
:valuetype<Int>
);
} elsif $type =:= $!symbols.find_in_setting("Complex") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($type), :value($op[1][2].value), :suggestiontype<Numeric>,
:valuetype<Int>
);
}
} elsif $want_type eq 'Nn' {
my $value := $op[1][2];
if $value.HOW.name($value) eq 'QAST::NVal' {
if $type =:= (my $inttype := $!symbols.find_in_setting("Int")) || nqp::objprimspec($type) == 1 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($inttype), :value($value.value), :suggestiontype<Real>,
:valuetype<Num>,
:native(!($type =:= $inttype))
);
} elsif $type =:= $!symbols.find_in_setting("Rat") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($type), :value($value.value), :suggestiontype<Real>,
:valuetype<Num>
);
} elsif $type =:= $!symbols.find_in_setting("Complex") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[1],
:$varname, :vartype($type), :value($value.value), :suggestiontype<Numeric>,
:valuetype<Num>
);
}
}
}
}
elsif nqp::istype($op[1], QAST::WVal) {
my $varsym := $!symbols.find_lexical_symbol($op[0].name);
my $type := $varsym<type>;
my $value := $op[1].value;
my $val_type := $value.HOW.name($value);
my $varname := $op[0].name;
if $val_type eq 'Rat' || $val_type eq 'RatStr' {
if $type =:= (my $inttype := $!symbols.find_in_setting("Int")) || nqp::objprimspec($type) == 1 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($inttype), :value($value), :suggestiontype<Real>,
:valuetype<Rat>,
:native(!($type =:= $inttype))
);
} elsif $type =:= (my $numtype := $!symbols.find_in_setting("Num")) || nqp::objprimspec($type) == 2 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($numtype), :value($value), :suggestiontype<Real>,
:valuetype<Rat>,
:native(!($type =:= $numtype))
);
} elsif $type =:= $!symbols.find_in_setting("Complex") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($type), :value($value), :suggestiontype<Numeric>,
:valuetype<Rat>
);
}
}
elsif $val_type eq 'Complex' || $val_type eq 'ComplexStr' {
if $type =:= (my $inttype := $!symbols.find_in_setting("Int")) || nqp::objprimspec($type) == 1 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($inttype), :value($value), :suggestiontype<Numeric>,
:valuetype<Complex>,
:native(!($type =:= $inttype))
);
} elsif $type =:= (my $numtype := $!symbols.find_in_setting("Num")) || nqp::objprimspec($type) == 2 {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($numtype), :value($value), :suggestiontype<Numeric>,
:valuetype<Complex>,
:native(!($type =:= $numtype))
);
} elsif $type =:= $!symbols.find_in_setting("Rat") {
$!problems.add_exception(['X', 'Syntax', 'Number', 'LiteralType'], $op[0],
:$varname, :vartype($type), :value($value), :suggestiontype<Numeric>,
:valuetype<Complex>
);
}
}
}
}
if $optype eq 'chain' {
$!chain_depth := $!chain_depth + 1;
# A chain with exactly two children can become the op itself.
$optype := 'call' if $!chain_depth == 1 &&
!(nqp::istype($op[0], QAST::Op) && $op[0].op eq 'chain') &&
!(nqp::istype($op[1], QAST::Op) && $op[1].op eq 'chain');
}
# We may be able to unfold a junction at compile time.
if $!level >= 2 {
my $jo_result := $!junc_opt.optimize($op);
if $jo_result {
return $jo_result;
}
}
# Visit the children.
self.visit_op_children($op);
# Some ops are significant for variable analysis/lowering.
if $optype eq 'bind' {
if nqp::istype($op[1], QAST::Op) && $op[1].op eq 'getlexouter' {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].register_getlexouter_bind($op);
}
elsif nqp::istype($op[0], QAST::Var) && $op[0].name eq '%_' {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].register_autoslurpy_bind($op);
}
elsif $op.ann('autoslurpy') {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].register_autoslurpy_setup($op);
}
}
elsif $optype eq 'p6bindsig' {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].uses_bindsig();
}
elsif $optype eq 'call' || $optype eq 'callmethod' || $optype eq 'chain' {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].register_call();
if nqp::existskey(%poison_calls, $op.name) {
self.poison_var_lowering();
}
}
# May be able to eliminate some decontrv operations.
if $optype eq 'p6decontrv' {
# If it's rw, don't need to decont at all.
my $value := $op[1];
return $value if $op[0].value.rw;
# Boolifications don't need it, nor do _I/_i/_n/_s ops, with
# the exception of native assignment, which can decont_[ins]
# as appropriate, which may avoid a boxing. Same for QAST::WVal
# if we can see the value is not containerized.
my $last_stmt := get_last_stmt($value);
if nqp::istype($last_stmt, QAST::Op) {
my str $last_op := $last_stmt.op;
if $last_op eq 'hllbool' || nqp::eqat($last_op, 'I', -1) {
return $value;
}
if nqp::eqat($last_op, 'assign_', 0) {
if $last_op eq 'assign_i' { $op.op('decont_i') }
elsif $last_op eq 'assign_n' { $op.op('decont_n') }
elsif $last_op eq 'assign_s' { $op.op('decont_s') }
$op.shift; # The QAST::WVal of the routine
return $op;
}
if nqp::eqat($last_op, '_i', -2) ||
nqp::eqat($last_op, '_n', -2) ||
nqp::eqat($last_op, '_s', -2) {
return $value;
}
}
elsif nqp::istype($last_stmt, QAST::Var) {
my str $scope := $last_stmt.scope;
if $scope eq 'lexicalref' {
$last_stmt.scope('lexical');
return $value;
}
if $scope eq 'attributeref' {
$last_stmt.scope('attribute');
return $value;
}
}
elsif nqp::istype($last_stmt, QAST::WVal) {
return $value unless nqp::iscont($last_stmt.value);
}
}
# Also some return type checks.
elsif $optype eq 'p6typecheckrv' {
my $optres := self.optimize_p6typecheckrv($op);
return $optres if $optres;
}
# Some ops have first boolean arg, and we may be able to get rid of
# a hllbool if there's already an integer result behind it. For if/unless,
# we can only do that when we have the `else` branch, since otherwise we
# might return the no-longer-Bool value from the conditional.
elsif (+@($op) == 3 && ($optype eq 'if' || $optype eq 'unless'))
|| $optype eq 'while' || $optype eq 'until' {
my $update := $op;
my $target := $op[0];
while (nqp::istype($target, QAST::Stmt) || nqp::istype($target, QAST::Stmts)) && +@($target) == 1 {
$update := $target;
$target := $target[0];
}
if nqp::istype($target, QAST::Op) && $target.op eq 'hllbool' {
if nqp::objprimspec($target[0].returns) == nqp::objprimspec(int) {
$update[0] := $target[0];
}
}
elsif nqp::istype($target,QAST::Var) && $target.scope eq 'lexicalref' && nqp::objprimspec($target.returns) == 1 {
# turn $i into $i != 0
$update[0] := QAST::Op.new( :op('isne_i'), :returns($target.returns), $target, QAST::IVal.new( :value(0) ));
}
}
# May be able to simplify takedispatcher ops.
elsif $optype eq 'takedispatcher' {
@!block_var_stack[nqp::elems(@!block_var_stack) - 1].register_takedispatcher($op);
}
# Make array variable initialization cheaper
elsif
$!level > 0
&& $optype eq 'callmethod'
&& $op.name eq 'STORE'
&& nqp::elems($op.list()) == 3
&& nqp::istype($op[0], QAST::Var)
&& nqp::substr($op[0].name, 0, 1) eq '@'
&& nqp::istype($op[1], QAST::Op)
&& ($op[1].op eq 'call' || $op[1].op eq 'callstatic')
&& $op[1].name eq '&infix:<,>'
&& $!symbols.is_from_core($op[1].name)
&& nqp::istype($op[2], QAST::WVal)
&& nqp::istype($op[2], QAST::SpecialArg)
{
return self.optimize_array_variable_initialization($op);
}
# Turn `@a[1, 3]` into `@a.AT-POS(1), @a.AT-POS(3)`
elsif
$!level > 0
&& ($optype eq 'call' || $optype eq 'callstatic')
# workaround because op_eq_core needs to be "primed"
&& ((try $!symbols.find_lexical($op.name)) || 1)
&& self.op_eq_core($op, '&postcircumfix:<[ ]>')
# if it's 3 that means the slice is on the LHS of an assignment
&& +@($op) == 2
&& nqp::istype($op[0], QAST::Var)
&& nqp::substr($op[0].name, 0, 1) eq '@'
&& nqp::istype($op[1], QAST::WVal)
&& nqp::istype($op[1].value, $!symbols.find_in_setting("List"))
{
return self.optimize_array_slice($op);
}
# Calls are especially interesting as we may wish to do some
# kind of inlining.
elsif $optype eq 'call' {
my $opt_result := $op.name eq ''
?? self.optimize_nameless_call($op)
!! self.optimize_call($op);
if $opt_result {
$!chain_depth := 0
if $op.op eq 'chain' && $!chain_depth == 1;
return $opt_result;
}
}
# Some .dispatch:<....> calls can be simplified
elsif $!level >= 2 && $optype eq 'callmethod'
&& nqp::eqat($op.name, 'dispatch:<', 0) {
if $op.name eq 'dispatch:<!>' {
# If it's a private method call, we can sometimes resolve
# it at compile time. If so, we can reduce it to a
# sub call in some cases.
self.optimize_private_method_call: $op;
}
elsif $op.name eq 'dispatch:<.=>' {
# .= calls can be unpacked entirely
return self.optimize_dot_equals_method_call: $op;
}
elsif $op.name eq 'dispatch:<::>' {
return self.optimize_qual_method_call: $op;
}
elsif $op.name eq 'dispatch:<.?>' {
return self.optimize_maybe_method_call: $op;
}
}
if $op.op eq 'chain' {
$!chain_depth := $!chain_depth - 1;
# See if we can staticalize this op
my $obj;
my $found;
try {
$obj := $!symbols.find_lexical($op.name);
$found := 1;
}
if $found {
if nqp::can($obj, 'is-pure') {
$op.op: 'chainstatic'
}
else {
my $scopes := $!symbols.scopes_in: $op.name;
$op.op: 'chainstatic'
if $scopes <= 1 && nqp::can($obj, 'soft') && ! $obj.soft;
}
}
}
$op
}
method optimize_dot_equals_method_call($call) {
my $target := $call[0];
my $qast;
$call.name: ''; # second kid already is the method name the op will use
if nqp::istype($target, QAST::Var) {
# we have a plain variable as target. Safe to Just Use It™
$qast := QAST::Op.new: :op<p6store>, $target, $call
}
else {
# we have something more complex as target. Use a temp var to
# save the result of it into and then to call method on it
$target := $call.shift;
my $name := QAST::Node.unique: 'make_dot_equals_temp_';
$call.unshift: QAST::Var.new: :$name, :scope<local>;
$qast := QAST::Stmts.new:
QAST::Op.new(:op<bind>,
QAST::Var.new(:$name, :scope<local>, :decl<var>),
$target),
QAST::Op.new: :op<p6store>,
QAST::Var.new(:$name, :scope<local>),
$call
}
$qast
}
method visit_op_children($op) {
my int $orig_void := $!void_context;
$!void_context := $op.op eq 'callmethod' && $op.name eq 'sink';
self.visit_children($op);
$!void_context := $orig_void;
}
method optimize_p6typecheckrv($op) {
try {
my $rettype := $!symbols.top_routine.returns;
my int $rettype_ps := nqp::objprimspec($rettype);
if $rettype =:= $!symbols.Mu {
return $op[0];
}
elsif $rettype_ps && $rettype_ps == nqp::objprimspec($op[0].returns) {
return $op[0];
}
}
}
method optimize_array_slice($op) {
unless nqp::isconcrete($op[1].value) {
return $op
}
my $reified := nqp::getattr($op[1].value, $!symbols.find_in_setting("List"), '$!reified');
unless $reified.HOW.name($reified) eq 'BOOTArray' {
return $op
}
my $new_op := QAST::Op.new(:op('callstatic'), :name('&infix:<,>'));
my $array_var := $op[0];
for $reified -> $var {
if nqp::istype($var,$!symbols.find_in_setting("Int")) {
$new_op.push: QAST::Op.new(:op('callmethod'),
:name('AT-POS'),
$array_var,
QAST::WVal.new(:value($var))
);
}
else {
return $op; # alas, too complex for now
}
}
$new_op;
}
method optimize_array_variable_initialization($op) {
my $Positional := $!symbols.find_in_setting('Positional');
if $op[0].returns =:= $Positional {
# Turns the @var.STORE(infix:<,>(...)) into:
# nqp::getattr(
# nqp::p6bindattrinvres(
# nqp::p6bindattrinvres(
# @var,
# List,
# $!reified,
# nqp::create(IterationBuffer),
# ),
# List,
# $!todo,
# nqp::p6bindattrinvres(
# nqp::p6bindattrinvres(
# nqp::p6bindattrinvres(
# $reifier,
# List::Reifier,
# '$!reified',
# nqp::getattr(@var, List, $!reified),
# ),
# List::Reifier,
# '$!reification-target',
# @var.reification-target()
# ),
# List::Reifier,
# '$!future',
# nqp::list(...),
# ),
# ),
# List,
# '$!todo'
# ).reify-until-lazy();
$op.op('callmethod');
$op.name('reify-until-lazy');
my $array_var := $op[0];
my $comma_op := $op[1];
$comma_op.op('getattr');
$comma_op.name(NQPMu);
my $List := $!symbols.find_in_setting('List');
my $Reifier := $!symbols.find_in_setting('List').WHO<Reifier>;
my $IterationBuffer := $!symbols.find_in_setting('IterationBuffer');
my $list := QAST::Op.new(:op<list>);
$list.set_children(@($comma_op));
$comma_op.set_children([
QAST::Op.new(
:op<p6bindattrinvres>,
QAST::Op.new(
:op<p6bindattrinvres>,
$array_var,
QAST::WVal.new(:value($List)),
QAST::SVal.new(:value('$!reified')),
QAST::Op.new(:op<create>, QAST::WVal.new(:value($IterationBuffer))),
),
QAST::WVal.new(:value($List)),
QAST::SVal.new(:value('$!todo')),
QAST::Op.new(
:op<p6bindattrinvres>,
QAST::Op.new(
:op<p6bindattrinvres>,
QAST::Op.new(
:op<p6bindattrinvres>,
QAST::Op.new(:op<create>, QAST::WVal.new(:value($Reifier))),
QAST::WVal.new(:value($Reifier)),
QAST::SVal.new(:value('$!reified')),
QAST::Op.new(
:op<getattr>,
$array_var,
QAST::WVal.new(:value($List)),
QAST::SVal.new(:value('$!reified')),
)
),
QAST::WVal.new(:value($Reifier)),
QAST::SVal.new(:value('$!reification-target')),
QAST::Op.new(
:op<callmethod>,
:name('reification-target'),
$array_var,
)
),
QAST::WVal.new(:value($Reifier)),
QAST::SVal.new(:value('$!future')),
$list,
),
),
QAST::WVal.new(:value($List)),
QAST::SVal.new(:value('$!todo')),
]);
$op.set_children([$comma_op]);
return QAST::Stmts.new: $op, $array_var;
}
$op
}
method optimize_call($op) {
# See if we can find the thing we're going to call.
my $obj;
my int $found := 0;
note("method optimize_call $!void_context\n" ~ $op.dump) if $!debug;
try {
$obj := $!symbols.find_lexical($op.name);
$found := 1;
}
if $found {
# Pure operators can be constant folded.
if nqp::can($obj, 'is-pure') {
# First ensure we're not in void context; warn if so.
sub widen($m) {
my int $from := $m.from;
my int $to := $m.to;
for $m.list {
$from := $_.from if $_.from < $from;
$to := $_.to if $_.to > $to;
}
nqp::substr($m.orig, $from, $to - $from);
}
if $op.name eq '&infix:<,>' {
if +@($op) {
# keep void setting to distribute sink warnings
try self.visit_children($op, :void_default($!void_context));
}
elsif $!void_context {
my $suggest := ($op.okifnil ?? ' (use Nil instead to suppress this warning)' !! '');
my $warning := qq[Useless use of () in sink context$suggest];
note($warning) if $!debug;
$!problems.add_worry($op, $warning);
}
}
elsif $op.node && $!void_context {
my str $op_txt := nqp::escape($op.node.Str);
unless $op_txt eq '/' && $op[1].has_compile_time_value && $op[1].compile_time_value == 0 {
my str $expr := nqp::escape(widen($op.node));
my $warning := qq[Useless use of "$op_txt" in expression "$expr" in sink context];
note($warning) if $!debug;
$!problems.add_worry($op, $warning);
}
}
# check if all arguments are known at compile time
my int $all_args_known := 1;
my @args := [];
for @($op) {
if nqp::istype($_, QAST::Node)
&& $_.has_compile_time_value
&& !$_.named {
nqp::push(@args, $_.compile_time_value);
}
else {
$all_args_known := 0;
last;
}
}
# Don't constant fold the 'x' operator if the resulting string would be too big.
# 1024 is just a heuristic, measuring might show a bigger value would be fine.
if $all_args_known && self.op_eq_core($op, '&infix:<x>') {
my int $survived := 0;
my int $size;
try {
$size := @args[0].chars * @args[1];
$survived := 1;
}
return $op if $survived && $size > 1024;
}
# If so, attempt to constant fold.
if $all_args_known {
my int $survived := 0;
my $ret_value;
try {
my $*FOLDING := 1;
$ret_value := $obj(|@args);
$survived := 1 ;
CONTROL {
$survived := 0;
}
}
if $survived && self.constant_foldable_type($ret_value) {
return $NULL if $!void_context && !$!in_declaration;
$*W.add_object_if_no_sc($ret_value);
my $wval := QAST::WVal.new(:value($ret_value));
if $op.named {
$wval.named($op.named);
}
# if it's an Int, Num or Str, we can create a Want
# from it with an int, num or str value.
my $want;
if !nqp::isconcrete($ret_value) {
# can we create a Want with a type object??? XXX
} elsif nqp::istype($ret_value, $!symbols.find_in_setting("Int")) && !nqp::isbig_I(nqp::decont($ret_value)) {
$want := QAST::Want.new($wval,
"Ii", QAST::IVal.new(:value(nqp::unbox_i($ret_value))));
} elsif nqp::istype($ret_value, $!symbols.find_in_setting("Num")) {
$want := QAST::Want.new($wval,
"Nn", QAST::NVal.new(:value(nqp::unbox_n($ret_value))));
} elsif nqp::istype($ret_value, $!symbols.find_in_setting("Str")) {
$want := QAST::Want.new($wval,
"Ss", QAST::SVal.new(:value(nqp::unbox_s($ret_value))));
}
if nqp::defined($want) {
if $op.named {
$want.named($op.named);
}
return $want;
}
return $wval;
} elsif $survived && nqp::istype($ret_value, $!symbols.Failure) {
# Disarm the failure so it doesn't output its warning during GC.
$ret_value.Bool();
}
}
}
elsif $!level >= 2 && (
$op.name eq '&prefix:<++>' || $op.name eq '&postfix:<++>'
|| $op.name eq '&prefix:<-->' || $op.name eq '&postfix:<-->'
) && $!symbols.is_from_core($op.name)
&& self.optimize-post-pre-inc-dec-ops($op) -> $qast {
return $qast;
}
# If it's an onlystar proto, we have a couple of options.
# The first is that we may be able to work out what to
# call at compile time. Failing that, we can at least inline
# the proto.
my $dispatcher;
try { if $obj.is_dispatcher { $dispatcher := 1 } }
if $dispatcher && $obj.onlystar {
# Try to do compile-time multi-dispatch. Need to consider
# both the proto and the multi candidates.
my @ct_arg_info := self.analyze_args_for_ct_call($op);
if +@ct_arg_info {
my @types := @ct_arg_info[0];
my @flags := @ct_arg_info[1];
my $ct_result_proto := nqp::p6trialbind($obj.signature, @types, @flags);
my @ct_result_multi := $obj.analyze_dispatch(@types, @flags);
if $ct_result_proto == 1 && @ct_result_multi[0] == 1 {
my $chosen := @ct_result_multi[1];
if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
if $!level >= 2 {
return nqp::can($chosen, 'inline_info') && nqp::istype($chosen.inline_info, QAST::Node)
?? self.inline_call($op, $chosen)
!! self.call_ct_chosen_multi($op, $obj, $chosen);
}
}
elsif $ct_result_proto == -1 || @ct_result_multi[0] == -1 {
self.report_inevitable_dispatch_failure(
$op, @types, @flags, $obj,
:protoguilt($ct_result_proto == -1)
) unless $*NO-COMPILE-TIME-THROWAGE;
}
}
if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
}
elsif !$dispatcher && nqp::can($obj, 'signature') {
# If we know enough about the arguments, do a "trial bind".
my @ct_arg_info := self.analyze_args_for_ct_call($op);
if +@ct_arg_info {
my @types := @ct_arg_info[0];
my @flags := @ct_arg_info[1];
my $sig := $obj.signature;
my $ct_result := nqp::p6trialbind($sig, @types, @flags);
if $ct_result == 1 {
if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
if $!level >= 2 {
if nqp::can($obj, 'inline_info') && nqp::istype($obj.inline_info, QAST::Node) {
return self.inline_call($op, $obj);
}
else {
self.simplify_refs($op, $sig);
}
copy_returns($op, $obj);
}
}
elsif $ct_result == -1 {
self.report_inevitable_dispatch_failure(
$op, @types, @flags, $obj
) unless $*NO-COMPILE-TIME-THROWAGE;
}
}
}
# If we get here, no inlining or compile-time decision was
# possible, but we may still be able to make it a callstatic,
# which is cheaper on some backends.
my $scopes := $!symbols.scopes_in($op.name);
if $scopes == 0 || $scopes == 1 && nqp::can($obj, 'soft') && !$obj.soft {
$op.op('callstatic');
}
}
else {
# We really should find routines; failure to do so is a CHECK
# time error. Check that it's not just compile-time unknown,
# however (shows up in e.g. sub foo(&x) { x() }).
unless $!symbols.is_lexical_declared($op.name) {
# Shouldn't be able to hit this due to checks done in the parse
# phase, but this will catch anything that sneaks past it.
$!problems.add_exception(['X', 'Undeclared'], $op, :symbol($op.name));
}
}
return NQPMu;
}
method optimize-post-pre-inc-dec-ops($op) {
my $var := $op[0];
my $node := $op.node;
$op.op: 'callstatic'; # by now we know 'tis a core op
# if we got a native int/num, we can rewrite into nqp ops
if nqp::istype($var,QAST::Var) && ($var.scope eq 'lexicalref' || $var.scope eq 'attributeref')
&& ((my $primspec := nqp::objprimspec($var.returns)) == 1 # native int
|| $primspec == 2 || $primspec == 4 || $primspec == 5) # native num or "emulated" 64bit int
{
my $returns := $var.returns;
my $is-dec := nqp::eqat($op.name, '--', -3);
if $primspec == 1 { # native int
my $one := QAST::IVal.new: :value(1);
if $!void_context || nqp::eqat($op.name, '&pre', 0) {
# we can just use (or ignore) the result
return QAST::Op.new: :op<assign_i>, :$node, :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_i' !! 'add_i'),
:$returns, $var, $one
}
else {
# need to assign original value; it's cheaper to just
# do the reverse operation than to use a temp var
return QAST::Op.new: :op($is-dec ?? 'add_i' !! 'sub_i'),
:$node, :$returns,
QAST::Op.new(:op<assign_i>, :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_i' !! 'add_i'),
:$returns, $var, $one),
$one
}
}
elsif $primspec == 2 { # native num
my $one := QAST::NVal.new: :value(1);
if $!void_context || nqp::eqat($op.name, '&pre', 0) {
# we can just use (or ignore) the result
return QAST::Op.new: :op<assign_n>, :$node, :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_n' !! 'add_n'),
:$returns, $var, $one
}
else {
# need to assign original value; it's cheaper to just
# do the reverse operation than to use a temp var
return QAST::Op.new: :op($is-dec ?? 'add_n' !! 'sub_n'),
:$node, :$returns,
QAST::Op.new(:op<assign_n>, :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_n' !! 'add_n'),
:$returns, $var, $one),
$one
}
}
elsif $primspec == 4 || $primspec == 5 { # 64bit int on 32bit backends
my str $assign_op := $primspec == 4 ?? 'assign_i64' !! 'assign_u64';
my $one := QAST::IVal.new: :value(1);
if $!void_context || nqp::eqat($op.name, '&pre', 0) {
# we can just use (or ignore) the result
return QAST::Op.new: :op($assign_op), :$node, :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_i64' !! 'add_i64'),
:$returns, $var, $one
}
else {
# need to assign original value; it's cheaper to just
# do the reverse operation than to use a temp var
return QAST::Op.new: :op($is-dec ?? 'add_i64' !! 'sub_i64'),
:$node, :$returns,
QAST::Op.new(:op($assign_op), :$returns, $var,
QAST::Op.new: :op($is-dec ?? 'sub_i64' !! 'add_i64'),
:$returns, $var, $one),
$one
}
}
}
# XXX TODO: my tests show the opt below makes things 25% slower.
# Even without the temp var business, and unoptimized version:
# my $i = 1; my $z; { for ^10000_000 { $z = 1 + ++$i }; say now - ENTER now }
# comes out slower than
# my $i = 1; my $z; { for ^10000_000 { $z = 1 + $i++ }; say now - ENTER now }
#
# Don't know what's going on. Leaving the code below commented out
# Filed as https://github.com/rakudo/rakudo/issues/1491
# elsif nqp::eqat($op.name, 'post', 1) { # try to optimize postfix ops
# just rewrite to prefix-assign
# $op.name: '&prefix:<' ~ nqp::substr($op.name, -3);
# if original value isn't needed, we're done here
# return $op if $!void_context;
# use a local temp var to store original value
# my $temp := QAST::Var.new: :$node, :scope<local>,
# :name(QAST::Node.unique: 'post_pre_op_rewrite_');
#
# return QAST::Stmts.new: :$node,
# QAST::Op.new(:$node, :op<bind>, $temp.decl_as('var'),
# QAST::Op.new: :op<decont>, $var),
# $op, $temp
# }
NQPMu
}
method constant_foldable_type($value) {
!(
nqp::istype($value, $!symbols.Seq) ||
nqp::istype($value, $!symbols.Failure)
)
}
# The _i64 and _u64 are only used on backends that emulate int64/uint64
my @native_assign_ops := ['', 'assign_i', 'assign_n', 'assign_s', 'assign_i64', 'assign_u64'];
method optimize_nameless_call($op) {
return NQPMu
unless nqp::elems($op)
&& nqp::istype((my $metaop := $op[0]), QAST::Op)
&& ($metaop.op eq 'call' || $metaop.op eq 'callstatic');
# if we know we're directly calling the result, we can be smarter
# about METAOPs
if self.op_eq_core($metaop, '&METAOP_ASSIGN') {
if nqp::istype($metaop[0], QAST::Var) # lexical sub
|| (nqp::istype($metaop[0], QAST::Op) # or a REVERSE metaop with lex sub
&& self.op_eq_core($metaop[0], '&METAOP_REVERSE') # and nothing else
&& nqp::istype($metaop[0][0], QAST::Var)
&& nqp::elems($metaop[0]) == 1
&& (my $is-reverse := 1)) {
if $is-reverse
|| (nqp::istype($op[1], QAST::Var) && (my int $is_var := 1))
|| $op[1].has_ann('METAOP_opt_result') # previously-optimized nested METAOP
# instead of $foo += 1 we may have $foo.bar += 1, which
# we really want to unpack here as well. this second branch
# of the if statement achieves this.
|| (nqp::istype($op[1], QAST::Op)
&& ($op[1].op eq 'callmethod'
|| ($op[1].op eq 'hllize' && nqp::istype($op[1][0], QAST::Op)
&& $op[1][0].op eq 'callmethod')
|| $op[1].op eq 'call' || $op[1].op eq 'callstatic')
) {
my str $assignop;
my $assignee;
my $assignee_var;
my int $is-always-definite;
if $is_var {
my str $sigil := nqp::substr($op[1].name, 0, 1);
if nqp::objprimspec($op[1].returns) -> $spec {
$assignop := @native_assign_ops[$spec];
$is-always-definite := 1;
}
elsif $sigil eq '$' {
$assignop := 'p6assign';
}
elsif $sigil eq '@' || $sigil eq '%' {
$assignop := 'p6store';
}
else {
return NQPMu;
}
$assignee := $op[1];
# other optimizations might want to change this independently
$assignee_var := nqp::clone($op[1]);
}
else {
$assignop := 'p6store';
# We want to be careful to only call $foo.bar once, if that's what
# we have, so we bind to a local var and assign to that. The
# var is also needed when we're unpacking a REVERSE op, since
# we'd still need to assign into the variable on LHS w/o REVERSE
my $lhs_ast := $op[1];
my $target_name := QAST::Node.unique: 'METAOP_assign_';
$assignee :=
QAST::Op.new: :op<bind>,
QAST::Var.new(:name($target_name), :scope<local>, :decl<var>),
$lhs_ast;
$assignee_var :=
QAST::Var.new: :name($target_name),:scope<local>;
}
# since the optimizer will only ever walk the first branch of a Want
# node, we have to make sure to change the node in place, since it's
# most likely shared with the other branch.
$op.op: $assignop;
my $operand := $op[2];
$op.pop; $op.pop; $op.pop;
$op.push: $assignee;
if $is-always-definite {
$op.push: QAST::Op.new: :op<call>, :name($metaop[0].name),
$assignee_var, $operand;
}
elsif $is-reverse {
# We end up with two calls of the op if var is not definite.
# This is by design:
# https://irclog.perlgeek.de/perl6-dev/2018-01-12#i_15681388
$op.push:
QAST::Op.new: :op<call>, :name($metaop[0][0].name),
$operand,
QAST::Op.new(:op<if>,
QAST::Op.new(:op<p6definite>, $assignee_var),
$assignee_var,
QAST::Op.new(:op<call>, :name($metaop[0][0].name)));
}
else {
# We end up with two calls of the op if var is not definite.
# This is by design:
# https://irclog.perlgeek.de/perl6-dev/2018-01-12#i_15681388
$op.push:
QAST::Op.new: :op<call>, :name($metaop[0].name),
QAST::Op.new(:op<if>,
QAST::Op.new(:op<p6definite>, $assignee_var),
$assignee_var,
QAST::Op.new(:op<call>, :name($metaop[0].name))),
$operand;
}
$op.annotate_self: 'METAOP_opt_result', 1;
$op.returns: $assignee.returns
if $assignop ne 'p6assign'
&& nqp::objprimspec($assignee.returns);
my $*NO-COMPILE-TIME-THROWAGE := 1;
return self.visit_op: $op;
}
}
}
elsif self.op_eq_core($metaop, '&METAOP_NEGATE') {
return NQPMu unless nqp::istype($metaop[0], QAST::Var);
return QAST::Op.new: :op<call>, :name('&prefix:<!>'),
QAST::Op.new: :op<call>, :name($metaop[0].name),
$op[1], $op[2];
}
elsif self.op_eq_core($metaop, '&METAOP_REVERSE') {
return NQPMu unless nqp::istype($metaop[0], QAST::Var)
&& nqp::elems($op) == 3;
return QAST::Op.new(:op<call>, :name($metaop[0].name),
$op[2], $op[1]).annotate_self: 'METAOP_opt_result', 1;
}
NQPMu
}
method op_eq_core($op, $name) {
$op.name eq $name && $!symbols.is_from_core: $name
}
method optimize_private_method_call($op) {
# We can only optimize if we have a compile-time-known name.
my $name_node := $op[1];
if nqp::istype($name_node, QAST::Want) && $name_node[1] eq 'Ss' {
$name_node := $name_node[2];
}
unless (nqp::istype($name_node, QAST::SVal)) {
return 0;
}
# For private method calls within a class, we can try to resolve them
# at this point. If they are missing, that's an error. In a role, this
# optimization won't help.
my $pkg_node := $op[2];
if $pkg_node.has_compile_time_value {
my str $name := $name_node.value; # get raw string name
my $pkg := $pkg_node.returns; # actions sets this unless in role
if nqp::can($pkg.HOW, 'find_private_method') {
my $meth := $pkg.HOW.find_private_method($pkg, $name);
if nqp::defined($meth) && $meth {
if nqp::isnull(nqp::getobjsc($meth)) {
try $*W.add_object_if_no_sc($meth);
}
unless nqp::isnull(nqp::getobjsc($meth)) {
my $call := QAST::WVal.new( :value($meth) );
my $inv := $op.shift;
$op.shift; $op.shift; # name, package (both pre-resolved now)
$op.unshift($inv);
$op.unshift($call);
$op.op('call');
$op.name(NQPMu);
return 1;
}
}
else {
$!problems.add_exception(['X', 'Method', 'NotFound'], $op,
:private(nqp::hllboolfor(1, "perl6")), :method($name),
:typename($pkg.HOW.name($pkg)), :invocant($pkg));
return 1;
}
}
}
# If resolution didn't work out this way, and we're on the MoarVM
# backend, use a spesh plugin to help speed it up.
if nqp::getcomp('perl6').backend.name eq 'moar' {
my $inv := $op.shift;
my $name := $op.shift;
my $pkg := $op.shift;
$op.unshift($inv);
$op.unshift(QAST::Op.new(
:op('speshresolve'),
QAST::SVal.new( :value('privmeth') ),
$pkg,
$name
));
$op.op('call');
$op.name(NQPMu);
return 1;
}
}
method optimize_qual_method_call($op) {
# Spesh plugins only available on MoarVM.
return $op unless nqp::getcomp('perl6').backend.name eq 'moar';
# We can only optimize if we have a compile-time-known name.
my $name_node := $op[1];
if nqp::istype($name_node, QAST::Want) && $name_node[1] eq 'Ss' {
$name_node := $name_node[2];
}
return $op unless nqp::istype($name_node, QAST::SVal);
# We need to evaluate the invocant only once, so will bind it into
# a temporary.
my $inv := $op.shift;
my $name := $op.shift;
my $type := $op.shift;
my @args;
while $op.list {
nqp::push(@args, $op.shift);
}
my $temp := QAST::Node.unique('inv_once');
$op.op('stmts');
$op.push(QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($temp), :scope('local'), :decl('var') ),
$inv
));
$op.push(QAST::Op.new(
:op('call'),
QAST::Op.new(
:op('speshresolve'),
QAST::SVal.new( :value('qualmeth') ),
QAST::Var.new( :name($temp), :scope('local') ),
$name,
$type
),
QAST::Var.new( :name($temp), :scope('local') ),
|@args
));
return $op;
}
method optimize_maybe_method_call($op) {
# Spesh plugins only available on MoarVM.
return $op unless nqp::getcomp('perl6').backend.name eq 'moar';
# We can only optimize if we have a compile-time-known name.
my $name_node := $op[1];
if nqp::istype($name_node, QAST::Want) && $name_node[1] eq 'Ss' {
$name_node := $name_node[2];
}
return $op unless nqp::istype($name_node, QAST::SVal);
# We need to evaluate the invocant only once, so will bind it into
# a temporary.
my $inv := $op.shift;
my $name := $op.shift;
my @args;
while $op.list {
nqp::push(@args, $op.shift);
}
my $temp := QAST::Node.unique('inv_once');
$op.op('stmts');
$op.push(QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($temp), :scope('local'), :decl('var') ),
$inv
));
$op.push(QAST::Op.new(
:op('call'),
QAST::Op.new(
:op('speshresolve'),
QAST::SVal.new( :value('maybemeth') ),
QAST::Op.new(
:op('decont'),
QAST::Var.new( :name($temp), :scope('local') )
),
$name,
),
QAST::Var.new( :name($temp), :scope('local') ),
|@args
));
return $op;
}
method generate_optimized_for($op,$callee,$start,$end,$step) {
my $it_var := QAST::Node.unique('range_it_');
my $last_var := QAST::Node.unique('range_last_');
my $callee_var := QAST::Node.unique('range_callee_');
$op.op('stmts');
$op.push(QAST::Stmts.new(
# my int $it := $start - $step
QAST::Op.new( :op<bind>,
QAST::Var.new(
:name($it_var), :scope<local>, :decl<var>, :returns(int)
),
QAST::Op.new( :op<sub_i>, $start, QAST::IVal.new( :value($step)))
),
# my int $last := $end
QAST::Op.new( :op<bind>,
QAST::Var.new(
:name($last_var), :scope<local>, :decl<var>, :returns(int)
),
$end
),
# my $callee := { };
QAST::Op.new( :op<bind>,
QAST::Var.new(:name($callee_var), :scope<local>, :decl<var>),
$callee
),
# nqp::while(
# $step < 0 ?? nqp::isge_i !! nqp::isle_i(
# nqp::bind($it, nqp::add_i($it,$step)),
# $last_var
# )
QAST::Op.new( :op<while>,
QAST::Op.new(
op => $step < 0 ?? "isge_i" !! "isle_i",
QAST::Op.new( :op<bind>,
QAST::Var.new(:name($it_var), :scope<local>, :returns(int)),
QAST::Op.new( :op<add_i>,
QAST::Var.new(:name($it_var),:scope<local>,:returns(int)),
QAST::IVal.new( :value($step) )
)
),
QAST::Var.new(:name($last_var), :scope<local>, :returns(int))
),
# nqp::call($callee, $it)
QAST::Op.new( :op<call>,
QAST::Var.new(:name($callee_var), :scope<local> ),
QAST::Var.new(:name($it_var), :scope<local>, :returns(int))
)
),
# return Nil
QAST::WVal.new( :value($!symbols.Nil) )
));
}
method optimize_for_range($op, $callee, $c2, :$reverse) {
my $code := $callee.ann('code_object');
my $count := $code.count;
my $block := $!symbols.Block;
my $phasers := nqp::istype($code, $block)
?? nqp::getattr($code, $block, '$!phasers')
!! nqp::null();
if $count == 1
&& nqp::isnull($phasers)
&& %range_bounds{$c2.name}($c2) -> @fls {
if $reverse {
my $tmp := @fls[0];
@fls[0] := @fls[1];
@fls[1] := $tmp;
@fls[2] := -@fls[2];
}
$op.shift while $op.list;
self.generate_optimized_for($op,$callee,@fls[0],@fls[1],@fls[2])
}
}
# Handles visiting a QAST::Op :op('handle').
method visit_handle($op) {
my int $orig_void := $!void_context;
$!void_context := 0;
self.visit_children($op, :skip_selectors);
$!void_context := $orig_void;
$op
}
# Handles visiting a QAST::Want node.
method visit_want($want) {
note("method visit_want $!void_context\n" ~ $want.dump) if $!debug;
# If it's the sink context void node, then only visit the first
# child. Otherwise, see all.
if +@($want) == 3 && $want[1] eq 'v' {
my $sinker := $want[2];
my int $tweak_sinkee := nqp::istype($sinker, QAST::Op)
&& $sinker.op eq 'p6sink'
&& $sinker[0] =:= $want[0];
self.visit_children($want, :first);
if $tweak_sinkee {
$want[2][0] := $want[0];
}
}
else {
self.visit_children($want, :skip_selectors);
}
# (Check the following after we've checked children, since they may have useless bits too.)
# Any literal in void context deserves a warning.
if $!void_context && +@($want) == 3 && $want.node
&& !$want.ann('sink-quietly') {
my str $warning;
my $no-sink;
if $want[1] eq 'Ss' && nqp::istype($want[2], QAST::SVal) {
$warning := 'constant string "'
~ nqp::escape($want[2].node // $want[2].value)
~ '"'
}
elsif $want[1] eq 'Ii' && nqp::istype($want[2], QAST::IVal) {
$warning := 'constant integer '
~ ($want[2].node // $want[2].value);
}
elsif $want[1] eq 'Nn' && nqp::istype($want[2], QAST::NVal) {
$warning := 'constant floating-point number '
~ ($want[2].node // $want[2].value);
}
elsif $want[1] eq 'v' && nqp::istype($want[2], QAST::Op) {
# R#2040
# - QAST::Op(p6capturelex)
# - QAST::Op(callmethod clone)
# - QAST::WVal(Sub...)
if $want[0].op eq 'p6capturelex' {
my $op := $want[0][0];
if $op.op eq 'callmethod' && $op.name eq 'clone' {
$op := $op[0];
if nqp::istype($op, QAST::WVal) && nqp::istype(
$op.value,
$!symbols.find_in_setting("Sub")
) && !$op.value.name {
$warning := qq[anonymous sub, did you forget to provide a name?];
$no-sink := 1;
}
}
}
}
if $warning {
$warning := "Useless use of " ~ $warning;
$warning := $warning ~ qq[ in sink context] unless $no-sink;
$warning := $warning ~ ' (use Nil instead to suppress this warning)' if $want.okifnil;
note($warning) if $!debug;
$!problems.add_worry($want, $warning);
}
}
$want;
}
# Handles visit a variable node.
method visit_var($var) {
# Track usage.
my str $scope := $var.scope;
my str $decl := $var.decl;
if $scope eq 'attribute' || $scope eq 'attributeref' || $scope eq 'positional' || $scope eq 'associative' {
self.visit_children($var);
} else {
my int $top := nqp::elems(@!block_var_stack) - 1;
if $decl {
@!block_var_stack[$top].add_decl($var);
if $decl eq 'param' {
self.visit_children($var);
my $default := $var.default;
if $default {
my $stmts_def := QAST::Stmts.new( $default );
self.visit_children($stmts_def);
$var.default($stmts_def[0]);
}
}
}
else {
@!block_var_stack[$top].add_usage($var);
}
}
# Warn about usage of variable in void context.
if $!void_context && !$decl && $var.name && !$var.sinkok {
# stuff like Nil is also stored in a QAST::Var, but
# we certainly don't want to warn about that one.
my str $name := try $!symbols.find_lexical_symbol($var.name)<descriptor>.name;
$name := $var.name unless $name;
my str $sigil := nqp::substr($name, 0, 1);
if $name ne "Nil" && $name ne 'ctxsave' { # (comes from nqp, which doesn't know about wanted)
my $suggest := ($var.okifnil ?? ' (use Nil instead to suppress this warning)' !! '');
my $warning := nqp::index(' $@%&', $sigil) < 1
?? "Useless use of $name symbol in sink context$suggest"
!! $sigil eq $name
?? "Useless use of unnamed $sigil variable in sink context$suggest"
!! "Useless use of $name in sink context$suggest";
note($warning) if $!debug;
$!problems.add_worry($var, $warning);
}
}
$var;
}
# Checks arguments to see if we're going to be able to do compile
# time analysis of the call.
my @allo_map := ['', 'Ii', 'Nn', 'Ss'];
my %allo_rev := nqp::hash('Ii', 1, 'Nn', 2, 'Ss', 3);
my @prim_names := ['', 'int', 'num', 'str'];
my int $ARG_IS_LITERAL := 32;
method analyze_args_for_ct_call($op) {
my @types;
my @flags;
my @allomorphs;
my int $num_prim := 0;
my int $num_allo := 0;
# Initial analysis.
for @($op) {
if !nqp::can($_,'flat') {
note("Weird node in analyze: " ~ $_.HOW.name($_));
return [];
}
# Can't cope with flattening or named.
if $_.flat || $_.named ne '' {
return [];
}
# See if we know the node's type; if so, check it.
my $type := $_.returns();
if $type =:= NQPMu {
if nqp::istype($_, QAST::Want) && nqp::istype($_[0], QAST::WVal) {
$type := $_[0].value.WHAT;
}
}
my $ok_type := 0;
try $ok_type := nqp::istype($type, $!symbols.Mu) &&
$type.HOW.archetypes.nominal();
unless $ok_type {
# nqp::ops end up labeled with nqp primitive types; we swap
# those out for their Perl 6 equivalents.
my int $ps := nqp::objprimspec($type);
if $ps >= 1 && $ps <= 3 {
$type := $!symbols.find_lexical(@prim_names[$ps]);
$ok_type := 1;
}
}
if $ok_type {
my $prim := nqp::objprimspec($type);
my str $allo := $_.has_compile_time_value && nqp::istype($_, QAST::Want)
?? $_[1] !! '';
@types.push($type);
@flags.push($prim);
@allomorphs.push($allo);
$num_prim := $num_prim + 1 if $prim;
$num_allo := $num_allo + 1 if $allo;
}
else {
return [];
}
}
# See if we have an allomorphic constant that may allow us to do
# a native dispatch with it; takes at least one declaratively
# native argument to make this happen.
if @types == 2 && $num_prim == 1 && $num_allo == 1 {
my int $prim_flag := @flags[0] || @flags[1];
my int $allo_idx := @allomorphs[0] ?? 0 !! 1;
if @allomorphs[$allo_idx] eq @allo_map[$prim_flag] {
@flags[$allo_idx] := $prim_flag +| $ARG_IS_LITERAL;
}
}
# Alternatively, a single arg that is allomorphic will prefer
# the literal too.
if @types == 1 && $num_allo == 1 {
my $rev := %allo_rev{@allomorphs[0]};
@flags[0] := nqp::defined($rev) ?? $rev +| $ARG_IS_LITERAL !! 0;
}
[@types, @flags]
}
method report_inevitable_dispatch_failure($op, @types, @flags, $obj, :$protoguilt) {
my @arg_names;
my int $i := 0;
while $i < +@types {
@arg_names.push(
@flags[$i] == 1 ?? 'int' !!
@flags[$i] == 2 ?? 'num' !!
@flags[$i] == 3 ?? 'str' !!
@types[$i].HOW.name(@types[$i]));
$i := $i + 1;
}
my %opts := nqp::hash();
%opts<protoguilt> := $protoguilt // nqp::hllboolfor(0, "perl6");
%opts<arguments> := @arg_names;
%opts<objname> := $obj.name;
%opts<signature> := nqp::can($obj, 'is_dispatcher') && $obj.is_dispatcher && !$protoguilt ??
multi_sig_list($obj) !!
[try $obj.signature.gist];
$!problems.add_exception(['X', 'TypeCheck', 'Argument'], $op, |%opts);
}
# Signature list for multis.
sub multi_sig_list($dispatcher) {
my @sigs := [];
for $dispatcher.dispatchees {
@sigs.push("\n " ~ $_.signature.gist);
}
@sigs
}
# Visits all of a node's children, and dispatches appropriately.
method visit_children($node, :$skip_selectors, :$resultchild, :$first, :$void_default) {
note("method visit_children $!void_context\n" ~ $node.dump) if $!debug;
my int $r := $resultchild // -1;
my int $i := 0;
my int $n := +@($node);
while $i < $n {
my int $outer_void := $!void_context;
my int $outer_decl := $!in_declaration;
unless $skip_selectors && $i % 2 {
$!void_context := $void_default && ($outer_void || ($r != -1 && $i != $r));
$!in_declaration := $outer_decl || ($i == 0 && nqp::istype($node, QAST::Block));
my $visit := $node[$i];
if nqp::can($visit,'ann') {
if $visit.wanted { $!void_context := 0 }
elsif $visit.sunk { $!void_context := 1 }
elsif $visit.final {
note("Undecided final " ~ $node.HOW.name($node)) if $!debug;
$!void_context := 0; # assume wanted
}
}
else {
note("Non-QAST node visited " ~ $visit.HOW.name($visit)) if $!debug;
}
if nqp::istype($visit, QAST::Op) {
$node[$i] := self.visit_op($visit)
}
elsif nqp::istype($visit, QAST::Want) {
$node[$i] := self.visit_want($visit);
}
elsif nqp::istype($visit, QAST::Var) {
$node[$i] := self.visit_var($visit);
}
elsif nqp::istype($visit, QAST::Block) {
$node[$i] := self.visit_block($visit);
}
elsif nqp::istype($visit, QAST::Stmts) && nqp::elems($visit.list) == 1 && !$visit.named {
self.visit_children($visit,:void_default);
$node[$i] := $visit[0];
}
elsif nqp::istype($visit, QAST::Stmt) || nqp::istype($visit, QAST::Stmts) {
my int $resultchild := $visit.resultchild // +@($visit) - 1;
if $resultchild >= 0 {
self.visit_children($visit, :$resultchild,:void_default);
if !nqp::can($visit,'returns') {
note("Child can't returns! " ~ $visit.HOW.name($visit)) if $!debug;
}
elsif !nqp::can($visit[$resultchild],'returns') {
note("Resultchild $resultchild can't returns! " ~
$visit[$resultchild].HOW.name($visit[$resultchild]) ~
"\n" ~ $node.dump)
if $!debug;
}
else {
$visit.returns($visit[$resultchild].returns);
}
}
}
elsif nqp::istype($visit, QAST::Regex) {
self.poison_var_lowering();
QRegex::Optimizer.new().optimize($visit, $!symbols.top_block, |%!adverbs);
}
elsif nqp::istype($visit, QAST::WVal) {
if $!void_context {
if $visit.ann: 'ok_to_null_if_sunk' {
$node[$i] := $NULL;
}
elsif $visit.has_compile_time_value && $visit.node {
my $value := ~$visit.node;
$value := '""' if $value eq '';
my $suggest := ($visit.okifnil ?? ' (use Nil instead to suppress this warning)' !! '');
unless $value eq 'Nil'
|| $visit.ann('sink-quietly') {
my $thing := nqp::istype($visit.value,
$!symbols.find_in_setting: 'Int')
?? 'integer' !! nqp::istype($visit.value,
$!symbols.find_in_setting: 'Rational')
?? 'rational' !! 'value';
my $warning := qq[Useless use of constant $thing $value in sink context$suggest];
note($warning) if $!debug;
$!problems.add_worry($visit, $warning)
}
}
}
if $visit.value =:= $!symbols.PseudoStash {
self.poison_var_lowering();
}
}
elsif nqp::istype($visit, QAST::ParamTypeCheck) {
self.optimize-param-typecheck: $visit;
}
elsif nqp::istype($visit, QAST::SVal) ||
nqp::istype($visit, QAST::IVal) ||
nqp::istype($visit, QAST::NVal) ||
nqp::istype($visit, QAST::VM)