optimize.pm

use strict;

package optimize;
use Carp; BEGIN { eval { croak "hi\n" }}
use B::Generate;
use B::Utils qw(walkallops_simple);
use B qw(OPf_KIDS OPf_MOD OPf_PARENS OPf_WANT_SCALAR OPf_STACKED);
use Attribute::Handlers;

our $VERSION = "0.05";

our $DEBUG = 0;
our %pads;
our $state;
our %loaded;
our $stash = '';
our %register;

sub dbgprint { print @_ if $DEBUG; }

use optimizer "extend-c" => sub {
    my $op = shift;
    return unless $op;

    if ($op->name eq 'nextstate') {
	$state = $op;
	$stash = $state->stash->NAME;
        dbgprint $state->file . ":" . $state->line . " " . $state->stash->NAME . "\n";
        if ($stash =~ /^(optimize|B::|types$|float$|double$|int$|number$|^O$|^DB$)/) {
            dbgprint "Don't optimize ourself $stash\n";
            return;
        }
    }

    dbgprint ref($op)." - " . $op->name . " -> " . ref($op->next) . " - " . 
             ($op->next->can('name') ? $op->next->name : "null") . "\n";
    my $cv;
    eval {
	$cv = $op->find_cv;
    };
    if ($@) {
	$@ =~ s/\n//;
	print "$@ in " . $state->file . ":" . $state->line . "\n";;
	return;
    }

    # $DB::single = 1 if defined &DB::DB;
    # const $foo with attributes:
    # pb -MO=Concise,-exec -e'my $foo : optimize(int) = 1.5;'
    # pb -MO=Deparse -e'my $foo : optimize(int) = 1.5;'
    #   ('attributes'->import('main', \$foo, 'optimize(int)'), my $foo) = 1.5;
    dbgprint "sv: ",ref($op->sv),"\n" if $op->name eq 'const';
    if ($op->name eq 'const' && 				
	ref($op->sv) =~ /^B::(P|G)V$/ 	# GV threaded, PV not-threaded
       )  
    { 
	#dbgprint "const: ",$op->sv->sv,"\n";
	if ($op->next->next->name eq 'padsv') {
	    #dbgprint "padsv ->",
	    #  $op->next->next->next,"->",$op->next->next->next->next->name, "\n";
	    if ($op->next->next->next->next->name eq 'srefgen') {
		#dbgprint "srefgen ->", $op->next->next->next->next->next->name, "\n";
		if ($op->next->next->next->next->next->name eq 'const') {
		    #dbgprint "const ->", $op->next->next->next->next->next->name, "\n";
		    if ($op->next->next->next->next->next->next->name eq 'method_named') {
			#dbgprint "method: ", $op->next->next->next->next->next->next->name,":", 
			#  $op->next->next->next->next->next->next->sv->sv, "\n";
			if ($op->next->next->next->next->next->next->sv->sv eq 'import') {

        # Here we establish that this is an use of attributes on lexicals
        # however we want to establish what attribute it is
	my $attribute = $op->next->next->next->next->next->sv->sv;
	dbgprint "my const $attribute\n"; # fails threaded
	
	if ($attribute =~/^optimize\(\s*(.*)\s*\)/) {
            #dbgprint "attr: $attribute\n";
	    my @attributes = split /\s*,\s*/, $1;
            dbgprint "GOT " . join("-", @attributes) . "\n";
	    my $opnn = $op->next->next;
	    if ($opnn->name eq 'padsv') {
		my $sv = (($cv->PADLIST->ARRAY)[0]->ARRAY)[$opnn->targ];
		my $ref = $pads{$cv->ROOT->seq}->[$opnn->targ] = [$sv->sv(),{}];
		for (@attributes) {
		    $ref->[1]{$_}++;
		    unless($loaded{$_}) {
			require "optimize/$_.pm";			
			$loaded{$_} = "optimize::$_";
		    }
		}
	    }
	}
			}
		    }
		}
	    }
	}
    }

    for (values %loaded) {	
        dbgprint "$_->check ",$op->name,"\n";
	$_->check($op);
        #dbgprint "Called $_\n";
    }
    # calling types
    if (exists($register{$stash})) {
	for my $callback (values %{$register{$stash}}) {
	    $callback->($op) if $callback;
	}
    }

};

sub register {
    my $class = shift;
    my $callback = shift;
    my $package = shift;
    my ($name) = (caller)[0];
    #$DB::single = 1 if defined &DB::DB; # magic to allow debugging into CHECK blocks
    $register{$package}->{$name} = $callback;
}

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

sub UNIVERSAL::optimize : ATTR {
    ;
}

1;
__END__

=head1 NAME

optimize - Pragma for hinting optimizations on variables

=head1 SYNOPSIS

    use optimize;
    my $int : optimize(int);
    $int = 1.5;
    $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 L<types> how it is used from import and unimport.
    optimize->register(\&callback, $package);

    # and reverse it
    optimize->unregister($package);

=head1 DESCRIPTION

B<optimize> allows you to use attributes to turn on optimizations.
It works as a framework for different optimizations.

=head1 BUGS

optimize usually rewrites the optree, weird and funky things can happen,
different optimizations will be in a different state of readyness

=head1 AUTHOR

Artur Bergman E<lt>abergman at cpan.orgE<gt>

=head1 SEE ALSO

L<optimize::int> L<B::Generate>

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: