Perl：使用尾调用优化以递归方式查找数组的总和

Question

我正在尝试制作尾部优化的递归函数。

sub sum {
    my ($first, @rest) = @_;

    return @rest
        ? $first + sum(@rest)
        : $first;
}

say sum(1 .. 100);

它适用于100个元素，但是对于带有Out of memory消息的100_000个元素，它会失败。

如何改进代码以使递归与更多元素一起工作？

编辑

尾调用以上功能的优化版：

use feature qw( current_sub );

sub sum_tco {
    my $loop = sub {
        my ($sum, $first, @rest) = @_;
        $sum += $first;

        return @rest
            ? __SUB__->($sum, @rest)
            : $sum;
    };

    return $loop->(@_);
}

Perl 5似乎不支持TCO。

如何在Perl中进行TCO（如果可能）？

Answer 1

Perl不执行尾调用优化是正确的。

如果你有一个尾调，你可以自己优化它。 但话虽如此，你没有尾调。 递归调用之后是添加。

所以让我们从更改sub开始只有尾调用。 这是通过传递执行最后一次操作所需的信息来完成的。

sub _sum {
   my ($acc, $first, @rest) = @_;
   $acc += $first;
   return @rest ? _sum( $acc, @rest ) : $acc;
}

sub sum {
   my (@rest) = @_;
   return undef if !@rest;
   return _sum( 0, @rest );
}

现在我们可以执行尾调用优化。

1. 将递归子例程的主体放在无限循环中。
2. 用do { @_ = ...; next; }替换recurse(...) do { @_ = ...; next; } do { @_ = ...; next; } do { @_ = ...; next; } 。

首先是助手。

sub _sum {
   while (1) {
      my ($acc, $first, @rest) = @_;
      $acc += $first;
      if (@rest) {
         @_ = ( $acc, @rest );
      } else {
         return $acc;
      }
   }
}

sub sum {
   my (@rest) = @_;
   return undef if !@rest;
   return _sum( 0, @rest );
}

然后在主要子。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   @_ = ( 0, @rest );
   while (1) {
      my ($acc, $first, @rest) = @_;
      $acc += $first;
      if (@rest) {
         @_ = ( $acc, @rest );
      } else {
         return $acc;
      }
   }
}

完成。

...有点儿。 我们现在可以做很多其他的清理和优化。

让我们从改善流程开始。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   @_ = ( 0, @rest );
   while (1) {
      my ($acc, $first, @rest) = @_;
      $acc += $first;
      return $acc if !@rest;

      @_ = ( $acc, @rest );
   }
}

无需在每次循环中创建新的$acc 。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   my $acc = 0;
   while (1) {
      my ($first, @rest) = @_;
      $acc += $first;
      return $acc if !@rest;

      @_ = @rest;
   }
}

没有必要再使用@_了。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   my $acc = 0;
   while (1) {
      (my $first, @rest) = @rest;
      $acc += $first;
      return $acc if !@rest;
   }
}

让我们替换昂贵的列表分配。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   my $acc = 0;
   while (1) {
      my $first = shift(@rest);
      $acc += $first;
      return $acc if !@rest;
   }
}

让我们简化循环。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   my $acc = 0;
   while (@rest) {
      my $first = shift(@rest);
      $acc += $first;
   }

   return $acc;
}

让我们用更便宜的foreach循环替换while循环。

sub sum {
   my (@rest) = @_;
   return undef if !@rest;

   my $acc = 0;
   for my $first (@rest) {
      $acc += $first;
   }

   return $acc;
}

$first和@rest不再是合适的变量名。 我们将在这个过程中摆脱一个无用的@_副本。

sub sum {
   return undef if !@_;

   my $acc = 0;
   $acc += $_ for @_;
   return $acc;
}

如果我们将$acc初始化$acc undef ，则不再需要初始检查。

sub sum {
   my $acc;
   $acc += $_ for @_;
   return $acc;
}

田田！

Answer 2

这是使用我在评论中提到的goto功能的TCO版本：

#!/usr/bin/env perl
use warnings;
use strict;
use feature qw/say/;

