use Benchmark qw(cmpthese);

my $end = 500_000;
cmpthese( -1,
    {
        plain => sub {
            my $total;
            for(1..$end) {
                $total += 1 / $_;
            }
            $total;
        },
        sub => sub {
            my $total;
            for(1..$end) {
                $total += reciprocal($_);
            }
            $total;
        },
        do => sub {
            my $total;
            for(1..$end) {
                $total += do { 1 / $_ };
            }
            $total;
        },
        do_var => sub {
            my $total;
            for(1..$end) {
                $total += do{ my $int = $_; 1 / $int };
            }
            $total;
        },
    }
);

sub reciprocal {
    my ($int) = @_;
    1 / $int;
}
__END__
         Rate    sub do_var  plain     do
sub    6.60/s     --   -49%   -72%   -72%
do_var 12.9/s    95%     --   -46%   -46%
plain  23.9/s   261%    85%     --     0%
do     23.9/s   261%    85%     0%     --

##</code><code>##

package Inline::Blocks;

use strict;
use warnings;
require Filter::Util::Call;

our $VERSION = '0.01';
our $debug = 0;

# our $callmatch  ||= qr{inline\s+(\w+)\s*\(([^\n]*)\)};      # find inline call
# our $plainmatch ||= 'qr{\b$sub\s*\(([^\n]*)\)}';            # find plain invocation
# our $bodymatch  ||= 'qr{^sub $sub\s*(\{\n.+?\n\})$}ms';     # find sub body
# our $declmatch  ||= qr{^inline\s+sub\s+(\w+)\s*(?:;|\{)}ms; # find sub declaration

my $callmatch  = qr{inline\s+(\w+)\s*\(([^\n]*)\)};      # find inline call
my $plainmatch = 'qr{\b$sub\s*\(([^\n]*)\)}';            # find plain invocation 
my $bodymatch  = 'qr{^sub $sub\s*(\{\n.+?\n\})$}ms';     # find sub body
my $declmatch  = qr{^inline\s+sub\s+(\w+)\s*(?:;|\{)}ms; # find sub declaration

sub import {
    shift if $_[0] eq __PACKAGE__;
    @_ % 2 and die "odd number of arguments passed to ".__PACKAGE__.
        '->import, aborted';
    my %args = @_;
    my $callmatch  = delete $args{callmatch}  || $callmatch;
    my $plainmatch = delete $args{plainmatch} || $plainmatch;
    my $bodymatch  = delete $args{bodymatch}  || $bodymatch;
    my $declmatch  = delete $args{declmatch}  || $declmatch;
    my $debug      = delete $args{debug}      || $debug;
    %args and die "unknown import parameters found (",join(", ",keys %args),
        ") - aborted";
        
    my $done;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;
            my $status; 
            my $data;
            while (($status = Filter::Util::Call::filter_read()) > 0) {
                /^__(?:END|DATA)__\r?$/ and last;
                $data .= $_; $_ = '';
            }   
            $_ = $data;
            while (/$declmatch/g) {
                my $match = $&;
                my $sub   = $1;
                s/inline\s+sub/sub/ms;
                my $re = eval $bodymatch;
                my ($text) = /$re/;
                $text or die "Couldn't find subroutine body for sub $sub\n";
                print "sub body: '$text'\n" if $debug;
                $text =~ /\breturn\b/
                    and die "return statement found in sub '$sub'! Read the documentation.\n";
                my $plain = eval $plainmatch;
                while(/$plain/) {
                    my $match = $&;
                    my $args = $1;
                    (my $repl = $text) =~ s/=\s*\@_/= ($args)/;
                    s/\Q$match\E/do $repl/;
                }   
                (my $repl  = $match) =~ s/\w+\s+//;
                s/$match/$repl/;
            }   
            while (/$callmatch/g) {
                my $match = $&;
                my $sub   = $1;
                my $args  = $2;
                print "matched subcall: '$match' sub '$sub' args '$args'\n" if $debug;
                my $re = eval $bodymatch;
                my ($text) = /$re/;
                $text or die "Couldn't find subroutine body for sub $sub\n";
                $text =~ /\breturn\b/
                    and die "return statement found in sub '$sub'! Read the documentation.\n";
                print "sub body: '$text'\n" if $debug;
                $text =~ s/=\s*\@_/= ($args)/;
                s/\Q$match\E/do $text/;
            } 
            print "=== BEGIN ===\n$_\n=== END ===\n" if $debug;
            $done = 1;
        }
    );
}       
1;          
__END__     
=head1 NAME     

Inline::Blocks - inline subroutine bodies as do { } blocks

