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 );
}

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

将递归子例程的主体置于无限循环中。
将recurse(...)替换为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 初始化为 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 &sum;
}

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

来自the documentation：

The goto &NAME form is quite different from the other forms of goto. In fact, it isn't a goto in the normal sense at all, and doesn't have the stigma associated with other gotos. Instead, it exits the current subroutine (losing any changes set by local) and immediately calls in its place the named subroutine using the current value of @_

我实际上不推荐使用这个，因为与其他任何东西相比，它真的非常慢，但是可以做到。

Answer 3

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

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 和 return 值 $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 界面允许您递归地思考您的问题并且允许它运行常量 space.

这是一个与 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

受此 post 启发：A simple perl recursion example.

文件通过减少参数调用自身

当然，这与实际解决方案相去甚远。

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

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

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

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

@rest
    ? exec join(' ', $^X, [=10=], $sum, @rest)
    : say $sum;

Perl：通过尾调用优化递归地查找数组的总和

Perl: Find a sum of an array recursively with tail call optimization

recursion

tail-recursion

perl