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