lib/Imager/Expr.pm

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