=head1 SYNOPSIS

  # inline sub at marked locations

  use Inline::Blocks;
  sub sum_reciprocals_to {
      my ($end) = @_;
      my $total = 0;
      for my $int ( 1 .. $end ) {
          $total += inline reciprocal($int);
      }
      return $total;
  }
  sub reciprocal {
      1 / $int;
  }

  # inline sub at every sub call

  use Inline::Blocks;
  sub sum_reciprocals_to {
      my ($end) = @_;
      my $total = 0;
      for my $int ( 1 .. $end ) {
          $total += reciprocal($int);
      }
      return $total;
  }
  inline sub reciprocal {
      1 / $int;
  }

  # both deparse with -MO=Deparse as

  use Inline::Blocks;
  sub sum_reciprocals_to {
      my($end) = @_;
      my $total = 0;
      foreach my $int (1 .. $end) {
          $total += do {
              1 / $int
          };
      }
      return $total;
  }
  sub reciprocal {
      1 / $int;
  }

  # roll your own declmatch, turn on debug

  use Inline::Blocks (
      declmatch => qr{^metastasize\s+sub\s+(\w+)\s*(?:;|\{)}ms,
      debug => 1,
  );
  metastasize sub capitalize_next;

=head1 DESCRIPTION

This is a module for inlining subroutines as C<do> blocks for performance reasons
implemented as a source filter. It is not a fully fledged macro expansion module.

This module provides a new keyword, C<inline> by default, which is used to prefix
either subroutine calls or subroutine declarations/definitions.

If a subroutine declaration or definition is marked as C<inline>, all instances of
subroutine calls are replaced with a C<do> block containing the subroutine's body.

If a subroutine isn't declared als inlined, only the calls to that sub marked as 
C<inline> are transformed into C<do> blocks, other instances are left as is.

=head2 Conventions

Currently, only plain named subroutines can be inlined (but see "Overriding" below).

This means that subroutines which prototypes or attributes are not suitable for
inlining.

Inlineable subroutines MUST NOT use C<return>, since in a C<do> block this would 
cause a return from the inlinee, i.e. return from a sub which uses inlined code. 

The return value is the latest statement of the subroutine. For subs with multiple
return points, use a variable to assign it the value and arrange your code so that
it always reaches the last subroutine statement which contains the variable.

A subroutine block is used textually, as is, so identifiers not private to the
subroutine will be those of the scope into which that block is inlined. Subroutines
which are closures are not suitable for inlining, e.g. this

  {
  my $bottom = 7;
  sub height {
      my ($rise) = @_;
      $bottom + $rise;
  }
  }

will not use the value 7 as C<$bottom>, and compilation will fail under C<use strict>
if there's no C<$bottom> present in the scope of the inlined call.

If parameters are passed into the subroutine, those need to be assigned to
variables in LIST context:

    my ($foo, $bar) = @_;

Inlining will substitute C<@_> with the subroutine call parameters:

    # before inlining
    $result = subcall($foo, $bar);

    # after inlining
    $result = do {
        my ($x,$y) = ($foo, $bar);
        ... # subroutine body here
    };

As is, the regular expression to handle inlined sub calls only detects a single
list as parameters i.e.

    \((s[^\n].*)\)

which means that a parameter list must begin and end on the same line. Multiline 
parameter lists are not supported (but see "Overriding Conventions" below).

Any EXPR used as subroutine call parameter must be resolvable in the context where
inlining takes place.

=head2 Overriding Conventions

You may want to provide your own, more sophisticated filtering regexps according 
to your coding conventions. To that end, you may pass in the following named
parameters along with their values to import, which will override the builtins:

=over 4

=item callmatch

Compiled regular expression (via C<qr> - see perlop) used to match inlined
subroutine calls. Default:

  qr{inline\s+(\w+)\s*\(([^\n]*)\)};

This matches the inlined sub's name and its parameter list in $1 and $2.

=item plainmatch

String containing a single C<qr> call which will be eval'ed by the filter.
It must contain the string '$sub' which - after being eval'ed -will hold the
current subroutine's name during the filtering process. Default:

  'qr{\b$sub\s*\(([^\n]*)\)}'

This matches plain (without 'subroutine' prefix) calls to subroutines declared
as inline subs.

=item declmatch

Compiled regular expression (via C<qr> - see perlop) used to match subroutine
declarations or definitions prefixed with the C<inline> keyword. Default:

  qr{^inline\s+sub\s+(\w+)\s*(?:;|\{)}ms

=item bodymatch

String containing a single C<qr> call which will be eval'ed by the filter.
It must contain the string '$sub' which - after being eval'ed -will hold the
current subroutine's name during the filtering process. Default:

  'qr{^sub $sub\s*(\{\n.+?\n\})$}ms'

=back

Additionaly, you can pass in the keyword 'debug' with a true value, which will
print diagnostics to STDERR.

=head1 CAVEATS AND BENEFITS

Standard caveats and frowning towards source filters apply.

Keywords meaningful inside subroutines may not do what you expect - namely
C<return>, C<caller> and C<wantarray>.

Since the overhead of calling a named subroutine over fully inlined code (without
even a C<do> block around) is roughly that of calculating seven integer reciprocals,
most performance benefits are obtained with simple and heavily used subroutines. 

For the example in the SYNOPSIS, inlining as C<do> blocks without assingning shows
a performance boost of roughly 100% against the same code with subroutine calls, 
while C<do> blocks with assignment of arguments to private variables measures as 
a 50% increase.

=head1 SEE ALSO

  Filter::Util::Call

=head1 AUTHOR

shmem, E<lt>shmem@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2018 by shmem

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.20.2 or,
at your option, any later version of Perl 5 you may have available.

=cut

##</code><code>##

use Inline::Blocks;

inline sub capitalize_next;

print uppercaseIncrementAsString('a'..'f'), "\n";

sub uppercaseIncrementAsString {
    my @l = @_;
    my $ret;
    $ret .= capitalize_next($_) for @l;
    $ret;
}

sub capitalize_next {
    my ($thing) = @_;
    uc inline increase($thing);
}
sub increase {
    my ($foo) = @_;
    ++$foo;
}

##</code><code>##

use Inline::Blocks;
print uppercaseIncrementAsString(('a', 'b', 'c', 'd', 'e', 'f')), "\n";
sub uppercaseIncrementAsString {
    my(@l) = @_;
    my $ret;
    $ret .= do {
        my($thing) = $_;
        uc do {
            my($foo) = $thing;
            ++$foo
        }
    } foreach (@l);
    $ret;
}
sub capitalize_next {
    my($thing) = @_;
    uc do {
        my($foo) = $thing;
        ++$foo
    };
}
sub increase {
    my($foo) = @_;
    ++$foo;
}