How do I refactor a recursion occurring in a for loop to make it a tail call?

Question

Consider the recursive subroutine append_until_exhausted. The recursion occurs in the middle of the body. I want to place it at the end for further processing, that is to say a simple tail call (without any optimisation, which in Perl typically involves a goto). You can change anything but the signature of the subroutine and the two helper subroutines.

The algorithms involving numerics look stupid because are a condensation/obfuscation of my real code, but the code execution path/structure of subroutine calls is unchanged.

use 5.032;
use strictures;
use experimental qw(signatures);

# Returns mostly one value, sometimes multiple,
# and an occasional end condition which will cause
# the recursion to end because then the for loop will
# iterate over an empty list.
# This sub is also called from elsewhere,
# do not change, do not inline.
sub some_complicated_computation($foo) { # → ArrayRef[$foo]
    return [] if $foo > 45;
    return $foo % 5
        ? [$foo + 1]
        : [$foo + 2, $foo + 3];
}

# do not inline
sub make_key($foo) { # → Str
    chr(64 + $foo / 5)
}

sub append_until_exhausted($foo, $appendix) { # → HashRef[ArrayRef[$foo]]
    my $computed = some_complicated_computation($foo);
    for my $new_foo ($computed->@*) {
        {
            push $appendix->{make_key $new_foo}->@*, $new_foo;
        }
        __SUB__->($new_foo, $appendix);
    }
    return $appendix;
}

my $new_appendix = append_until_exhausted(
    7, # start value for foo
    { dummy => [], dummy2 => [], dummy3 => [], }
);

The goal here is for me to understand the principle so I can apply it in similar situations and in similar languages. It does not help if you suggest some {Sub::*, B::*, XS} magic.

Answer 1

Let's start with a simple example.

sub fact($n) {
   return 1 if $n == 0;
   return $n * fact($n-1);
}

To make something tail-recursive, you need to pass the information needed to perform the tail operation along with the call.

sub _fact($n, $acc) {
   return $acc if $n == 0;
   return _fact($n-1, $n * $acc);
}

sub fact($n) {
   return _fact($n, 1);
}

This particular solution relies on the fact that multiplication is commutative. (We replaced 1*2*3*4 with 1*4*3*2.) So we still need a generic approach.

---

A generic approach would involve passing the tail as a callback. This means that

if (TERMINAL_COND())
   return TERMINAL_VALUE();
} else {
   return TAIL(recursive(HEAD()))
}

becomes

