lib/Imager/Expr.pm

   1 package Imager::Expr;
   2
   3 use Imager::Regops;
   4 use strict;
   5
   6 my %expr_types;
   7
   8 my $error;
   9
  10 sub error {
  11   shift if UNIVERSAL::isa($_[0], 'Imager::Expr');
  12   if (@_) {
  13     $error = "@_";
  14   }
  15   else {
  16     return $error;
  17   }
  18 }
  19
  20 # what else?
  21 my %default_constants =
  22   (
  23    # too many digits, better than too few
  24    pi=>3.14159265358979323846264338327950288419716939937510582097494
  25   );
  26
  27 sub new {
  28   my ($class, $opts) = @_;
  29
  30   # possibly this is a very bad idea
  31   my ($type) = grep exists $expr_types{$_}, keys %$opts;
  32   die "Imager::Expr: No known expression type"
  33     if !defined $type;
  34   my $self = bless {}, $expr_types{$type};
  35   $self->{variables} = [ @{$opts->{variables}} ];
  36   $self->{constants} = { %default_constants, %{$opts->{constants} || {}} };
  37   $self->{ops} = $self->compile($opts->{$type}, $opts)
  38     or return;
  39   $self->optimize()
  40     or return;
  41   $self->{code} = $self->assemble()
  42     or return;
  43   $self;
  44 }
  45
  46 sub register_type {
  47   my ($pack, $name) = @_;
  48   $expr_types{$name} = $pack;
  49 }
  50
  51 sub _variables {
  52   return @{$_[0]->{variables}};
  53 }
  54
  55 sub code {
  56   return $_[0]->{code};
  57 }
  58
  59 sub nregs {
  60   return $_[0]->{nregs};
  61 }
  62
  63 sub cregs {
  64   return $_[0]->{cregs};
  65 }
  66
  67 my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?';
  68
  69 sub numre {
  70   $numre;
  71 }
  72
  73 # optimize the code
  74 sub optimize {
  75   my ($self) = @_;
  76
  77   my @ops = @{$self->{ops}};
  78
  79   # this function cannot current handle code with jumps
  80   return 1 if grep $_->[0] =~ /^jump/, @ops;
  81
  82   # optimization - common sub-expression elimination
  83   # it's possible to fold this into the code generation - but it will wait
  84
  85   my $max_opr = $Imager::Regops::MaxOperands;
  86   my $attr = \%Imager::Regops::Attr;
  87   my $foundops = 1;
  88   while ($foundops) {
  89     $foundops = 0;
  90     my %seen;
  91     my $index;
  92     my @out;
  93     while (@ops) {
  94       my $op = shift @ops;
  95       my $desc = join(",", @{$op}[0..$max_opr]);
  96       if ($seen{$desc}) {
  97         push(@out, @ops);
  98         my $old = $op->[-1];
  99         my $new = $seen{$desc};
 100         for $op (@out) {
 101           for my $reg (@{$op}[1..$max_opr]) {
 102             $reg = $new if $reg eq $old;
 103           }
 104         }
 105         $foundops=1;
 106         last;
 107       }
 108       $seen{$desc} = $op->[-1];
 109       push(@out, $op);
 110     }
 111     @ops = @out;
 112   }
 113   # strength reduction
 114   for my $op (@ops) {
 115     # reduce division by a constant to multiplication by a constant
 116     if ($op->[0] eq 'div' && $op->[2] =~ /^r(\d+)/
 117        && defined($self->{"nregs"}[$1])) {
 118       my $newreg = @{$self->{"nregs"}};
 119       push(@{$self->{"nregs"}}, 1.0/$self->{"nregs"}[$1]);
 120       $op->[0] = 'mult';
 121       $op->[2] = 'r'.$newreg;
 122     }
 123   }
 124   $self->{ops} = \@ops;
 125   1;
 126 }
 127
 128 sub assemble {
 129   my ($self) = @_;
 130   my $attr = \%Imager::Regops::Attr;
 131   my $max_opr = $Imager::Regops::MaxOperands;
 132   my @ops = @{$self->{ops}};
 133   for my $op (@ops) {
 134     $op->[0] = $attr->{$op->[0]}{opcode};
 135     for (@{$op}[1..$max_opr+1]) { s/^[rpj]// }
 136   }
 137   my $pack = $Imager::Regops::PackCode x (2+$Imager::Regops::MaxOperands);
 138
 139   return join("", ,map { pack($pack, @$_, ) } @ops);
 140 }
 141
 142 # converts stack code to register code
 143 sub stack_to_reg {
 144   my ($self, @st_ops) = @_;
 145   my @regstack;
 146   my %nregs;
 147   my @vars = $self->_variables();
 148   my @nregs = (0) x scalar(@vars);
 149   my @cregs;
 150   my $attr = \%Imager::Regops::Attr;
 151   my %vars;
 152   my %names;
 153   my $max_opr = $Imager::Regops::MaxOperands;
 154   @vars{@vars} = map { "r$_" } 0..$#vars;
 155
 156   my @ops;
 157   for (@st_ops) {
 158     if (/^$numre$/) {
 159       # combining constants makes the optimization below work
 160       if (exists $nregs{$_}) {
 161         push(@regstack, $nregs{$_});
 162       }
 163       else {
 164         $nregs{$_} = "r".@nregs;
 165         push(@regstack,"r".@nregs);
 166         push(@nregs, $_);
 167       }
 168     }
 169     elsif (exists $vars{$_}) {
 170       push(@regstack, $vars{$_});
 171     }
 172     elsif (exists $attr->{$_} && length $attr->{$_}{types}) {
 173       if (@regstack < $attr->{$_}{parms}) {
 174         error("Imager::transform2: stack underflow on $_");
 175         return;
 176       }
 177       my @parms = splice(@regstack, -$attr->{$_}{parms});
 178       my $types = join("", map {substr($_,0,1)} @parms);
 179       if ($types ne $attr->{$_}{types}) {
 180         if (exists $attr->{$_.'p'} && $types eq $attr->{$_.'p'}{types}) {
 181           $_ .= 'p';
 182         }
 183         else {
 184           error("Imager::transform2: Call to $_ with incorrect types");
 185           return;
 186         }
 187       }
 188       my $result;
 189       if ($attr->{$_}{result} eq 'r') {
 190         $result = "r".@nregs;
 191         push(@nregs, undef);
 192       }
 193       else {
 194         $result = "p".@cregs;
 195         push(@cregs, -1);
 196       }
 197       push(@regstack, $result);
 198       push(@parms, "0") while @parms < $max_opr;
 199       push(@ops, [ $_, @parms, $result ]);
 200       #print "$result <- $_ @parms\n";
 201     }
 202     elsif (/^!(\w+)$/) {
 203       if (!@regstack) {
 204         error("Imager::transform2: stack underflow with $_");
 205         return;
 206       }
 207       $names{$1} = pop(@regstack);
 208     }
 209     elsif (/^\@(\w+)$/) {
 210       if (exists $names{$1}) {
 211         push(@regstack, $names{$1});
 212       }
 213       else {
 214         error("Imager::Expr: unknown storage \@$1");
 215         return;
 216       }
 217     }
 218     else {
 219       error("Imager::Expr: unknown operator $_");
 220       return;
 221     }
 222   }
 223   if (@regstack != 1) {
 224     error("stack must have only one item at end");
 225     return;
 226   }
 227   if ($regstack[0] !~ /^p/) {
 228     error("you must have a color value at the top of the stack at end");
 229     return;
 230   }
 231   push(@ops, [ "ret", $regstack[0], (-1) x $max_opr ]);
 232
 233   $self->{"nregs"} = \@nregs;
 234   $self->{"cregs"} = \@cregs;
 235
 236   return \@ops;
 237 }
 238
 239 sub dumpops {
 240   my $result = '';
 241   for my $op (@{$_[0]->{ops}}) {
 242     $result .= "@{$op}\n";
 243   }
 244   $result;
 245 }
 246
 247 # unassembles the compiled code
 248 sub dumpcode {
 249   my ($self) = @_;
 250   my $code = $self->{"code"};
 251   my $attr = \%Imager::Regops::Attr;
 252   my @code = unpack("${Imager::Regops::PackCode}*", $code);
 253   my %names = map { $attr->{$_}{opcode}, $_ } keys %Imager::Regops::Attr;
 254   my @vars = $self->_variables();
 255   my $result = '';
 256   my $index = 0;
 257   while (my @op = splice(@code, 0, 2+$Imager::Regops::MaxOperands)) {
 258     my $opcode = shift @op;
 259     my $name = $names{$opcode};
 260     if ($name) {
 261       $result .= "j$index: $name($opcode)";
 262       my @types = split //, $attr->{$name}{types};
 263       for my $parm (@types) {
 264         my $reg = shift @op;
 265         $result .= " $parm$reg";
 266         if ($parm eq 'r') {
 267           if ($reg < @vars) {
 268             $result.= "($vars[$reg])";
 269           }
 270           elsif (defined $self->{"nregs"}[$reg]) {
 271             $result .= "($self->{\"nregs\"}[$reg])";
 272           }
 273         }
 274       }
 275
 276       $result .= " -> $attr->{$name}{result}$op[-1]"
 277         if $attr->{$name}{result};
 278       $result .= "\n";
 279     }
 280     else {
 281       $result .= "unknown($opcode) @op\n";
 282     }
 283     ++$index;
 284   }
 285
 286   $result;
 287 }
 288
 289 package Imager::Expr::Postfix;
 290 use vars qw(@ISA);
 291 @ISA = qw(Imager::Expr);
 292
 293 Imager::Expr::Postfix->register_type('rpnexpr');
 294
 295 my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div',
 296                  '%'=>'mod', '**'=>'pow' );
 297
 298 sub compile {
 299   my ($self, $expr, $opts) = @_;
 300
 301   $expr =~ s/#.*//; # remove comments
 302   my @st_ops = split ' ', $expr;
 303
 304   for (@st_ops) {
 305     $_ = $op_names{$_} if exists $op_names{$_};
 306     $_ = $self->{constants}{$_} if exists $self->{constants}{$_};
 307   }
 308   return $self->stack_to_reg(@st_ops);
 309 }
 310
 311 package Imager::Expr::Infix;
 312
 313 use vars qw(@ISA);
 314 @ISA = qw(Imager::Expr);
 315 use Imager::Regops qw(%Attr $MaxOperands);
 316
 317
 318 eval "use Parse::RecDescent;";
 319 __PACKAGE__->register_type('expr') if !$@;
 320
 321 # I really prefer bottom-up parsers
 322 my $grammar = <<'GRAMMAR';
 323
 324 code : assigns 'return' expr
 325 { $return = [ @item[1,3] ] }
 326
 327 assigns : assign(s?) { $return = [ @{$item[1]} ] }
 328
 329 assign : identifier '=' expr ';'
 330 { $return = [ @item[1,3] ] }
 331
 332 expr : relation
 333
 334 relation : addition (relstuff)(s?)
 335 {
 336   $return = $item[1];
 337   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 338 }
 339
 340 relstuff : relop addition { $return = [ @item[1,2] ] }
 341
 342 relop : '<=' { $return = 'le' }
 343       | '<' { $return = 'lt' }
 344       | '==' { $return = 'eq' }
 345       | '>=' { $return = 'ge' }
 346       | '>' { $return = 'gt' }
 347       | '!=' { $return = 'ne' }
 348
 349 addition : multiply (addstuff)(s?)
 350 {
 351   $return = $item[1];
 352 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 353   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 354 }
 355 addstuff : addop multiply { $return = [ @item[1,2] ] }
 356 addop : '+' { $return = 'add' }
 357       | '-' { $return = 'subtract' }
 358
 359 multiply : power mulstuff(s?)
 360 { $return = $item[1];
 361 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 362   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 363 }
 364
 365 mulstuff : mulop power { $return = [ @item[1,2] ] }
 366 mulop : '*' { $return = 'mult' }
 367       | '/' { $return = 'div' }
 368       | '%' { $return = 'mod' }
 369
 370 power : powstuff(s?) atom
 371 {
 372   $return = $item[2];
 373   for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
 374 }
 375       | atom
 376 powstuff : atom powop { $return = [ @item[1,2] ] }
 377 powop : '**' { $return = 'pow' }
 378
 379 atom: '(' expr ')' { $return = $item[2] }
 380      | '-' atom    { $return = [ uminus=>$item[2] ] }
 381      | number
 382      | funccall
 383      | identifier
 384
 385 number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/
 386
 387 exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
 388          | expr { $return = [ $item[1] ] }
 389
 390 funccall : identifier '(' exprlist ')'
 391 { $return = [ $item[1], @{$item[3]} ] }
 392
 393 identifier : /[^\W\d]\w*/ { $return = $item[1] }
 394
 395 GRAMMAR
 396
 397 my $parser;
 398
 399 sub init_parser {
 400   if (!$parser) {
 401     $parser = Parse::RecDescent->new($grammar);
 402   }
 403 }
 404
 405 sub compile {
 406   my ($self, $expr, $opts) = @_;
 407   if (!$parser) {
 408     $parser = Parse::RecDescent->new($grammar);
 409   }
 410   my $optree = $parser->code($expr);
 411   if (!$optree) {
 412     $self->error("Error in $expr\n");
 413     return;
 414   }
 415
 416   @{$self->{inputs}}{$self->_variables} = ();
 417   $self->{varregs} = {};
 418   @{$self->{varregs}}{$self->_variables} = map { "r$_" } 0..$self->_variables-1;
 419   $self->{"nregs"} = [ (undef) x $self->_variables ];
 420   $self->{"cregs"} = [];
 421   $self->{"lits"} = {};
 422
 423   eval {
 424     # generate code for the assignments
 425     for my $assign (@{$optree->[0]}) {
 426       my ($varname, $tree) = @$assign;
 427       if (exists $self->{inputs}{$varname}) {
 428         $self->error("$varname is an input - you can't assign to it");
 429         return;
 430       }
 431       $self->{varregs}{$varname} = $self->gencode($tree);
 432     }
 433
 434     # generate the final result
 435     my $result = $self->gencode($optree->[1]);
 436     if ($result !~ /^p\d+$/) {
 437       $self->error("You must return a colour value");
 438       return;
 439     }
 440     push(@{$self->{genops}}, [ 'ret', $result, (0) x $MaxOperands ])
 441   };
 442   if ($@) {
 443     $self->error($@);
 444     return;
 445   }
 446
 447   return $self->{genops};
 448 }
 449
 450 sub gencode {
 451   my ($self, $tree) = @_;
 452
 453   if (ref $tree) {
 454     my ($op, @parms) = @$tree;
 455
 456     if (!exists $Attr{$op}) {
 457       die "Unknown operator or function $op";
 458     }
 459
 460     for my $subtree (@parms) {
 461       $subtree = $self->gencode($subtree);
 462     }
 463     my $types = join("", map {substr($_,0,1)} @parms);
 464
 465     if (length($types) < length($Attr{$op}{types})) {
 466       die "Too few parameters in call to $op";
 467     }
 468     if ($types ne $Attr{$op}{types}) {
 469       # some alternate operators have the same name followed by p
 470       my $opp = $op."p";
 471       if (exists $Attr{$opp} &&
 472           $types eq $Attr{$opp}{types}) {
 473         $op = $opp;
 474       }
 475       else {
 476         die "Call to $_ with incorrect types";
 477       }
 478     }
 479     my $result;
 480     if ($Attr{$op}{result} eq 'r') {
 481       $result = "r".@{$self->{nregs}};
 482       push(@{$self->{nregs}}, undef);
 483     }
 484     else {
 485       $result = "p".@{$self->{cregs}};
 486       push(@{$self->{cregs}}, undef);
 487     }
 488     push(@parms, "0") while @parms < $MaxOperands;
 489     push(@{$self->{genops}}, [ $op, @parms, $result]);
 490     return $result;
 491   }
 492   elsif (exists $self->{varregs}{$tree}) {
 493     return $self->{varregs}{$tree};
 494   }
 495   elsif ($tree =~ /^$numre$/ || exists $self->{constants}{$tree}) {
 496     $tree = $self->{constants}{$tree} if exists $self->{constants}{$tree};
 497
 498     if (exists $self->{lits}{$tree}) {
 499       return $self->{lits}{$tree};
 500     }
 501     my $reg = "r".@{$self->{nregs}};
 502     push(@{$self->{nregs}}, $tree);
 503     $self->{lits}{$tree} = $reg;
 504
 505     return $reg;
 506   }
 507 }
 508
 509 1;
 510
 511 __END__
 512
 513 =head1 NAME
 514
 515 Imager::Expr - implements expression parsing and compilation for the
 516 expression evaluation engine used by Imager::transform2()
 517
 518 =head1 SYNOPSIS
 519
 520 my $code = Imager::Expr->new({rpnexpr=>$someexpr})
 521   or die "Cannot compile $someexpr: ",Imager::Expr::error();
 522
 523 =head1 DESCRIPTION
 524
 525 This module is used internally by the Imager::transform2() function.
 526 You shouldn't have much need to use it directly, but you may want to
 527 extend it.
 528
 529 To create a new Imager::Expr object, call:
 530
 531  my %options;
 532  my $expr = Imager::Expr->new(\%options)
 533    or die Imager::Expr::error();
 534
 535 You will need to set an expression value and you may set any of the
 536 following:
 537
 538 =over 4
 539
 540 =item constants
 541
 542 A hashref defining extra constants for expression parsing.  The names
 543 of the constants must be valid identifiers (/[^\W\d]\w*/) and the
 544 values must be valid numeric constants (that Perl recognizes in
 545 scalars).
 546
 547 Imager::Expr may define it's own constants (currently just pi.)
 548
 549 =item variables
 550
 551 A reference to an array of variable names.  These are allocated
 552 numeric registers starting from register zero.
 553
 554 =back
 555
 556 By default you can define a 'rpnexpr' key (which emulates RPN) or
 557 'expr' (an infix expression).  It's also possible to write other
 558 expression parsers that will use other keys.  Only one expression key
 559 should be defined.
 560
 561 =head2 Instance methods
 562
 563 The Imager::Expr::error() method is used to retrieve the error if the
 564 expression object cannot be created.
 565
 566 =head2 Methods
 567
 568 Imager::Expr provides only a few simple methods meant for external use:
 569
 570 =over 4
 571
 572 =item $expr->code()
 573
 574 Returns the compiled code.
 575
 576 =item $expr->nregs()
 577
 578 Returns a reference to the array of numeric registers.
 579
 580 =item $expr->cregs()
 581
 582 Returns a reference to the array of colour registers.
 583
 584 =item $expr->dumpops()
 585
 586 Returns a string with the generated VM "machine code".
 587
 588 =item $expr->dumpcode()
 589
 590 Returns a string with the unassembled VM "machine code".
 591
 592 =back
 593
 594 =head2 Creating a new parser
 595
 596 I'll write this one day.
 597
 598 Methods used by parsers:
 599
 600 =over 4
 601
 602 =item @vars = $self->_variables()
 603
 604 A list (not a reference) of the input variables.  This should be used
 605 to allocate as many registers as there are variable as input
 606 registers.
 607
 608 =item $self->error($message)
 609
 610 Set the return value of Imager::Expr::error()
 611
 612 =item @ops = $self->stack_to_reg(@stack_ops)
 613
 614 Converts marginally parsed RPN to register code.
 615
 616 =back
 617
 618 =head2 Future compatibility
 619
 620 Try to avoid doing your own optimization beyond literal folding - if
 621 we add some sort of jump, the existing optimizer will need to be
 622 rewritten, and any optimization you perform may well be broken too
 623 (well, your code generation will probably be broken anyway <sigh>).
 624
 625 =cut