eliminate use vars
[imager.git] / lib / Imager / Expr.pm
1 package Imager::Expr;
2 use 5.006;
3 use Imager::Regops;
4 use strict;
5
6 our $VERSION = "1.008";
7
8 my %expr_types;
9
10 my $error;
11
12 sub error {
13   shift if UNIVERSAL::isa($_[0], 'Imager::Expr');
14   if (@_) {
15     $error = "@_";
16   }
17   else {
18     return $error;
19   }
20 }
21
22 # what else?
23 my %default_constants =
24   (
25    # too many digits, better than too few
26    pi=>3.14159265358979323846264338327950288419716939937510582097494
27   );
28
29 sub new {
30   my ($class, $opts) = @_;
31
32   # possibly this is a very bad idea
33   my ($type) = grep exists $expr_types{$_}, keys %$opts;
34   die "Imager::Expr: No known expression type"
35     if !defined $type;
36   my $self = bless {}, $expr_types{$type};
37   $self->{variables} = [ @{$opts->{variables}} ];
38   $self->{constants} = { %default_constants, %{$opts->{constants} || {}} };
39   $self->{ops} = $self->compile($opts->{$type}, $opts)
40     or return;
41   $self->optimize()
42     or return;
43   $self->{code} = $self->assemble()
44     or return;
45   $self;
46 }
47
48 sub register_type {
49   my ($pack, $name) = @_;
50   $expr_types{$name} = $pack;
51 }
52
53 sub type_registered {
54   my ($class, $name) = @_;
55
56   $expr_types{$name};
57 }
58
59 sub _variables {
60   return @{$_[0]->{variables}};
61 }
62
63 sub code {
64   return $_[0]->{code};
65 }
66
67 sub nregs {
68   return $_[0]->{nregs};
69 }
70
71 sub cregs {
72   return $_[0]->{cregs};
73 }
74
75 my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?';
76
77 sub numre {
78   $numre;
79 }
80
81 # optimize the code
82 sub optimize {
83   my ($self) = @_;
84
85   my @ops = @{$self->{ops}};
86
87   # this function cannot current handle code with jumps
88   return 1 if grep $_->[0] =~ /^jump/, @ops;
89
90   # optimization - common sub-expression elimination
91   # it's possible to fold this into the code generation - but it will wait
92
93   my $max_opr = $Imager::Regops::MaxOperands;
94   my $attr = \%Imager::Regops::Attr;
95   my $foundops = 1;
96   while ($foundops) {
97     $foundops = 0;
98     my %seen;
99     my $index;
100     my @out;
101     while (@ops) {
102       my $op = shift @ops;
103       my $desc = join(",", @{$op}[0..$max_opr]);
104       if ($seen{$desc}) {
105         push(@out, @ops);
106         my $old = $op->[-1];
107         my $new = $seen{$desc};
108         for $op (@out) {
109           for my $reg (@{$op}[1..$max_opr]) {
110             $reg = $new if $reg eq $old;
111           }
112         }
113         $foundops=1;
114         last;
115       }
116       $seen{$desc} = $op->[-1];
117       push(@out, $op);
118     }
119     @ops = @out;
120   }
121   # strength reduction
122   for my $op (@ops) {
123     # reduce division by a constant to multiplication by a constant
124     if ($op->[0] eq 'div' && $op->[2] =~ /^r(\d+)/
125        && defined($self->{"nregs"}[$1])) {
126       my $newreg = @{$self->{"nregs"}};
127       push(@{$self->{"nregs"}}, 1.0/$self->{"nregs"}[$1]);
128       $op->[0] = 'mult';
129       $op->[2] = 'r'.$newreg;
130     }
131   }
132   $self->{ops} = \@ops;
133   1;
134 }
135
136 sub assemble {
137   my ($self) = @_;
138   my $attr = \%Imager::Regops::Attr;
139   my $max_opr = $Imager::Regops::MaxOperands;
140   my @ops = @{$self->{ops}};
141   for my $op (@ops) {
142     $op->[0] = $attr->{$op->[0]}{opcode};
143     for (@{$op}[1..$max_opr+1]) { s/^[rpj]// }
144   }
145   my $pack = $Imager::Regops::PackCode x (2+$Imager::Regops::MaxOperands);
146
147   return join("", ,map { pack($pack, @$_, ) } @ops);
148 }
149
150 # converts stack code to register code
151 sub stack_to_reg {
152   my ($self, @st_ops) = @_;
153   my @regstack;
154   my %nregs;
155   my @vars = $self->_variables();
156   my @nregs = (0) x scalar(@vars);
157   my @cregs;
158   my $attr = \%Imager::Regops::Attr;
159   my %vars;
160   my %names;
161   my $max_opr = $Imager::Regops::MaxOperands;
162   @vars{@vars} = map { "r$_" } 0..$#vars;
163
164   my @ops;
165   for (@st_ops) {
166     if (/^$numre$/) {
167       # combining constants makes the optimization below work
168       if (exists $nregs{$_}) {
169         push(@regstack, $nregs{$_});
170       }
171       else {
172         $nregs{$_} = "r".@nregs;
173         push(@regstack,"r".@nregs);
174         push(@nregs, $_);
175       }
176     }
177     elsif (exists $vars{$_}) {
178       push(@regstack, $vars{$_});
179     }
180     elsif (exists $attr->{$_} && length $attr->{$_}{types}) {
181       if (@regstack < $attr->{$_}{parms}) {
182         error("Imager::transform2: stack underflow on $_");
183         return;
184       }
185       my @parms = splice(@regstack, -$attr->{$_}{parms});
186       my $types = join("", map {substr($_,0,1)} @parms);
187       if ($types ne $attr->{$_}{types}) {
188         if (exists $attr->{$_.'p'} && $types eq $attr->{$_.'p'}{types}) {
189           $_ .= 'p';
190         }
191         else {
192           error("Imager::transform2: Call to $_ with incorrect types");
193           return;
194         }
195       }
196       my $result;
197       if ($attr->{$_}{result} eq 'r') {
198         $result = "r".@nregs;
199         push(@nregs, undef);
200       }
201       else {
202         $result = "p".@cregs;
203         push(@cregs, -1);
204       }
205       push(@regstack, $result);
206       push(@parms, "0") while @parms < $max_opr;
207       push(@ops, [ $_, @parms, $result ]);
208       #print "$result <- $_ @parms\n";
209     }
210     elsif (/^!(\w+)$/) {
211       if (!@regstack) {
212         error("Imager::transform2: stack underflow with $_");
213         return;
214       }
215       $names{$1} = pop(@regstack);
216     }
217     elsif (/^\@(\w+)$/) {
218       if (exists $names{$1}) {
219         push(@regstack, $names{$1});
220       }
221       else {
222         error("Imager::Expr: unknown storage \@$1");
223         return;
224       }
225     }
226     else {
227       error("Imager::Expr: unknown operator $_");
228       return;
229     }
230   }
231   if (@regstack != 1) {
232     error("stack must have only one item at end");
233     return;
234   }
235   if ($regstack[0] !~ /^p/) {
236     error("you must have a color value at the top of the stack at end");
237     return;
238   }
239   push(@ops, [ "ret", $regstack[0], (-1) x $max_opr ]);
240
241   $self->{"nregs"} = \@nregs;
242   $self->{"cregs"} = \@cregs;
243
244   return \@ops;
245 }
246
247 sub dumpops {
248   my $result = '';
249   for my $op (@{$_[0]->{ops}}) {
250     $result .= "@{$op}\n";
251   }
252   $result;
253 }
254
255 # unassembles the compiled code
256 sub dumpcode {
257   my ($self) = @_;
258   my $code = $self->{"code"};
259   my $attr = \%Imager::Regops::Attr;
260   my @code = unpack("${Imager::Regops::PackCode}*", $code);
261   my %names = map { $attr->{$_}{opcode}, $_ } keys %Imager::Regops::Attr;
262   my @vars = $self->_variables();
263   my $result = '';
264   my $index = 0;
265   while (my @op = splice(@code, 0, 2+$Imager::Regops::MaxOperands)) {
266     my $opcode = shift @op;
267     my $name = $names{$opcode};
268     if ($name) {
269       $result .= "j$index: $name($opcode)";
270       my @types = split //, $attr->{$name}{types};
271       for my $parm (@types) {
272         my $reg = shift @op;
273         $result .= " $parm$reg";
274         if ($parm eq 'r') {
275           if ($reg < @vars) {
276             $result.= "($vars[$reg])";
277           }
278           elsif (defined $self->{"nregs"}[$reg]) {
279             $result .= "($self->{\"nregs\"}[$reg])";
280           }
281         }
282       }
283
284       $result .= " -> $attr->{$name}{result}$op[-1]"
285         if $attr->{$name}{result};
286       $result .= "\n";
287     }
288     else {
289       $result .= "unknown($opcode) @op\n";
290     }
291     ++$index;
292   }
293
294   $result;
295 }
296
297 package Imager::Expr::Postfix;
298 our @ISA = qw(Imager::Expr);
299
300 Imager::Expr::Postfix->register_type('rpnexpr');
301
302 my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div',
303                  '%'=>'mod', '**'=>'pow' );
304
305 sub compile {
306   my ($self, $expr, $opts) = @_;
307
308   $expr =~ s/#.*//; # remove comments
309   my @st_ops = split ' ', $expr;
310
311   for (@st_ops) {
312     $_ = $op_names{$_} if exists $op_names{$_};
313     $_ = $self->{constants}{$_} if exists $self->{constants}{$_};
314   }
315   return $self->stack_to_reg(@st_ops);
316 }
317
318 package Imager::Expr::Infix;
319
320 our @ISA = qw(Imager::Expr);
321 use Imager::Regops qw(%Attr $MaxOperands);
322
323 {
324   local @INC = @INC;
325   pop @INC if $INC[-1] eq '.';
326   eval "use Parse::RecDescent;";
327   __PACKAGE__->register_type('expr') if !$@;
328 }
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 =head1 AUTHOR
700
701 Tony Cook <tonyc@cpan.org>, Arnar M. Hrafnkelsson
702
703 =cut