# Extra argument $tail
if (TERMINAL_COND()) {
   return $tail->(TERMINAL_VALUE());   # Tail call
} else {
   return recursive(HEAD(), sub {      # Tail call
      return $tail->(TAIL($_[0]);      # Tail call
   });
}

This gives us the following:

sub _fact($n, $tail) {
   return $tail->(1) if $n == 0;
   return _fact($n-1, sub($fact) {
      return $tail->( $fact * $n );
   });
}

sub fact($n) {
   return _fact($n, sub($fact) { $fact });
}

This is basically how Promises work.

# Promise is a fictional class akin
# to the JS one with the same name.

sub fact_p($n) {
   return Promise->new(1) if $n == 0;
   return fact_p($n-1)->then(sub($fact) {
      return $fact * $n;
   });
}

fact_p($n)->done(sub($fact) {
   say $fact;
});

---

What you have is a lot trickier because you have multiple recursive calls. But we can still apply the same technique.

# Loop body
sub __append_until_exhausted($appendix, $computed, $i, $tail) {
   if ($i == $computed->@*) {
      return $tail->();  # TC
   } else {
      my $new_foo = $computed->[$i];
      push $appendix->{make_key $new_foo}->@*, $new_foo;
      return _append_until_exhausted($appendix, $new_foo, sub {  # TC
         return __append_until_exhausted($appendix, $computed, $i+1, $tail);  # TC
      });
   }
}

# Function body
sub _append_until_exhausted($appendix, $foo, $tail) {
   my $computed = some_complicated_computation($foo);
   return __append_until_exhausted($appendix, $computed, 0, $tail);  # TC
}

# Public interface
sub append_until_exhausted($appendix, $foo) {
   return _append_until_exhausted($appendix, $foo, sub {  # TC
      return $appendix;
   });
}

We can avoid all the extra copies of $appendix as follows:

sub append_until_exhausted($appendix, $foo) {
   local *helper2 = sub($computed, $i, $tail) {
      if ($i == $computed->@*) {
         return $tail->();  # TC
      } else {
         my $new_foo = $computed->[$i];
         push $appendix->{make_key $new_foo}->@*, $new_foo;
         return helper1($new_foo, sub {  # TC
            return helper2($computed, $i+1, $tail);  # TC
         });
      }
   };

   local *helper1 = sub($foo, $tail) {
      my $computed = some_complicated_computation($foo);
      return helper2($computed, 0, $tail);  # TC
   };

   return helper1($foo, sub {  # TC
      return $appendix;
   });
}

---

Perl doesn't perform tail-call elimination, and function calls are rather slow. You'd be better off using an array as a stack.

This performs the work in the same order as the original:

sub append_until_exhausted($foo, $appendix) {
   my @todo = [ $foo, undef, 0 ];
   while (@todo) {
      my $todo = $todo[-1];
      \my ( $foo, $computed, $i ) = \( @$todo );
      $computed //= some_complicated_computation($foo);
      if ($i == $computed->@*) {
         pop(@todo);
         next;
      }

      my $new_foo = $computed->[$i++];
      push $appendix->{make_key $new_foo}->@*, $new_foo;
      push @todo, [ $new_foo, undef, 0 ];
   }

   return $appendix;
}

If you don't mind doing the complicated computation out of order (while still preserving the result), the above simplifies to the following:

sub append_until_exhausted($foo, $appendix) {
   my @todo = some_complicated_computation($foo);
   while (@todo) {
      my $computed = $todo[-1];
      if (!$computed->@*) {
         pop(@todo);
         next;
      }

      my $new_foo = shift(@$computed);
      push $appendix->{make_key $new_foo}->@*, $new_foo;
      push @todo, some_complicated_computation($new_foo);
   }

   return $appendix;
}

Answer 2

Since your recursive call is within a loop, you can't make your function tail-recursive. Well, when some_expensive_computation returns 0 or 1 elements, you can, but as soon as it returns two, it's over.

I'd suggest using a stack instead. Basically, change your sub append_until_exhausted to:

sub append_until_exhausted_stack($init_foo, $appendix) { # → HashRef[ArrayRef[$foo]]
    my @stack = ($init_foo);
    while (@stack) {
        my $foo = pop @stack;
        my $computed = some_complicated_computation($foo);
        for my $new_foo (@$computed) {
            push @{$appendix->{make_key $new_foo}}, $new_foo;
        }
        push @stack, @$computed;
    }
    return $appendix;
}

Small caveat: it does not perform the work in the same order as your original function. If that matters to you, then see Ikegami's answer.

I've quickly benchmarked it, and it appears to be a bit less than 10% faster than the recursive implementation, so not that much. Bencmarking code below:

sub append_until_exhausted($foo, $appendix) { # → HashRef[ArrayRef[$foo]]
    my $computed = some_complicated_computation($foo);
    for my $new_foo (@$computed) {
        {
            push @{$appendix->{make_key $new_foo}}, $new_foo;
        }
        __SUB__->($new_foo, $appendix);
    }
    return $appendix;
}


sub append_until_exhausted_stack($init_foo, $appendix) { # → HashRef[ArrayRef[$foo]]
    my @stack = ($init_foo);
    while (@stack) {
        my $foo = pop @stack;
        my $computed = some_complicated_computation($foo);
        for my $new_foo (@$computed) {
            push @{$appendix->{make_key $new_foo}}, $new_foo;
        }
        push @stack, @$computed;
    }
    return $appendix;
}

use Benchmark qw(:all);

cmpthese(2000, {
         'Recursive' => sub {
             append_until_exhausted(7, { dummy => [], dummy2 => [], dummy3 => [] })},
         'Stack'   => sub {
             append_until_exhausted_stack(7, { dummy => [], dummy2 => [], dummy3 => [] })},
         });

Which yields the following results:

            Rate Recursive     Stack
Recursive 1384/s        --       -8%
Stack     1505/s        9%        --

I've tried optimizing it a bit by adding special cases to avoid pushing something on the stack and removing it right away but it barely impacts the performance (for instance, doing $foo = $computed->[0]; redo when @$computed == 1). Might be worth trying with your actual code though.