File Coverage

blib/lib/Imager/Expr.pm

Criterion	Covered	Total	%
statement	216	266	81.2
branch	63	96	65.6
condition	10	18	55.5
subroutine	20	23	86.9
pod	13	13	100.0
total	322	416	77.4

package Imager::Expr;
use 5.006;
use Imager::Regops;
use strict;

our $VERSION = "1.008";

my %expr_types;

my $error;

sub error {
  shift if UNIVERSAL::isa($_[0], 'Imager::Expr');
  if (@_) {
    $error = "@_";
  }
  else {
    return $error;
  }
}

# what else?
my %default_constants =
  (
   # too many digits, better than too few
   pi=>3.14159265358979323846264338327950288419716939937510582097494
  );

sub new {
  my ($class, $opts) = @_;

  # possibly this is a very bad idea
  my ($type) = grep exists $expr_types{$_}, keys %$opts;
  die "Imager::Expr: No known expression type"
    if !defined $type;
  my $self = bless {}, $expr_types{$type};
  $self->{variables} = [ @{$opts->{variables}} ];
  $self->{constants} = { %default_constants, %{$opts->{constants} || {}} };
  $self->{ops} = $self->compile($opts->{$type}, $opts)
    or return;
  $self->optimize()
    or return;
  $self->{code} = $self->assemble()
    or return;
  $self;
}

sub register_type {
  my ($pack, $name) = @_;
  $expr_types{$name} = $pack;
}

sub type_registered {
  my ($class, $name) = @_;

  $expr_types{$name};
}

sub _variables {
  return @{$_[0]->{variables}};
}

sub code {
  return $_[0]->{code};
}

sub nregs {
  return $_[0]->{nregs};
}

sub cregs {
  return $_[0]->{cregs};
}

my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?';

sub numre {
  $numre;
}

# optimize the code
sub optimize {
  my ($self) = @_;

  my @ops = @{$self->{ops}};

  # this function cannot current handle code with jumps
  return 1 if grep $_->[0] =~ /^jump/, @ops;

  # optimization - common sub-expression elimination
  # it's possible to fold this into the code generation - but it will wait

  my $max_opr = $Imager::Regops::MaxOperands;
  my $attr = \%Imager::Regops::Attr;
  my $foundops = 1;
  while ($foundops) {
    $foundops = 0;
    my %seen;
    my $index;
    my @out;
    while (@ops) {
      my $op = shift @ops;
      my $desc = join(",", @{$op}[0..$max_opr]);
      if ($seen{$desc}) {
	push(@out, @ops);
	my $old = $op->[-1];
	my $new = $seen{$desc};
	for $op (@out) {
	  for my $reg (@{$op}[1..$max_opr]) {
	    $reg = $new if $reg eq $old;
	  }
	}
	$foundops=1;
	last;
      }
      $seen{$desc} = $op->[-1];
      push(@out, $op);
    }
    @ops = @out;
  }
  # strength reduction
  for my $op (@ops) {
    # reduce division by a constant to multiplication by a constant
    if ($op->[0] eq 'div' && $op->[2] =~ /^r(\d+)/
       && defined($self->{"nregs"}[$1])) {
      my $newreg = @{$self->{"nregs"}};
      push(@{$self->{"nregs"}}, 1.0/$self->{"nregs"}[$1]);
      $op->[0] = 'mult';
      $op->[2] = 'r'.$newreg;
    }
  }
  $self->{ops} = \@ops;
  1;
}

