Merge pull request #1509 from rakudo/rework-dot-equals-opt

Rework dot equals opt

src/Perl6/Actions.nqp

@@ -5603,11 +5603,6 @@ class Perl6::Actions is HLL::Actions does STDActions {
         if $<sym> eq '.^' {
             $past.op('p6callmethodhow');
         }
-        elsif $<sym> eq '.=' {
-            # we'll just mark it for now and wait until we get a
-            # hold of the invocant to prepare the final QAST
-            $past.annotate: 'dot_equals', 1;
-        }
         else {
             $past.unshift($*W.add_string_constant($past.name))
                 if $past.name ne '';
@@ -6622,11 +6617,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
         'R^..^', 1
     );
     method EXPR($/, $KEY?) {
-        unless $KEY {
-            return make make_dot_equals($<dotty>.ast.shift, $<dotty>.ast)
-                if $<dotty><sym> eq '.=' && $<dotty>.ast.ann: 'dot_equals';
-            return 0;
-        }
+        unless $KEY { return 0; }
         my $past := $/.ast // $<OPER>.ast;
         my $key := nqp::lc($KEY // 'infix');
         $key := 'infix' if $key eq 'list';
@@ -6773,10 +6764,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
                     $return_map := 1
                 }
 
-                if $past.ann('dot_equals') {
-                    return make make_dot_equals($past.shift, $past);
-                }
-                elsif $past.name eq 'dispatch:<var>' && ! (
+                if $past.name eq 'dispatch:<var>' && ! (
                        nqp::istype($past[0], QAST::WVal)
                     && nqp::istype($past[0].value,
                       $*W.find_symbol: ['Whatever'], :setting-only)
@@ -9371,33 +9359,14 @@ class Perl6::Actions is HLL::Actions does STDActions {
         )
     }
 
-    sub make_dot_equals($t, $call) {
-        my $target := WANTED($t,'make_dot_equals');
-        my $qast;
-
-        # clear the annotation so we don't double-dot-equals the QAST
-        $call.annotate: 'dot_equals', 0 if $call.ann: 'dot_equals';
-        if nqp::istype($target, QAST::Var) {
-            # we have a plain variable as target. Safe to Just Use It™
-            $call.unshift: $target;
-            $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
-            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.nosink: 1;
-        wantall($qast, 'make_dot_equals');
-        $qast.annotate_self: 'fake_infix_adverb_target', $call;
+    sub make_dot_equals($target, $call) {
+        $call.unshift($*W.add_string_constant($call.name)) if $call.name || !$call.list;
+        $call.unshift(WANTED($target,'make_dot_equals'));
+        $call.name('dispatch:<.=>');
+        $call.op('callmethod');
+        $call.nosink(1);
+        wantall($call, 'make_dot_equals');
+        $call;
     }
 
     sub make_dot($target, $call) {

src/Perl6/Optimizer.nqp

@@ -1354,11 +1354,19 @@ class Perl6::Optimizer {
                  return $opt_result;
             }
         }
-
-        # 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.
-        elsif $!level >= 2 && $optype eq 'callmethod' && $op.name eq 'dispatch:<!>' {
-            self.optimize_private_method_call($op);
+        # 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;
+            }
         }
 
         if $op.op eq 'chain' {
@@ -1385,6 +1393,33 @@ class Perl6::Optimizer {
         $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';

src/core/Mu.pm

@@ -821,6 +821,11 @@ Perhaps it can be found at https://docs.perl6.org/type/$name"
             ).throw;
     }
 
+    method dispatch:<.=>(\mutate: Str() $name, |c) is raw {
+        $/ := nqp::getlexcaller('$/');
+        mutate = mutate."$name"(|c)
+    }
+
     method dispatch:<.?>(Mu \SELF: Str() $name, |c) is raw {
         nqp::can(SELF,$name) ??
             SELF."$name"(|c) !!

t/08-performance/02-qast-rewrites.t

@@ -1,7 +1,7 @@
 use lib <t/packages>;
 use Test::Helpers::QAST;
 use Test;
-plan 1;
+plan 2;
 
 subtest 'postfix-inc/dec on natives gets overwritten to prefix' => {
     plan 8;
@@ -54,3 +54,27 @@ subtest 'postfix-inc/dec on natives gets overwritten to prefix' => {
         and not qast-contains-call v, '&postfix:<-->'
     }, 'num, non-void context --';
 }
+
+
+subtest '.dispatch:<.=> gets rewritten to simple ops' => {
+    plan +my @codes :=
+      ｢(my Int $x .=new).="{"new"}"(42);｣,
+      ｢my Int $x; .=new andthen .=new orelse .=new;｣,
+      ｢my \foo .= new｣,
+      ｢my Int \foo .= new｣,
+      ｢my Int $a; .=new without $a｣,
+      ｢my Int $a; .=new with $a｣,
+      ｢my Int $a; $a .= new｣,
+      ｢my @a; @a .= new｣,   ｢my @a .= new｣,
+      ｢my %a; %a .= new｣,   ｢my %a .= new｣,
+      ｢my &a; &a .= new｣,   ｢my &a .= new｣,
+      ｢my $b = "meows"; $b .= WHAT｣,
+      ｢my @b = <z a b d e>; @b .= sort｣,
+    ;
+
+    for @codes -> \code {
+        qast-is code, -> \v {
+            not qast-contains-callmethod v, 'dispatch:<.=>'
+        }, code;
+    }
+}

t/packages/Test/Helpers/QAST.pm6

@@ -15,6 +15,19 @@ sub qast-contains-op (Mu $qast, Str:D $name --> Bool:D) is export {
     False
 }
 
+sub qast-contains-callmethod (Mu $qast, Str:D $name --> Bool:D) is export {
+    if nqp::istype($qast, QAST::Op)
+    && $qast.op eq 'callmethod' && $qast.name eq $name {
+        return True;
+    }
+    elsif qast-descendable $qast {
+        for $qast.list {
+            qast-contains-call $_, $name and return True;
+        }
+    }
+    False
+}
+
 sub qast-contains-call (Mu $qast, Str:D $name --> Bool:D) is export {
     if nqp::istype($qast, QAST::Op)
     && ( $qast.op eq 'call'  || $qast.op eq 'callstatic'
@@ -169,4 +182,16 @@ Takes a QAST tree and tests whether it has QAST::Op with C<.op> set to
 C<call>, C<callstatic>, C<chain>, or C<chainstatic>, and with C<.name> set
 to C<$name>. Recurses into descendable ops.
 
+=head2 C<qast-contains-callmethod>
+
+Defined as:
+
+    sub qast-contains-callmethod (Mu $qast, Str:D $name --> Bool:D);
+
+Takes a QAST tree and tests whether it has QAST::Op with C<.op> set to
+C<callmethod> and with C<.name> set to C<$name>. Recurses into descendable ops.
+
+B<NOTE:> C<callmethod> op can also take the name as second positional arg.
+This routine does B<NOT> inspect such nodes.
+
 =end pod