Create `defer` syntax and `OP_PUSHDEFER` opcode

Adds syntax `defer { BLOCK }` to create a deferred block; code that is
deferred until the scope exits. This syntax is guarded by

  use feature 'defer';

Adds a new opcode, `OP_PUSHDEFER`, which is a LOGOP whose `op_other` field
gives the start of an optree to be deferred until scope exit. That op
pointer will be stored on the save stack and invoked as part of scope
unwind.

Included is support for `B::Deparse` to deparse the optree back into
syntax.

4 files changed, 332 insertions, 5 deletions

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index b32f18078a..64b66c0e31 100644
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -1160,8 +1160,8 @@ like $@, qr'^Undefined format "STDOUT" called',
   my %nottest_words = map { $_ => 1 } qw(
     AUTOLOAD BEGIN CHECK CORE DESTROY END INIT UNITCHECK
     __DATA__ __END__
-    and catch cmp default do dump else elsif eq eval for foreach format ge
-    given goto grep gt if isa last le local lt m map my ne next no or our
+    and catch cmp default defer do dump else elsif eq eval for foreach format
+    ge given goto grep gt if isa last le local lt m map my ne next no or our
     package print printf q qq qr qw qx redo require return s say sort state
     sub tr try unless until use when while x xor y
   );
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 30f0621f65..514114bfb6 100644
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -15,8 +15,8 @@ BEGIN {
 use B;
 
 my %unsupported = map +($_=>1), qw (
- __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
-  catch cmp default do dump else elsif eq eval for foreach
+ __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK
+  and catch cmp default defer do dump else elsif eq eval for foreach
   format ge given goto grep gt if isa last le local lt m map my ne next
   no  or  our  package  print  printf  q  qq  qr  qw  qx  redo  require
   return s say sort state sub tr try unless until use
diff --git a/t/op/defer.t b/t/op/defer.t
new file mode 100644
index 0000000000..8443ad104b
--- /dev/null
+++ b/t/op/defer.t
@@ -0,0 +1,315 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib');
+}
+
+plan 29;
+
+use feature 'defer';
+no warnings 'experimental::defer';
+
+{
+    my $x = "";
+    {
+        defer { $x = "a" }
+    }
+    is($x, "a", 'defer block is invoked');
+
+    {
+        defer {
+            $x = "";
+            $x .= "abc";
+            $x .= "123";
+        }
+    }
+    is($x, "abc123", 'defer block can contain multiple statements');
+
+    {
+       defer {}
+    }
+    ok(1, 'Empty defer block parses OK');
+}
+
+{
+    my $x = "";
+    {
+        defer { $x .= "a" }
+        defer { $x .= "b" }
+        defer { $x .= "c" }
+    }
+    is($x, "cba", 'defer blocks happen in LIFO order');
+}
+
+{
+    my $x = "";
+
+    {
+        defer { $x .= "a" }
+        $x .= "A";
+    }
+
+    is($x, "Aa", 'defer blocks happen after the main body');
+}
+
+{
+    my $x = "";
+
+    foreach my $i (qw( a b c )) {
+        defer { $x .= $i }
+    }
+
+    is($x, "abc", 'defer block happens for every iteration of foreach');
+}
+
+{
+    my $x = "";
+
+    my $cond = 0;
+    if( $cond ) {
+        defer { $x .= "XXX" }
+    }
+
+    is($x, "", 'defer block does not happen inside non-taken conditional branch');
+}
+
+{
+    my $x = "";
+
+    while(1) {
+        last;
+        defer { $x .= "a" }
+    }
+
+    is($x, "", 'defer block does not happen if entered but unencountered');
+}
+
+{
+   my $x = "";
+
+   my $counter = 1;
+   {
+      defer { $x .= "A" }
+      redo if $counter++ < 5;
+   }
+
+   is($x, "AAAAA", 'defer block can happen multiple times');
+}
+
+{
+    my $x = "";
+
+    {
+        defer {
+            $x .= "a";
+            defer {
+                $x .= "b";
+            }
+        }
+    }
+
+    is($x, "ab", 'defer block can contain another defer');
+}
+
+{
+    my $x = "";
+    my $value = do {
+        defer { $x .= "before" }
+        "value";
+    };
+
+    is($x, "before", 'defer blocks run inside do { }');
+    is($value, "value", 'defer block does not disturb do { } value');
+}
+
+{
+    my $x = "";
+    my $sub = sub {
+        defer { $x .= "a" }
+    };
+
+    $sub->();
+    $sub->();
+    $sub->();
+
+    is($x, "aaa", 'defer block inside sub');
+}
+
+{
+    my $x = "";
+    my $sub = sub {
+        return;
+        defer { $x .= "a" }
+    };
+
+    $sub->();
+
+    is($x, "", 'defer block inside sub does not happen if entered but returned early');
+}
+
+{
+   my $x = "";
+
+   my sub after {
+      $x .= "c";
+   }
+
+   my sub before {
+      $x .= "a";
+      defer { $x .= "b" }
+      goto \&after;
+   }
+
+   before();
+
+   is($x, "abc", 'defer block invoked before tail-call');
+}
+
+# Sequencing with respect to variable cleanup
+
+{
+    my $var = "outer";
+    my $x;
+    {
+        my $var = "inner";
+        defer { $x = $var }
+    }
+
+    is($x, "inner", 'defer block captures live value of same-scope lexicals');
+}
+
+{
+    my $var = "outer";
+    my $x;
+    {
+        defer { $x = $var }
+        my $var = "inner";
+    }
+
+    is ($x, "outer", 'defer block correctly captures outer lexical when only shadowed afterwards');
+}
+
+{
+    our $var = "outer";
+    {
+        local $var = "inner";
+        defer { $var = "finally" }
+    }
+
+    is($var, "outer", 'defer after localization still unlocalizes');
+}
+
+{
+    our $var = "outer";
+    {
+        defer { $var = "finally" }
+        local $var = "inner";
+    }
+
+    is($var, "finally", 'defer before localization overwrites');
+}
+
+# Interactions with exceptions
+
+{
+    my $x = "";
+    my $sub = sub {
+        defer { $x .= "a" }
+        die "Oopsie\n";
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+
+    is($x, "a", 'defer block still runs during exception unwind');
+    is($e, "Oopsie\n", 'Thrown exception still occurs after defer');
+}
+
+{
+    my $sub = sub {
+        defer { die "Oopsie\n"; }
+        return "retval";
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+
+    is($e, "Oopsie\n", 'defer block can throw exception');
+}
+
+{
+    my $sub = sub {
+        defer { die "Oopsie 1\n"; }
+        die "Oopsie 2\n";
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+
+    # TODO: Currently the first exception gets lost without even a warning
+    #   We should consider what the behaviour ought to be here
+    # This test is happy for either exception to be seen, does not care which
+    like($e, qr/^Oopsie \d\n/, 'defer block can throw exception during exception unwind');
+}
+
+{
+    my $sub = sub {
+        while(1) {
+            defer { return "retval" }
+            last;
+        }
+        return "wrong";
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+    like($e, qr/^Can't "return" out of a defer block /,
+        'Cannot return out of defer block');
+}
+
+{
+    my $sub = sub {
+        while(1) {
+            defer { goto HERE }
+        }
+        HERE:
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+    like($e, qr/^Can't "goto" out of a defer block /,
+        'Cannot goto out of defer block');
+}
+
+{
+    my $subA = sub {
+        my $subB = sub {};
+        while(1) {
+            defer { goto &$subB }
+        }
+    };
+
+    my $e = defined eval { $subA->(); 1 } ? undef : $@;
+    like($e, qr/^Can't "goto" out of a defer block at /,
+        'Cannot goto &SUB out of a defer block');
+}
+
+{
+    my $sub = sub {
+        LOOP: while(1) {
+            defer { last LOOP }
+        }
+    };
+
+    my $e = defined eval { $sub->(); 1 } ? undef : $@;
+    like($e, qr/^Can't "last" out of a defer block /,
+        'Cannot last out of defer block');
+}
+
+{
+    # strictness failures are only checked at optree finalization time. This
+    # is a good way to test if that happens.
+    my $ok = eval 'defer { use strict; foo }';
+    my $e = $@;
+
+    ok(!$ok, 'defer BLOCK finalizes optree');
+    like($e, qr/^Bareword "foo" not allowed while "strict subs" in use at /,
+        'Error from finalization');
+}
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 21a6f36dcf..0e1353391b 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -20,7 +20,7 @@ BEGIN {
 use warnings;
 use strict;
 
-plan 2583;
+plan 2584;
 
 use B ();
 
@@ -675,3 +675,15 @@ test_opcount(0, "multiconcat: local assign",
                     concat      => 0,
                     sassign     => 1,
                 });
+
+{
+    use feature 'defer';
+    no warnings 'experimental::defer';
+
+    test_opcount(1, "pushdefer: block is optimized",
+                    sub { my @a; defer { $a[0] } },
+                    {
+                        aelemfast_lex => 1,
+                        aelem         => 0,
+                    });
+}