File Coverage

blib/lib/optimizer.pm

Criterion	Covered	Total	%
statement	30	112	26.7
branch	7	64	10.9
condition	3	45	6.6
subroutine	9	21	42.8
pod	2	2	100.0
total	51	244	20.9

package optimizer;
use Carp;
use B;
{ no warnings 'redefine';
  use B::Generate;
}
use 5.007002;
use strict;
use warnings;

BEGIN {
  # op_seq workaround for 5.10, store it as package global.
  my $seq = 0;
  if ($] > 5.009) {
    eval q(
      package B::OP;
      sub seq {
        shift;
        @_ ? $optimizer::seq = shift : $optimizer::seq;
      }
    );
  }
}

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

1;
__END__