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   my @st_ops = split ' ', $expr;
 302
 303   for (@st_ops) {
 304     $_ = $op_names{$_} if exists $op_names{$_};
 305     $_ = $self->{constants}{$_} if exists $self->{constants}{$_};
 306   }
 307   return $self->stack_to_reg(@st_ops);
 308 }
 309
 310 package Imager::Expr::Infix;
 311
 312 use vars qw(@ISA);
 313 @ISA = qw(Imager::Expr);
 314 use Imager::Regops qw(%Attr $MaxOperands);
 315
 316
 317 eval "use Parse::RecDescent;";
 318 __PACKAGE__->register_type('expr') if !$@;
 319
 320 # I really prefer bottom-up parsers
 321 my $grammar = <<'GRAMMAR';
 322
 323 code : assigns 'return' expr
 324 { $return = [ @item[1,3] ] }
 325
 326 assigns : assign(s?) { $return = [ @{$item[1]} ] }
 327
 328 assign : identifier '=' expr ';'
 329 { $return = [ @item[1,3] ] }
 330
 331 expr : relation
 332
 333 relation : addition (relstuff)(s?)
 334 {
 335   $return = $item[1];
 336   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 337 }
 338
 339 relstuff : relop addition { $return = [ @item[1,2] ] }
 340
 341 relop : '<=' { $return = 'le' }
 342       | '<' { $return = 'lt' }
 343       | '==' { $return = 'eq' }
 344       | '>=' { $return = 'ge' }
 345       | '>' { $return = 'gt' }
 346       | '!=' { $return = 'ne' }
 347
 348 addition : multiply (addstuff)(s?)
 349 {
 350   $return = $item[1];
 351 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 352   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 353 }
 354 addstuff : addop multiply { $return = [ @item[1,2] ] }
 355 addop : '+' { $return = 'add' }
 356       | '-' { $return = 'subtract' }
 357
 358 multiply : power mulstuff(s?)
 359 { $return = $item[1];
 360 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 361   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 362 }
 363
 364 mulstuff : mulop power { $return = [ @item[1,2] ] }
 365 mulop : '*' { $return = 'mult' }
 366       | '/' { $return = 'div' }
 367       | '%' { $return = 'mod' }
 368
 369 power : powstuff(s?) atom
 370 {
 371   $return = $item[2];
 372   for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
 373 }
 374       | atom
 375 powstuff : atom powop { $return = [ @item[1,2] ] }
 376 powop : '**' { $return = 'pow' }
 377
 378 atom: '(' expr ')' { $return = $item[2] }
 379      | '-' atom    { $return = [ uminus=>$item[2] ] }
 380      | number
 381      | funccall
 382      | identifier
 383
 384 number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/
 385
 386 exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
 387          | expr { $return = [ $item[1] ] }
 388
 389 funccall : identifier '(' exprlist ')'
 390 { $return = [ $item[1], @{$item[3]} ] }
 391
 392 identifier : /[^\W\d]\w*/ { $return = $item[1] }
 393
 394 GRAMMAR
 395
 396 my $parser;
 397
 398 sub init_parser {
 399   if (!$parser) {
 400     $parser = Parse::RecDescent->new($grammar);
 401   }
 402 }
 403
 404 sub compile {
 405   my ($self, $expr, $opts) = @_;
 406   if (!$parser) {
 407     $parser = Parse::RecDescent->new($grammar);
 408   }
 409   my $optree = $parser->code($expr);
 410   if (!$optree) {
 411     $self->error("Error in $expr\n");
 412     return;
 413   }
 414
 415   @{$self->{inputs}}{$self->_variables} = ();
 416   $self->{varregs} = {};
 417   @{$self->{varregs}}{$self->_variables} = map { "r$_" } 0..$self->_variables-1;
 418   $self->{"nregs"} = [ (undef) x $self->_variables ];
 419   $self->{"cregs"} = [];
 420   $self->{"lits"} = {};
 421
 422   eval {
 423     # generate code for the assignments
 424     for my $assign (@{$optree->[0]}) {
 425       my ($varname, $tree) = @$assign;
 426       if (exists $self->{inputs}{$varname}) {
 427         $self->error("$varname is an input - you can't assign to it");
 428         return;
 429       }
 430       $self->{varregs}{$varname} = $self->gencode($tree);
 431     }
 432
 433     # generate the final result
 434     my $result = $self->gencode($optree->[1]);
 435     if ($result !~ /^p\d+$/) {
 436       $self->error("You must return a colour value");
 437       return;
 438     }
 439     push(@{$self->{genops}}, [ 'ret', $result, (0) x $MaxOperands ])
 440   };
 441   if ($@) {
 442     $self->error($@);
 443     return;
 444   }
 445
 446   return $self->{genops};
 447 }
 448
 449 sub gencode {
 450   my ($self, $tree) = @_;
 451
 452   if (ref $tree) {
 453     my ($op, @parms) = @$tree;
 454
 455     if (!exists $Attr{$op}) {
 456       die "Unknown operator or function $op";
 457     }
 458
 459     for my $subtree (@parms) {
 460       $subtree = $self->gencode($subtree);
 461     }
 462     my $types = join("", map {substr($_,0,1)} @parms);
 463
 464     if (length($types) < length($Attr{$op}{types})) {
 465       die "Too few parameters in call to $op";
 466     }
 467     if ($types ne $Attr{$op}{types}) {
 468       # some alternate operators have the same name followed by p
 469       my $opp = $op."p";
 470       if (exists $Attr{$opp} &&
 471           $types eq $Attr{$opp}{types}) {
 472         $op = $opp;
 473       }
 474       else {
 475         die "Call to $_ with incorrect types";
 476       }
 477     }
 478     my $result;
 479     if ($Attr{$op}{result} eq 'r') {
 480       $result = "r".@{$self->{nregs}};
 481       push(@{$self->{nregs}}, undef);
 482     }
 483     else {
 484       $result = "p".@{$self->{cregs}};
 485       push(@{$self->{cregs}}, undef);
 486     }
 487     push(@parms, "0") while @parms < $MaxOperands;
 488     push(@{$self->{genops}}, [ $op, @parms, $result]);
 489     return $result;
 490   }
 491   elsif (exists $self->{varregs}{$tree}) {
 492     return $self->{varregs}{$tree};
 493   }
 494   elsif ($tree =~ /^$numre$/ || exists $self->{constants}{$tree}) {
 495     $tree = $self->{constants}{$tree} if exists $self->{constants}{$tree};
 496
 497     if (exists $self->{lits}{$tree}) {
 498       return $self->{lits}{$tree};
 499     }
 500     my $reg = "r".@{$self->{nregs}};
 501     push(@{$self->{nregs}}, $tree);
 502     $self->{lits}{$tree} = $reg;
 503
 504     return $reg;
 505   }
 506 }
 507
 508 1;
 509
 510 __END__
 511
 512 =head1 NAME
 513
 514 Imager::Expr - implements expression parsing and compilation for the
 515 expression evaluation engine used by Imager::transform2()
 516
 517 =head1 SYNOPSIS
 518
 519 my $code = Imager::Expr->new({rpnexpr=>$someexpr})
 520   or die "Cannot compile $someexpr: ",Imager::Expr::error();
 521
 522 =head1 DESCRIPTION
 523
 524 This module is used internally by the Imager::transform2() function.
 525 You shouldn't have much need to use it directly, but you may want to
 526 extend it.
 527
 528 To create a new Imager::Expr object, call:
 529
 530  my %options;
 531  my $expr = Imager::Expr->new(\%options)
 532    or die Imager::Expr::error();
 533
 534 You will need to set an expression value and you may set any of the
 535 following:
 536
 537 =over 4
 538
 539 =item constants
 540
 541 A hashref defining extra constants for expression parsing.  The names
 542 of the constants must be valid identifiers (/[^\W\d]\w*/) and the
 543 values must be valid numeric constants (that Perl recognizes in
 544 scalars).
 545
 546 Imager::Expr may define it's own constants (currently just pi.)
 547
 548 =item variables
 549
 550 A reference to an array of variable names.  These are allocated
 551 numeric registers starting from register zero.
 552
 553 =back
 554
 555 By default you can define a 'rpnexpr' key (which emulates RPN) or
 556 'expr' (an infix expression).  It's also possible to write other
 557 expression parsers that will use other keys.  Only one expression key
 558 should be defined.
 559
 560 =head2 Instance methods
 561
 562 The Imager::Expr::error() method is used to retrieve the error if the
 563 expression object cannot be created.
 564
 565 =head2 Methods
 566
 567 Imager::Expr provides only a few simple methods meant for external use:
 568
 569 =over 4
 570
 571 =item $expr->code()
 572
 573 Returns the compiled code.
 574
 575 =item $expr->nregs()
 576
 577 Returns a reference to the array of numeric registers.
 578
 579 =item $expr->cregs()
 580
 581 Returns a reference to the array of colour registers.
 582
 583 =item $expr->dumpops()
 584
 585 Returns a string with the generated VM "machine code".
 586
 587 =item $expr->dumpcode()
 588
 589 Returns a string with the unassembled VM "machine code".
 590
 591 =back
 592
 593 =head2 Creating a new parser
 594
 595 I'll write this one day.
 596
 597 Methods used by parsers:
 598
 599 =over 4
 600
 601 =item @vars = $self->_variables()
 602
 603 A list (not a reference) of the input variables.  This should be used
 604 to allocate as many registers as there are variable as input
 605 registers.
 606
 607 =item $self->error($message)
 608
 609 Set the return value of Imager::Expr::error()
 610
 611 =item @ops = $self->stack_to_reg(@stack_ops)
 612
 613 Converts marginally parsed RPN to register code.
 614
 615 =back
 616
 617 =head2 Future compatibility
 618
 619 Try to avoid doing your own optimization beyond literal folding - if
 620 we add some sort of jump, the existing optimizer will need to be
 621 rewritten, and any optimization you perform may well be broken too
 622 (well, your code generation will probably be broken anyway <sigh>).
 623
 624 =cut