Skip to content

Commit

Permalink
import optimize 0.02 from CPAN
Browse files Browse the repository at this point in the history
git-cpan-module:   optimize
git-cpan-version:  0.02
git-cpan-authorid: ABERGMAN
git-cpan-file:     authors/id/A/AB/ABERGMAN/optimize-0.02.tar.gz
  • Loading branch information
Artur Bergman authored and Reini Urban committed Feb 27, 2011
1 parent bb7ca1e commit 5fa9f78
Show file tree
Hide file tree
Showing 7 changed files with 156 additions and 113 deletions.
2 changes: 1 addition & 1 deletion Build.PL
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ my $build = Module::Build->new
requires =>
{
Hook::Scope => '0.02',
'B::Generate' => '1.03',
'B::Generate' => '1.05',
'optimizer' => '0.02',
'perl' => '5.8',
}
Expand Down
6 changes: 6 additions & 0 deletions Changes
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
Revision history for Perl extension optimize

0.02 Fri Jun 28 00:22:01 CEST 2002
- Added register() and unregister() functions to
allow third party modules to hook into
optimize
3 changes: 3 additions & 0 deletions MANIFEST
Original file line number Diff line number Diff line change
Expand Up @@ -3,8 +3,11 @@ Makefile.PL
META.yaml
README
MANIFEST
Changes
lib/optimize.pm
lib/optimize/int.pm
lib/optimize/tie.pm
t/02-register.t
t/10-int.t
t/11-integer.t

Expand Down
4 changes: 2 additions & 2 deletions META.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -6,8 +6,8 @@ license: unknown
name: optimize
recommends: {}
requires:
B::Generate: 1.03
B::Generate: 1.05
Hook::Scope: 0.02
optimizer: 0.02
perl: 5.8
version: 0.01
version: 0.02
138 changes: 28 additions & 110 deletions lib/optimize.pm
Original file line number Diff line number Diff line change
Expand Up @@ -8,13 +8,14 @@ use B::Utils qw(walkallops_simple);
use B qw(OPf_KIDS OPf_MOD OPf_PARENS OPf_WANT_SCALAR OPf_STACKED);
use Attribute::Handlers;
use Hook::Scope qw(POST);
our $VERSION = 0.01;
our $VERSION = 0.02;