sub sum {
    return undef if @_ == 0;
    return $_[0] if @_ == 1;
    splice @_, 0, 2, $_[0] + $_[1];
    goto ∑
}

say sum(1..100);
say sum(1..100_000);

从文档 ：

goto和NAME表单与其他形式的goto完全不同。 事实上，它根本不是正常意义上的结果，并且没有与其他结果相关的耻辱感。 相反，它退出当前子例程（丢失由本地设置的任何更改）并立即使用@_的当前值调用命名子例程

我不建议实际使用它，因为它真的，非常慢，相比其他任何东西，但它可以做到。

Answer 3

这是一种使用通用run - recur接口的技术。 这实际上是一个蹦床 -

sub recur (*@values) {
  :{ 'recur' => &recur, 'values' => @values }
}

sub run (&f) {
  my $r = &f();
  while $r.isa(Hash) && $r{'recur'} === &recur {
    $r = &f(|$r{'values'});
  }
  return $r;
}

要使用它，我们传递一个子程序来run循环参数及其初始值 -

sub sum ($n = 0) {
  run (sub ($m = $n, $r = 0) {
    if $m == 0 {
      return $r;
    }
    else {
      recur($m - 1, $r + $m);
    }
  })
}

注意我们使用recur和更新的参数，而不是直接调用sum 。 这是输出 -

say sum(100_000);
# 100_000 + 99_999 + 99_997 + ... + 3 + 2 + 1 =
# => 5000050000

# cpu time: 10.61 sec

在这里，它正在研究范围。 我们使用循环变量来跟踪范围索引， $i和返回值$r -

sub sum (@range) {
  run (sub ($i = 0, $r = 0) {
    if $i >= @range {
      return $r;
    }
    else {
      recur($i + 1, $r + @range[$i]);
    }
  })
}

say sum(5..10);
# 5 + 6 + 7 + 8 + 9 + 10 =
# => 45

say sum(0..0);
# => 0

say sum(1..100_000);
# => 5000050000

# cpu time: 14.37 sec

此处介绍的其他技术要求您大幅更改程序以避免堆栈溢出。 独特的run - recur接口允许您递归地思考问题并允许它在恒定的空间中运行。

---

这是与Perl 5兼容的版本。令我惊讶的是，这个程序快了近50倍。 也许减速是由于较新的语法糖的执行不力？ 这是任何人的猜测......

use strict;
use warnings;

sub recur {
  { recur => \&recur, values => \@_ }
}

sub run {
  my ($f, @init) = @_;
  my $r = &{$f}(@init);
  while (ref $r eq ref {} && $r->{'recur'} == \&recur) {
    $r = &{$f}(@{$r->{'values'}});
  }
  return $r;
}

sub sum {
  my ($n) = @_;
  run (sub {
    my ($m, $r) = @_;
    if ($m == 0) {
      return $r;
    }
    else {
      recur($m - 1, $r + $m);
    }
  }, $n, 0);
}

print sum(100_000);
# => 5000050000

# cpu: 0.25 sec
# mem: 3 Mb

并且采用范围输入的sum变量 -

sub sum {
  my (@range) = @_;
  run (sub {
    my ($i, $r) = @_;
    if ($i >= @range) {
      return $r;
    }
    else {
      recur($i + 1, $r + $range[$i]);
    }
  }, 0, 0);
}

print sum(1..100_000);
# => 5000050000

# cpu: 0.27 sec
# mem: 12 Mb

Answer 4

在这篇文章的启发下，一个文件调用自身的参数数量减少： 一个简单的perl递归示例 。

当然，这远非实际的解决方案。

#!/usr/bin/perl
use strict;
use warnings;
use feature qw(say);

# Init the args at the first call
if (!@ARGV) {exec join(' ', $^X, $0, 1 .. 100_000)}

# Show progress
if (@ARGV % 100 == 0) {say scalar @ARGV}

my ($sum, $first, @rest) = @ARGV;
$sum += $first;

@rest
    ? exec join(' ', $^X, $0, $sum, @rest)
    : say $sum;