view release on metacpan or  search on metacpan

optimizer.pm  view on Meta::CPAN

}

require DynaLoader;
our $VERSION = '0.08';
our @ISA = q(DynaLoader);
our %callbacks;
bootstrap optimizer $VERSION;

my ($file, $line) = ("unknown", "unknown");

{
sub _preparewarn {
    my $args = join '', @_;
    $args = "Something's wrong " unless $args;
    $args .= " at $file line $line.\n" unless substr($args, length($args) -1) eq "\n";
}

sub _update {
    my $cop = shift; $file = $cop->file; $line = $cop->line;
}

sub _die (@) { CORE::die(preparewarn(@_)) }
sub _warn (@) { CORE::warn(preparewarn(@_)) }
}

sub import {
    my ($class,$type) = (shift, shift);
    if (!defined $type) {
        CORE::warn("Must pass an action to ${class}'s importer");
        return
    }
    if ($type eq 'C' or $type eq 'c') {
        optimizer::uninstall();
    } elsif ($type =~ /^Perl$/i) {
        optimizer::install( sub { optimizer::peepextend($_[0], sub {}) });
    } elsif ($type eq "callback" or $type eq "extend" or $type eq "mine") {
        my $subref = shift;
        croak "Supplied callback was not a subref" unless ref $subref eq "CODE";
        optimizer::install( sub { callbackoptimizer($_[0], $subref) }) if $type eq "callback";
        optimizer::install( sub { optimizer::peepextend($_[0], $subref) }) if $type eq "extend";
        optimizer::install( $subref ) if $type eq "mine";
    } elsif ($type eq 'extend-c') {
      optimizer::c_extend_install(shift);
    } elsif ($type eq 'sub-detect') {
      my ($package, $filename, $line) = caller;
      $callbacks{$package} = shift;
      optimizer::c_sub_detect_install();
    } else { croak "Unknown optimizer option '$type'"; }
}

sub unimport {
    optimizer::install(sub {callbackoptimizer($_[0], sub{})});
}

sub callbackoptimizer {
    my ($op, $callback) = @_;
    while ($$op) {
	$op->seq(optimizer::op_seqmax_inc());
        _update($op) if $op->isa("B::COP");
	# crashes: wrong op_sv, strange cv
        #_relocatetopad($op, $op->find_cv()) if $op->name eq "const"; # For thread safety

        $callback->($op);
        $op = $op->next;
        last unless $op->can("next"); # Shouldn't get here
    }
}