sub assemble {
  my ($self) = @_;
  my $attr = \%Imager::Regops::Attr;
  my $max_opr = $Imager::Regops::MaxOperands;
  my @ops = @{$self->{ops}};
  for my $op (@ops) {
    $op->[0] = $attr->{$op->[0]}{opcode};
    for (@{$op}[1..$max_opr+1]) { s/^[rpj]// }
  }
  my $pack = $Imager::Regops::PackCode x (2+$Imager::Regops::MaxOperands);

  return join("", ,map { pack($pack, @$_, ) } @ops);
}

# converts stack code to register code
sub stack_to_reg {
  my ($self, @st_ops) = @_;
  my @regstack;
  my %nregs;
  my @vars = $self->_variables();
  my @nregs = (0) x scalar(@vars);
  my @cregs;
  my $attr = \%Imager::Regops::Attr;
  my %vars;
  my %names;
  my $max_opr = $Imager::Regops::MaxOperands;
  @vars{@vars} = map { "r$_" } 0..$#vars;

  my @ops;
  for (@st_ops) {
    if (/^$numre$/) {
      # combining constants makes the optimization below work
      if (exists $nregs{$_}) {
	push(@regstack, $nregs{$_});
      }
      else {
	$nregs{$_} = "r".@nregs;
	push(@regstack,"r".@nregs);
	push(@nregs, $_);
      }
    }
    elsif (exists $vars{$_}) {
      push(@regstack, $vars{$_});
    }
    elsif (exists $attr->{$_} && length $attr->{$_}{types}) {
      if (@regstack < $attr->{$_}{parms}) {
	error("Imager::transform2: stack underflow on $_");
	return;
      }
      my @parms = splice(@regstack, -$attr->{$_}{parms});
      my $types = join("", map {substr($_,0,1)} @parms);
      if ($types ne $attr->{$_}{types}) {
	if (exists $attr->{$_.'p'} && $types eq $attr->{$_.'p'}{types}) {
	  $_ .= 'p';
	}
	else {
	  error("Imager::transform2: Call to $_ with incorrect types");
	  return;
	}
      }
      my $result;
      if ($attr->{$_}{result} eq 'r') {
	$result = "r".@nregs;
	push(@nregs, undef);
      }
      else {
	$result = "p".@cregs;
	push(@cregs, -1);
      }
      push(@regstack, $result);
      push(@parms, "0") while @parms < $max_opr;
      push(@ops, [ $_, @parms, $result ]);
      #print "$result <- $_ @parms\n";
    }
    elsif (/^!(\w+)$/) {
      if (!@regstack) {
	error("Imager::transform2: stack underflow with $_");
	return;
      }
      $names{$1} = pop(@regstack);
    }
    elsif (/^\@(\w+)$/) {
      if (exists $names{$1}) {
	push(@regstack, $names{$1});
      }
      else {
	error("Imager::Expr: unknown storage \@$1");
	return;
      }
    }
    else {
      error("Imager::Expr: unknown operator $_");
      return;
    }
  }
  if (@regstack != 1) {
    error("stack must have only one item at end");
    return;
  }
  if ($regstack[0] !~ /^p/) {
    error("you must have a color value at the top of the stack at end");
    return;
  }
  push(@ops, [ "ret", $regstack[0], (-1) x $max_opr ]);

  $self->{"nregs"} = \@nregs;
  $self->{"cregs"} = \@cregs;

  return \@ops;
}

sub dumpops {
  my $result = '';
  for my $op (@{$_[0]->{ops}}) {
    $result .= "@{$op}\n";
  }
  $result;
}

# unassembles the compiled code
sub dumpcode {
  my ($self) = @_;
  my $code = $self->{"code"};
  my $attr = \%Imager::Regops::Attr;
  my @code = unpack("${Imager::Regops::PackCode}*", $code);
  my %names = map { $attr->{$_}{opcode}, $_ } keys %Imager::Regops::Attr;
  my @vars = $self->_variables();
  my $result = '';
  my $index = 0;
  while (my @op = splice(@code, 0, 2+$Imager::Regops::MaxOperands)) {
    my $opcode = shift @op;
    my $name = $names{$opcode};
    if ($name) {
      $result .= "j$index: $name($opcode)";
      my @types = split //, $attr->{$name}{types};
      for my $parm (@types) {
	my $reg = shift @op;
	$result .= " $parm$reg";
	if ($parm eq 'r') {
	  if ($reg < @vars) {
	    $result.= "($vars[$reg])";
	  }
	  elsif (defined $self->{"nregs"}[$reg]) {
	    $result .= "($self->{\"nregs\"}[$reg])";
	  }
	}
      }

      $result .= " -> $attr->{$name}{result}$op[-1]"
	if $attr->{$name}{result};
      $result .= "\n";
    }
    else {
      $result .= "unknown($opcode) @op\n";
    }
    ++$index;
  }

  $result;
}

package Imager::Expr::Postfix;
our @ISA = qw(Imager::Expr);

Imager::Expr::Postfix->register_type('rpnexpr');

my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div',
		 '%'=>'mod', '**'=>'pow' );

sub compile {
  my ($self, $expr, $opts) = @_;

  $expr =~ s/#.*//; # remove comments
  my @st_ops = split ' ', $expr;

  for (@st_ops) {
    $_ = $op_names{$_} if exists $op_names{$_};
    $_ = $self->{constants}{$_} if exists $self->{constants}{$_};
  }
  return $self->stack_to_reg(@st_ops);
}

package Imager::Expr::Infix;

our @ISA = qw(Imager::Expr);
use Imager::Regops qw(%Attr $MaxOperands);

{
  local @INC = @INC;
  pop @INC if $INC[-1] eq '.';
  eval "use Parse::RecDescent;";
  __PACKAGE__->register_type('expr') if !$@;
}

# I really prefer bottom-up parsers
my $grammar = <<'GRAMMAR';

code : assigns 'return' expr
{ $return = [ @item[1,3] ] }

assigns : assign(s?) { $return = [ @{$item[1]} ] }

assign : identifier '=' expr ';'
{ $return = [ @item[1,3] ] }

expr : relation

