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