sub peepextend {
    # Oh boy
    my ($o, $callback) = @_;
    my $oldop = 0;

    return if !$$o or $o->seq;

    op_seqmax_inc() unless op_seqmax();
    while ($$o) {
        #warn ("Trying op $o ($$o) -> ".$o->name."\n");
        if ($o->isa("B::COP")) {
            $o->seq(optimizer::op_seqmax_inc());
            _update($o); # For warnings

        } elsif ($o->name eq "const") {
            optimizer::_die("Bareword ",$o->sv->sv, " not allowed while \"strict subs\" in use")
                if ($o->private & 8);
	    # crashes: wrong op_sv, strange cv
            #_relocatetopad($o, $o->find_cv());
            $o->seq(optimizer::op_seqmax_inc());
        } elsif ($o->name eq "concat") {
            if ($o->next && $o->next->name eq "stringify" and !($o->flags &64)) {
                if ($o->next->private & 16) {
                    $o->targ($o->next->targ);
                    $o->next->targ(0);
                }
                #$o->null;
            }
            $o->seq(optimizer::op_seqmax_inc());
        #} elsif ($o->name eq "stub") {
        #    CORE::die "Eep.";
        #} elsif ($o->name eq "null") {
        #   CORE::die "Eep.";
        } elsif ($o->name eq "scalar" or $o->name eq "lineseq" or $o->name eq "scope") {
            if ($$oldop and ${$o->next}) {
                $oldop->next($o->next);
                $o=$o->next;
                next;
            }
            $o->seq(optimizer::op_seqmax_inc());
        #} elsif ($o->name eq "gv") {
        #    CORE::die "Eep.";
        } elsif ($o->name =~ /^((map|grep)while|(and|or)(assign)?|cond_expr|range)$/) {
            $o->seq(optimizer::op_seqmax_inc());
            $o->other($o->other->next) while $o->other->name eq "null";
            peepextend($o->other, $callback); # Weee.
        } elsif ($o->name =~ /^enter(loop|iter|given|when)/) {
            $o->seq(optimizer::op_seqmax_inc());
            $o->redoop($o->redoop->next) while $o->redoop->name eq "null";
	    peepextend($o->redoop, $callback);
            $o->nextop($o->nextop->next) while $o->nextop->name eq "null";
	    peepextend($o->nextop, $callback);
            $o->lastop($o->lastop->next) while $o->lastop->name eq "null";
	    peepextend($o->lastop, $callback);
        } elsif ($o->name eq "qr" or $o->name eq "match" or $o->name eq "subst") {
            $o->seq(optimizer::op_seqmax_inc());
            $o->pmreplstart($o->pmreplstart->next)
	      while ${$o->pmreplstart} and $o->pmreplstart->name eq "null";
            peepextend($o->pmreplstart, $callback);
        } elsif ($o->name eq "exec") {
            $o->seq(optimizer::op_seqmax_inc());
            if (${$o->next} and $o->next->name eq "nextstate" and
                ${$o->next->sibling} and $o->next->sibling->type !~ /exit|warn|die/) {
                optimizer::_warn("Statement unlikely to be reached");
                optimizer::_warn("\t(Maybe you meant system() when you said exec()?)\n");
            }
        } else {
            # Screw pseudohashes.
            $o->seq(optimizer::op_seqmax_inc());
        }
        my $plop = $o;

        $callback->($o);
        $oldop = $o;
        $o = $o->next;
        last unless $o->can("next"); # Shouldn't get here
    }
}

optimizer.pm  view on Meta::CPAN

Completely implement your own optimizer. You have to provide your own walker and peep.

  use optimizer mine => sub { ... }

=item extend-c

Use the standard optimizer with an extra callback.
This is the most compatible optimizer version.

  use optimizer 'extend-c' => sub { print $_[0]->name() };

=item sub-detect

Don't provide a peep optimizer, rather get a callback
after we are finished with every code block (I<sub>).
You will be passed LEAVE* ops after the standard
peep optimizer has been run, this minimises the risk
for bugs as we use the standard one.

  use optimizer 'sub-detect' => sub { print $_[0]->name() };

=back

=head1 HELPER FUNCTIONS

=over 4

=item callbackoptimizer (this, callback)

The helper function for the option B<callback>.

=item peepextend (this, callback)

The helper function for the option B<extend>.

->import('perl') uses B<peepextend> with an empty callback.

=item c_extend_install

The helper function for the option B<extend-c>.
It uses the longish XS function C<c_extend_peep> as
experimental peeper, and calls the user-side perl callback
for each OP.

=item c_sub_detect_install

The XS helper function for the option B<sub-detect>.
It installs C<c_sub_detect> as C<PL_peep>.
B<c_sub_detect> calls all perl-side callbacks at any LEAVE op.

=item unimport

Override with an empty B<callbackoptimizer>, effectively disabling any
installed optimizer.

=back

=head1 STATUS

relocatetopad fails with threaded perls.

=head1 5.10 Changes

Since Perl 5.10 there are no op_seqmax and op_seq numbers in CORE
anymore, so we add a package global op_seqmax for the op-tree
numbering, for $B::OP::seq also. This is not thread-safe.

=head1 AUTHOR

  Simon Cozens, C<simon@cpan.org>

Extended functionality:

  Artur Bergman, C<abergman@cpan.org>

5.10 support and current maintainer Reini Urban:

  Reini Urban, C<rurban@cpan.org>

=head1 SEE ALSO

L<B::Generate>, L<optimize>

=cut