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