relation : addition (relstuff)(s?)
{
  $return = $item[1];
  for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
  1;
}

relstuff : relop addition { $return = [ @item[1,2] ] }

relop : '<=' { $return = 'le' }
      | '<' { $return = 'lt' }
      | '==' { $return = 'eq' }
      | '>=' { $return = 'ge' }
      | '>' { $return = 'gt' }
      | '!=' { $return = 'ne' }

addition : multiply (addstuff)(s?)
{
  $return = $item[1];
#  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
  for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
  1;
}
addstuff : addop multiply { $return = [ @item[1,2] ] }
addop : '+' { $return = 'add' }
      | '-' { $return = 'subtract' }

multiply : power mulstuff(s?)
{ $return = $item[1];
#  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
  for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
  1;
}

mulstuff : mulop power { $return = [ @item[1,2] ] }
mulop : '*' { $return = 'mult' }
      | '/' { $return = 'div' }
      | '%' { $return = 'mod' }

power : powstuff(s?) atom
{
  $return = $item[2];
  for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
  1;
}
      | atom
powstuff : atom powop { $return = [ @item[1,2] ] }
powop : '**' { $return = 'pow' }

atom: '(' expr ')' { $return = $item[2] }
     | '-' atom    { $return = [ uminus=>$item[2] ] }
     | number
     | funccall
     | identifier

number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/

exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
         | expr { $return = [ $item[1] ] }

funccall : identifier '(' exprlist ')'
{ $return = [ $item[1], @{$item[3]} ] }

identifier : /[^\W\d]\w*/ { $return = $item[1] }

GRAMMAR

my $parser;

sub init_parser {
  if (!$parser) {
    $parser = Parse::RecDescent->new($grammar);
  }
}

sub compile {
  my ($self, $expr, $opts) = @_;
  if (!$parser) {
    $parser = Parse::RecDescent->new($grammar);
  }
  my $optree = $parser->code($expr);
  if (!$optree) {
    $self->error("Error in $expr\n");
    return;
  }

  @{$self->{inputs}}{$self->_variables} = ();
  $self->{varregs} = {};
  @{$self->{varregs}}{$self->_variables} = map { "r$_" } 0..$self->_variables-1;
  $self->{"nregs"} = [ (undef) x $self->_variables ];
  $self->{"cregs"} = [];
  $self->{"lits"} = {};

  eval {
    # generate code for the assignments
    for my $assign (@{$optree->[0]}) {
      my ($varname, $tree) = @$assign;
      if (exists $self->{inputs}{$varname}) {
	$self->error("$varname is an input - you can't assign to it");
	return;
      }
      $self->{varregs}{$varname} = $self->gencode($tree);
    }

    # generate the final result
    my $result = $self->gencode($optree->[1]);
    if ($result !~ /^p\d+$/) {
      $self->error("You must return a color value");
      return;
    }
    push(@{$self->{genops}}, [ 'ret', $result, (0) x $MaxOperands ])
  };
  if ($@) {
    $self->error($@);
    return;
  }

  return $self->{genops};
}

sub gencode {
  my ($self, $tree) = @_;

  if (ref $tree) {
    my ($op, @parms) = @$tree;

    if (!exists $Attr{$op}) {
      die "Unknown operator or function $op";
    }

    for my $subtree (@parms) {
      $subtree = $self->gencode($subtree);
    }
    my $types = join("", map {substr($_,0,1)} @parms);

    if (length($types) < length($Attr{$op}{types})) {
      die "Too few parameters in call to $op";
    }
    if ($types ne $Attr{$op}{types}) {
      # some alternate operators have the same name followed by p
      my $opp = $op."p";
      if (exists $Attr{$opp} &&
	  $types eq $Attr{$opp}{types}) {
	$op = $opp;
      }
      else {
	die "Call to $_ with incorrect types";
      }
    }
    my $result;
    if ($Attr{$op}{result} eq 'r') {
      $result = "r".@{$self->{nregs}};
      push(@{$self->{nregs}}, undef);
    }
    else {
      $result = "p".@{$self->{cregs}};
      push(@{$self->{cregs}}, undef);
    }
    push(@parms, "0") while @parms < $MaxOperands;
    push(@{$self->{genops}}, [ $op, @parms, $result]);
    return $result;
  }
  elsif (exists $self->{varregs}{$tree}) {
    return $self->{varregs}{$tree};
  }
  elsif ($tree =~ /^$numre$/ || exists $self->{constants}{$tree}) {
    $tree = $self->{constants}{$tree} if exists $self->{constants}{$tree};

    if (exists $self->{lits}{$tree}) {
      return $self->{lits}{$tree};
    }
    my $reg = "r".@{$self->{nregs}};
    push(@{$self->{nregs}}, $tree);
    $self->{lits}{$tree} = $reg;

    return $reg;
  }
}

1;

__END__