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.007";
   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   local @INC = @INC;
 328   pop @INC if $INC[-1] eq '.';
 329   eval "use Parse::RecDescent;";
 330   __PACKAGE__->register_type('expr') if !$@;
 331 }
 332
 333 # I really prefer bottom-up parsers
 334 my $grammar = <<'GRAMMAR';
 335
 336 code : assigns 'return' expr
 337 { $return = [ @item[1,3] ] }
 338
 339 assigns : assign(s?) { $return = [ @{$item[1]} ] }
 340
 341 assign : identifier '=' expr ';'
 342 { $return = [ @item[1,3] ] }
 343
 344 expr : relation
 345
 346 relation : addition (relstuff)(s?)
 347 {
 348   $return = $item[1];
 349   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 350   1;
 351 }
 352
 353 relstuff : relop addition { $return = [ @item[1,2] ] }
 354
 355 relop : '<=' { $return = 'le' }
 356       | '<' { $return = 'lt' }
 357       | '==' { $return = 'eq' }
 358       | '>=' { $return = 'ge' }
 359       | '>' { $return = 'gt' }
 360       | '!=' { $return = 'ne' }
 361
 362 addition : multiply (addstuff)(s?)
 363 {
 364   $return = $item[1];
 365 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 366   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 367   1;
 368 }
 369 addstuff : addop multiply { $return = [ @item[1,2] ] }
 370 addop : '+' { $return = 'add' }
 371       | '-' { $return = 'subtract' }
 372
 373 multiply : power mulstuff(s?)
 374 { $return = $item[1];
 375 #  for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; }
 376   for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
 377   1;
 378 }
 379
 380 mulstuff : mulop power { $return = [ @item[1,2] ] }
 381 mulop : '*' { $return = 'mult' }
 382       | '/' { $return = 'div' }
 383       | '%' { $return = 'mod' }
 384
 385 power : powstuff(s?) atom
 386 {
 387   $return = $item[2];
 388   for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
 389   1;
 390 }
 391       | atom
 392 powstuff : atom powop { $return = [ @item[1,2] ] }
 393 powop : '**' { $return = 'pow' }
 394
 395 atom: '(' expr ')' { $return = $item[2] }
 396      | '-' atom    { $return = [ uminus=>$item[2] ] }
 397      | number
 398      | funccall
 399      | identifier
 400
 401 number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/
 402
 403 exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
 404          | expr { $return = [ $item[1] ] }
 405
 406 funccall : identifier '(' exprlist ')'
 407 { $return = [ $item[1], @{$item[3]} ] }
 408
 409 identifier : /[^\W\d]\w*/ { $return = $item[1] }
 410
 411 GRAMMAR
 412
 413 my $parser;
 414
 415 sub init_parser {
 416   if (!$parser) {
 417     $parser = Parse::RecDescent->new($grammar);
 418   }
 419 }
 420
 421 sub compile {
 422   my ($self, $expr, $opts) = @_;
 423   if (!$parser) {
 424     $parser = Parse::RecDescent->new($grammar);
 425   }
 426   my $optree = $parser->code($expr);
 427   if (!$optree) {
 428     $self->error("Error in $expr\n");
 429     return;
 430   }
 431
 432   @{$self->{inputs}}{$self->_variables} = ();
 433   $self->{varregs} = {};
 434   @{$self->{varregs}}{$self->_variables} = map { "r$_" } 0..$self->_variables-1;
 435   $self->{"nregs"} = [ (undef) x $self->_variables ];
 436   $self->{"cregs"} = [];
 437   $self->{"lits"} = {};
 438
 439   eval {
 440     # generate code for the assignments
 441     for my $assign (@{$optree->[0]}) {
 442       my ($varname, $tree) = @$assign;
 443       if (exists $self->{inputs}{$varname}) {
 444         $self->error("$varname is an input - you can't assign to it");
 445         return;
 446       }
 447       $self->{varregs}{$varname} = $self->gencode($tree);
 448     }
 449
 450     # generate the final result
 451     my $result = $self->gencode($optree->[1]);
 452     if ($result !~ /^p\d+$/) {
 453       $self->error("You must return a color value");
 454       return;
 455     }
 456     push(@{$self->{genops}}, [ 'ret', $result, (0) x $MaxOperands ])
 457   };
 458   if ($@) {
 459     $self->error($@);
 460     return;
 461   }
 462
 463   return $self->{genops};
 464 }
 465
 466 sub gencode {
 467   my ($self, $tree) = @_;
 468
 469   if (ref $tree) {
 470     my ($op, @parms) = @$tree;
 471
 472     if (!exists $Attr{$op}) {
 473       die "Unknown operator or function $op";
 474     }
 475
 476     for my $subtree (@parms) {
 477       $subtree = $self->gencode($subtree);
 478     }
 479     my $types = join("", map {substr($_,0,1)} @parms);
 480
 481     if (length($types) < length($Attr{$op}{types})) {
 482       die "Too few parameters in call to $op";
 483     }
 484     if ($types ne $Attr{$op}{types}) {
 485       # some alternate operators have the same name followed by p
 486       my $opp = $op."p";
 487       if (exists $Attr{$opp} &&
 488           $types eq $Attr{$opp}{types}) {
 489         $op = $opp;
 490       }
 491       else {
 492         die "Call to $_ with incorrect types";
 493       }
 494     }
 495     my $result;
 496     if ($Attr{$op}{result} eq 'r') {
 497       $result = "r".@{$self->{nregs}};
 498       push(@{$self->{nregs}}, undef);
 499     }
 500     else {
 501       $result = "p".@{$self->{cregs}};
 502       push(@{$self->{cregs}}, undef);
 503     }
 504     push(@parms, "0") while @parms < $MaxOperands;
 505     push(@{$self->{genops}}, [ $op, @parms, $result]);
 506     return $result;
 507   }
 508   elsif (exists $self->{varregs}{$tree}) {
 509     return $self->{varregs}{$tree};
 510   }
 511   elsif ($tree =~ /^$numre$/ || exists $self->{constants}{$tree}) {
 512     $tree = $self->{constants}{$tree} if exists $self->{constants}{$tree};
 513
 514     if (exists $self->{lits}{$tree}) {
 515       return $self->{lits}{$tree};
 516     }
 517     my $reg = "r".@{$self->{nregs}};
 518     push(@{$self->{nregs}}, $tree);
 519     $self->{lits}{$tree} = $reg;
 520
 521     return $reg;
 522   }
 523 }
 524
 525 1;
 526
 527 __END__
 528
 529 =head1 NAME
 530
 531 Imager::Expr - implements expression parsing and compilation for the
 532 expression evaluation engine used by Imager::transform2()
 533
 534 =head1 SYNOPSIS
 535
 536 my $code = Imager::Expr->new({rpnexpr=>$someexpr})
 537   or die "Cannot compile $someexpr: ",Imager::Expr::error();
 538
 539 =head1 DESCRIPTION
 540
 541 This module is used internally by the Imager::transform2() function.
 542 You shouldn't have much need to use it directly, but you may want to
 543 extend it.
 544
 545 To create a new Imager::Expr object, call:
 546
 547  my %options;
 548  my $expr = Imager::Expr->new(\%options)
 549    or die Imager::Expr::error();
 550
 551 You will need to set an expression value and you may set any of the
 552 following:
 553
 554 =over
 555
 556 =item *
 557
 558 constants
 559
 560 A hashref defining extra constants for expression parsing.  The names
 561 of the constants must be valid identifiers (/[^\W\d]\w*/) and the
 562 values must be valid numeric constants (that Perl recognizes in
 563 scalars).
 564
 565 Imager::Expr may define it's own constants (currently just pi.)
 566
 567 =item *
 568
 569 variables
 570
 571 A reference to an array of variable names.  These are allocated
 572 numeric registers starting from register zero.
 573
 574 =back
 575
 576 =for stopwords RPN
 577
 578 By default you can define a C<rpnexpr> key (which emulates RPN) or
 579 C<expr> (an infix expression).  It's also possible to write other
 580 expression parsers that will use other keys.  Only one expression key
 581 should be defined.
 582
 583 =head2 Instance methods
 584
 585 The Imager::Expr::error() method is used to retrieve the error if the
 586 expression object cannot be created.
 587
 588 =head2 Methods
 589
 590 Imager::Expr provides only a few simple methods meant for external use:
 591
 592 =for stopwords VM
 593
 594 =over
 595
 596 =item Imager::Expr->type_registered($keyword)
 597
 598 Returns true if the given expression type is available.  The parameter
 599 is the key supplied to the new() method.
 600
 601   if (Imager::Expr->type_registered('expr')) {
 602     # use infix expressions
 603   }
 604
 605 =item $expr->code()
 606
 607 Returns the compiled code.
 608
 609 =item $expr->nregs()
 610
 611 Returns a reference to the array of numeric registers.
 612
 613 =item $expr->cregs()
 614
 615 Returns a reference to the array of color registers.
 616
 617 =item $expr->dumpops()
 618
 619 Returns a string with the generated VM "machine code".
 620
 621 =item $expr->dumpcode()
 622
 623 Returns a string with the disassembled VM "machine code".
 624
 625 =back
 626
 627 =head2 Creating a new parser
 628
 629 I'll write this one day.
 630
 631 Methods used by parsers:
 632
 633 =over
 634
 635 =item compile
 636
 637 This is the main method you'll need to implement in a parser.  See the
 638 existing parsers for a guide.
 639
 640 It's supplied the following parameters:
 641
 642 =over
 643
 644 =item *
 645
 646 $expr - the expression to be parsed
 647
 648 =item *
 649
 650 $options - the options hash supplied to transform2.
 651
 652 =back
 653
 654 Return an array ref of array refs containing opcodes and operands.
 655
 656 =item @vars = $self->_variables()
 657
 658 A list (not a reference) of the input variables.  This should be used
 659 to allocate as many registers as there are variable as input
 660 registers.
 661
 662 =item $self->error($message)
 663
 664 Set the return value of Imager::Expr::error()
 665
 666 =item @ops = $self->stack_to_reg(@stack_ops)
 667
 668 Converts marginally parsed RPN to register code.
 669
 670 =item assemble()
 671
 672 Called to convert op codes into byte code.
 673
 674 =item numre()
 675
 676 Returns a regular expression that matches floating point numbers.
 677
 678 =item optimize()
 679
 680 Optimizes the assembly code, including attempting common subexpression
 681 elimination and strength reducing division by a constant into
 682 multiplication by a constant.
 683
 684 =item register_type()
 685
 686 Called by a new expression parser implementation to register itself,
 687 call as:
 688
 689   YourClassName->register_type('type code');
 690
 691 where type code is the parameter that will accept the expression.
 692
 693 =back
 694
 695 =head2 Future compatibility
 696
 697 Try to avoid doing your own optimization beyond literal folding - if
 698 we add some sort of jump, the existing optimizer will need to be
 699 rewritten, and any optimization you perform may well be broken too
 700 (well, your code generation will probably be broken anyway <sigh>).
 701
 702 =head1 AUTHOR
 703
 704 Tony Cook <tonyc@cpan.org>, Arnar M. Hrafnkelsson
 705
 706 =cut