our %pads;
our $state;
our $old_op;
our %loaded;
our $stash;
our %register;
use optimizer "extend-c" => sub {
my $op = shift;
POST { $old_op = $op };
Expand All @@ -23,7 +24,7 @@ use optimizer "extend-c" => sub {
$stash = $state->stash->NAME;
# print $state->file . ":" . $state->line . "-" . $state->stash->NAME . "\n";;
}
if($stash =~/^(optimize|B::)/) {
if($stash =~/^(optimize|B::|type|float|int)/) {
# print "Don't optimize ourself\n";
return;
}
Expand Down Expand Up @@ -96,121 +97,30 @@ use optimizer "extend-c" => sub {
$_->check($op);
# print "Called $_\n";
}


if($op->name eq 'sassign') {
my $dst = $state->next->next;
my $src = $state->next;
if($dst->name eq 'padsv' && $dst->next->name eq 'sassign') {
my $cv = $op->find_cv();
if(exists($pads{$cv->ROOT->seq}) &&
exists($pads{$cv->ROOT->seq}->[$dst->targ]) &&
$pads{$cv->ROOT->seq}->[$dst->targ]->[1]->{tied}
) {
# print "sassign tied optimization possible\n";


# return;
my $n = $op->next;
# $op->next(0);
$op->first(0);
$op->null();
# $op->dump();

my $pushmark = B::OP->new("pushmark",2);
$state->next($pushmark);
$pushmark->next($dst);
$pushmark->seq(optimizer::op_seqmax_inc());
my $tied = B::UNOP->new('tied',38,$dst);
$tied->seq(optimizer::op_seqmax_inc());
$pushmark->sibling($tied);
# $dst->flags(50);
$dst->next($tied);
$tied->next($src);
$tied->sibling($src);
# $src->flags(34);

my $method_named = B::SVOP->new('method_named',0,"STORE");
$method_named->seq(optimizer::op_seqmax_inc());
$src->next($method_named);
$src->sibling($method_named);


my $entersub = B::UNOP->new('entersub',69,0);
$entersub->seq(optimizer::op_seqmax_inc());
$method_named->next($entersub);
$entersub->next($n);
$entersub->first($pushmark);
$state->sibling($entersub);

if($n->flags & OPf_KIDS) {
my $no_sibling = 1;
for (my $kid = $n->first; $$kid; $kid = $kid->sibling) {
if($kid->seq == $entersub->seq) {
$no_sibling = 0;
last;
}
}
if($no_sibling) {
$entersub->sibling($n);
}
} else {
$entersub->sibling($n);
}
# print $tied->next->name . "\n";
# print $src->next->name . "\n";
# print $dst->next->name . "\n";

if(exists($register{$stash})) {
for my $callback (values %{$register{$stash}}) {
if($callback) {
$callback->($op);
}
}
} elsif($op->name eq 'padsv' && !($op->flags & OPf_MOD)) {
my $cv = $op->find_cv();
if(exists($pads{$cv->ROOT->seq}) &&
exists($pads{$cv->ROOT->seq}->[$op->targ]) &&
$pads{$cv->ROOT->seq}->[$op->targ]->[1]->{tied}
) {
# print $old_op->seq . " - " . $state->seq . "\n";
# $old_op->dump();
# $op->dump();
my $sibling = $op->sibling();

my $pushmark = B::OP->new("pushmark",2);
my $n = $op->next();
$old_op->next($pushmark);
$pushmark->seq(optimizer::op_seqmax_inc());
$pushmark->next($op);
$op->sibling(0);
my $tied = B::UNOP->new('tied',38,$op);
$pushmark->sibling($tied);
$op->next($tied);
my $method_named = B::SVOP->new('method_named',OPf_WANT_SCALAR,"FETCH");
$tied->sibling($method_named);
# $tied->seq(optimizer::op_seqmax_inc());
$tied->next($method_named);
my $entersub = B::UNOP->new('entersub',OPf_WANT_SCALAR| OPf_PARENS | OPf_STACKED,0);
# $method_named->seq(optimizer::op_seqmax_inc());
$method_named->next($entersub);
$entersub->first($pushmark);
# $entersub->seq(optimizer::op_seqmax_inc());
$entersub->next($n);
$entersub->sibling($sibling);
$n->next->first($entersub);
# $old_op->sibling($entersub);
}
}

};

sub register {
my $class = shift;
my $callback = shift;
my $package = shift;
my ($name) = (caller)[0];
$register{$package}->{$name} = $callback;
}


#CHECK {
# push @B::Utils::bad_stashes, "optimize",'Attribute::Handlers','B::Generate','attributes','lib','constant','UNIVERSAL';
# walkallops_simple(\&callback);
#}

#my %pads;
#my $state;

sub unregister {
my $class = shift;
my $package = shift;
my ($name) = (caller)[0];
$register{$package}->{$name} = 0;
}

sub UNIVERSAL::optimize : ATTR {

Expand All @@ -228,6 +138,14 @@ optimize - Pragma for hinting optimizations on variables
$int += 1;
if($int == 2) { print "$int is integerized" }
#Following will call this callback with the op
#as the argument if you are in the specified package
#see types.pm how it is used from import and unimport
optimize->register(\&callback, $package);
#and reverse it
optimize->unregister($package);
=head1 DESCRIPTION
optimize allows you to use attributes to turn on optimizations.
Expand Down
103 changes: 103 additions & 0 deletions lib/optimize/tie.pm
Original file line number Diff line number Diff line change
@@ -0,0 +1,103 @@

if($op->name eq 'sassign') {
my $dst = $state->next->next;
my $src = $state->next;
if($dst->name eq 'padsv' && $dst->next->name eq 'sassign') {
my $cv = $op->find_cv();
if(exists($pads{$cv->ROOT->seq}) &&
exists($pads{$cv->ROOT->seq}->[$dst->targ]) &&
$pads{$cv->ROOT->seq}->[$dst->targ]->[1]->{tied}
) {
# print "sassign tied optimization possible\n";


# return;
my $n = $op->next;
# $op->next(0);
$op->first(0);
$op->null();
# $op->dump();

my $pushmark = B::OP->new("pushmark",2);
$state->next($pushmark);
$pushmark->next($dst);
$pushmark->seq(optimizer::op_seqmax_inc());
my $tied = B::UNOP->new('tied',38,$dst);
$tied->seq(optimizer::op_seqmax_inc());
$pushmark->sibling($tied);
# $dst->flags(50);
$dst->next($tied);
$tied->next($src);
$tied->sibling($src);
# $src->flags(34);

my $method_named = B::SVOP->new('method_named',0,"STORE");
$method_named->seq(optimizer::op_seqmax_inc());
$src->next($method_named);
$src->sibling($method_named);


my $entersub = B::UNOP->new('entersub',69,0);
$entersub->seq(optimizer::op_seqmax_inc());
$method_named->next($entersub);
$entersub->next($n);
$entersub->first($pushmark);
$state->sibling($entersub);

if($n->flags & OPf_KIDS) {
my $no_sibling = 1;
for (my $kid = $n->first; $$kid; $kid = $kid->sibling) {
if($kid->seq == $entersub->seq) {
$no_sibling = 0;
last;
}
}
if($no_sibling) {
$entersub->sibling($n);
}
} else {
$entersub->sibling($n);
}
# print $tied->next->name . "\n";
# print $src->next->name . "\n";
# print $dst->next->name . "\n";

}
}
} elsif($op->name eq 'padsv' && !($op->flags & OPf_MOD)) {
my $cv = $op->find_cv();
if(exists($pads{$cv->ROOT->seq}) &&
exists($pads{$cv->ROOT->seq}->[$op->targ]) &&
$pads{$cv->ROOT->seq}->[$op->targ]->[1]->{tied}
) {
# print $old_op->seq . " - " . $state->seq . "\n";
# $old_op->dump();
# $op->dump();
my $sibling = $op->sibling();

my $pushmark = B::OP->new("pushmark",2);
my $n = $op->next();
$old_op->next($pushmark);
$pushmark->seq(optimizer::op_seqmax_inc());
$pushmark->next($op);
$op->sibling(0);
my $tied = B::UNOP->new('tied',38,$op);
$pushmark->sibling($tied);
$op->next($tied);
my $method_named = B::SVOP->new('method_named',OPf_WANT_SCALAR,"FETCH");
$tied->sibling($method_named);
# $tied->seq(optimizer::op_seqmax_inc());
$tied->next($method_named);
my $entersub = B::UNOP->new('entersub',OPf_WANT_SCALAR| OPf_PARENS | OPf_STACKED,0);
# $method_named->seq(optimizer::op_seqmax_inc());
$method_named->next($entersub);
$entersub->first($pushmark);
# $entersub->seq(optimizer::op_seqmax_inc());
$entersub->next($n);
$entersub->sibling($sibling);
$n->next->first($entersub);
# $old_op->sibling($entersub);
}
}

};
13 changes: 13 additions & 0 deletions t/02-register.t
Original file line number Diff line number Diff line change
@@ -0,0 +1,13 @@

use Test::More tests=> 9;
use optimize;

package foo;
BEGIN { optimize->register(sub { Test::More::pass() }, "bar")};
$i++;
package bar;
$i++;
$i++;
$i++;
package yeah;
$i++;

0 comments on commit 5fa9f78

Please sign in to comment.