- added comment support the postfix transform2() expression
[imager.git] / lib / Imager / Expr.pm
CommitLineData
02d1d628
AMH
1package Imager::Expr;
2
3use Imager::Regops;
4use strict;
5
6my %expr_types;
7
8my $error;
9
10sub 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?
21my %default_constants =
22 (
23 # too many digits, better than too few
24 pi=>3.14159265358979323846264338327950288419716939937510582097494
25 );
26
27sub 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
46sub register_type {
47 my ($pack, $name) = @_;
48 $expr_types{$name} = $pack;
49}
50
51sub _variables {
52 return @{$_[0]->{variables}};
53}
54
55sub code {
56 return $_[0]->{code};
57}
58
59sub nregs {
60 return $_[0]->{nregs};
61}
62
63sub cregs {
64 return $_[0]->{cregs};
65}
66
67my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?';
68
69sub numre {
70 $numre;
71}
72
73# optimize the code
74sub 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
128sub 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
143sub 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
239sub dumpops {
240 my $result = '';
241 for my $op (@{$_[0]->{ops}}) {
242 $result .= "@{$op}\n";
243 }
244 $result;
245}
246
247# unassembles the compiled code
248sub 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
289package Imager::Expr::Postfix;
290use vars qw(@ISA);
291@ISA = qw(Imager::Expr);
292
293Imager::Expr::Postfix->register_type('rpnexpr');
294
295my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div',
296 '%'=>'mod', '**'=>'pow' );
297
298sub compile {
299 my ($self, $expr, $opts) = @_;
300
e5744e01 301 $expr =~ s/#.*//; # remove comments
02d1d628
AMH
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
311package Imager::Expr::Infix;
312
313use vars qw(@ISA);
314@ISA = qw(Imager::Expr);
315use Imager::Regops qw(%Attr $MaxOperands);
316
317
318eval "use Parse::RecDescent;";
319__PACKAGE__->register_type('expr') if !$@;
320
321# I really prefer bottom-up parsers
322my $grammar = <<'GRAMMAR';
323
324code : assigns 'return' expr
325{ $return = [ @item[1,3] ] }
326
327assigns : assign(s?) { $return = [ @{$item[1]} ] }
328
329assign : identifier '=' expr ';'
330{ $return = [ @item[1,3] ] }
331
332expr : relation
333
334relation : addition (relstuff)(s?)
335{
336 $return = $item[1];
337 for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
338}
339
340relstuff : relop addition { $return = [ @item[1,2] ] }
341
342relop : '<=' { $return = 'le' }
343 | '<' { $return = 'lt' }
344 | '==' { $return = 'eq' }
345 | '>=' { $return = 'ge' }
346 | '>' { $return = 'gt' }
347 | '!=' { $return = 'ne' }
348
349addition : 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}
355addstuff : addop multiply { $return = [ @item[1,2] ] }
356addop : '+' { $return = 'add' }
357 | '-' { $return = 'subtract' }
358
359multiply : 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
365mulstuff : mulop power { $return = [ @item[1,2] ] }
366mulop : '*' { $return = 'mult' }
367 | '/' { $return = 'div' }
368 | '%' { $return = 'mod' }
369
370power : powstuff(s?) atom
371{
372 $return = $item[2];
373 for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
374}
375 | atom
376powstuff : atom powop { $return = [ @item[1,2] ] }
377powop : '**' { $return = 'pow' }
378
379atom: '(' expr ')' { $return = $item[2] }
380 | '-' atom { $return = [ uminus=>$item[2] ] }
381 | number
382 | funccall
383 | identifier
384
385number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/
386
387exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
388 | expr { $return = [ $item[1] ] }
389
390funccall : identifier '(' exprlist ')'
391{ $return = [ $item[1], @{$item[3]} ] }
392
393identifier : /[^\W\d]\w*/ { $return = $item[1] }
394
395GRAMMAR
396
397my $parser;
398
399sub init_parser {
400 if (!$parser) {
401 $parser = Parse::RecDescent->new($grammar);
402 }
403}
404
405sub 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
450sub 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
5091;
510
511__END__
512
513=head1 NAME
514
515Imager::Expr - implements expression parsing and compilation for the
516expression evaluation engine used by Imager::transform2()
517
518=head1 SYNOPSIS
519
520my $code = Imager::Expr->new({rpnexpr=>$someexpr})
521 or die "Cannot compile $someexpr: ",Imager::Expr::error();
522
523=head1 DESCRIPTION
524
525This module is used internally by the Imager::transform2() function.
526You shouldn't have much need to use it directly, but you may want to
527extend it.
528
529To 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
535You will need to set an expression value and you may set any of the
536following:
537
538=over 4
539
540=item constants
541
542A hashref defining extra constants for expression parsing. The names
543of the constants must be valid identifiers (/[^\W\d]\w*/) and the
544values must be valid numeric constants (that Perl recognizes in
545scalars).
546
547Imager::Expr may define it's own constants (currently just pi.)
548
549=item variables
550
551A reference to an array of variable names. These are allocated
552numeric registers starting from register zero.
553
554=back
555
556By default you can define a 'rpnexpr' key (which emulates RPN) or
557'expr' (an infix expression). It's also possible to write other
558expression parsers that will use other keys. Only one expression key
559should be defined.
560
561=head2 Instance methods
562
563The Imager::Expr::error() method is used to retrieve the error if the
564expression object cannot be created.
565
566=head2 Methods
567
568Imager::Expr provides only a few simple methods meant for external use:
569
570=over 4
571
572=item $expr->code()
573
574Returns the compiled code.
575
576=item $expr->nregs()
577
578Returns a reference to the array of numeric registers.
579
580=item $expr->cregs()
581
582Returns a reference to the array of colour registers.
583
584=item $expr->dumpops()
585
586Returns a string with the generated VM "machine code".
587
588=item $expr->dumpcode()
589
590Returns a string with the unassembled VM "machine code".
591
592=back
593
594=head2 Creating a new parser
595
596I'll write this one day.
597
598Methods used by parsers:
599
600=over 4
601
602=item @vars = $self->_variables()
603
604A list (not a reference) of the input variables. This should be used
605to allocate as many registers as there are variable as input
606registers.
607
608=item $self->error($message)
609
610Set the return value of Imager::Expr::error()
611
612=item @ops = $self->stack_to_reg(@stack_ops)
613
614Converts marginally parsed RPN to register code.
615
616=back
617
618=head2 Future compatibility
619
620Try to avoid doing your own optimization beyond literal folding - if
621we add some sort of jump, the existing optimizer will need to be
622rewritten, and any optimization you perform may well be broken too
623(well, your code generation will probably be broken anyway <sigh>).
624
625=cut