eliminate use vars
[imager.git] / lib / Imager / Expr.pm
CommitLineData
02d1d628 1package Imager::Expr;
ee64a81f 2use 5.006;
02d1d628
AMH
3use Imager::Regops;
4use strict;
f17b46d8 5
ee64a81f 6our $VERSION = "1.008";
02d1d628
AMH
7
8my %expr_types;
9
10my $error;
11
12sub 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?
23my %default_constants =
24 (
25 # too many digits, better than too few
26 pi=>3.14159265358979323846264338327950288419716939937510582097494
27 );
28
29sub 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
48sub register_type {
49 my ($pack, $name) = @_;
50 $expr_types{$name} = $pack;
51}
52
ff37fc3f
TC
53sub type_registered {
54 my ($class, $name) = @_;
55
56 $expr_types{$name};
57}
58
02d1d628
AMH
59sub _variables {
60 return @{$_[0]->{variables}};
61}
62
63sub code {
64 return $_[0]->{code};
65}
66
67sub nregs {
68 return $_[0]->{nregs};
69}
70
71sub cregs {
72 return $_[0]->{cregs};
73}
74
75my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?';
76
77sub numre {
78 $numre;
79}
80
81# optimize the code
82sub 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
136sub 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
151sub 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
247sub dumpops {
248 my $result = '';
249 for my $op (@{$_[0]->{ops}}) {
250 $result .= "@{$op}\n";
251 }
252 $result;
253}
254
255# unassembles the compiled code
256sub 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
297package Imager::Expr::Postfix;
ee64a81f 298our @ISA = qw(Imager::Expr);
02d1d628
AMH
299
300Imager::Expr::Postfix->register_type('rpnexpr');
301
302my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div',
303 '%'=>'mod', '**'=>'pow' );
304
305sub compile {
306 my ($self, $expr, $opts) = @_;
307
e5744e01 308 $expr =~ s/#.*//; # remove comments
02d1d628
AMH
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
318package Imager::Expr::Infix;
319
ee64a81f 320our @ISA = qw(Imager::Expr);
02d1d628
AMH
321use Imager::Regops qw(%Attr $MaxOperands);
322
b1736e02
TC
323{
324 local @INC = @INC;
325 pop @INC if $INC[-1] eq '.';
326 eval "use Parse::RecDescent;";
327 __PACKAGE__->register_type('expr') if !$@;
328}
02d1d628
AMH
329
330# I really prefer bottom-up parsers
331my $grammar = <<'GRAMMAR';
332
333code : assigns 'return' expr
334{ $return = [ @item[1,3] ] }
335
336assigns : assign(s?) { $return = [ @{$item[1]} ] }
337
338assign : identifier '=' expr ';'
339{ $return = [ @item[1,3] ] }
340
341expr : relation
342
343relation : addition (relstuff)(s?)
344{
345 $return = $item[1];
346 for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] }
d3bf4eaf 347 1;
02d1d628
AMH
348}
349
350relstuff : relop addition { $return = [ @item[1,2] ] }
351
352relop : '<=' { $return = 'le' }
353 | '<' { $return = 'lt' }
354 | '==' { $return = 'eq' }
355 | '>=' { $return = 'ge' }
356 | '>' { $return = 'gt' }
357 | '!=' { $return = 'ne' }
358
359addition : 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] ] }
d3bf4eaf 364 1;
02d1d628
AMH
365}
366addstuff : addop multiply { $return = [ @item[1,2] ] }
367addop : '+' { $return = 'add' }
368 | '-' { $return = 'subtract' }
369
370multiply : 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] ] }
d3bf4eaf 374 1;
02d1d628
AMH
375}
376
377mulstuff : mulop power { $return = [ @item[1,2] ] }
378mulop : '*' { $return = 'mult' }
379 | '/' { $return = 'div' }
380 | '%' { $return = 'mod' }
381
382power : powstuff(s?) atom
383{
384 $return = $item[2];
385 for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] }
d3bf4eaf 386 1;
02d1d628
AMH
387}
388 | atom
389powstuff : atom powop { $return = [ @item[1,2] ] }
390powop : '**' { $return = 'pow' }
391
392atom: '(' expr ')' { $return = $item[2] }
393 | '-' atom { $return = [ uminus=>$item[2] ] }
394 | number
395 | funccall
396 | identifier
397
398number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/
399
400exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] }
401 | expr { $return = [ $item[1] ] }
402
403funccall : identifier '(' exprlist ')'
404{ $return = [ $item[1], @{$item[3]} ] }
405
406identifier : /[^\W\d]\w*/ { $return = $item[1] }
407
408GRAMMAR
409
410my $parser;
411
412sub init_parser {
413 if (!$parser) {
414 $parser = Parse::RecDescent->new($grammar);
415 }
416}
417
418sub 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+$/) {
5715f7c3 450 $self->error("You must return a color value");
02d1d628
AMH
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
463sub 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
5221;
523
524__END__
525
526=head1 NAME
527
528Imager::Expr - implements expression parsing and compilation for the
529expression evaluation engine used by Imager::transform2()
530
531=head1 SYNOPSIS
532
533my $code = Imager::Expr->new({rpnexpr=>$someexpr})
534 or die "Cannot compile $someexpr: ",Imager::Expr::error();
535
536=head1 DESCRIPTION
537
538This module is used internally by the Imager::transform2() function.
539You shouldn't have much need to use it directly, but you may want to
540extend it.
541
542To 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
548You will need to set an expression value and you may set any of the
549following:
550
d5556805
TC
551=over
552
553=item *
02d1d628 554
d5556805 555constants
02d1d628
AMH
556
557A hashref defining extra constants for expression parsing. The names
558of the constants must be valid identifiers (/[^\W\d]\w*/) and the
559values must be valid numeric constants (that Perl recognizes in
560scalars).
561
562Imager::Expr may define it's own constants (currently just pi.)
563
d5556805
TC
564=item *
565
566variables
02d1d628
AMH
567
568A reference to an array of variable names. These are allocated
569numeric registers starting from register zero.
570
571=back
572
5715f7c3
TC
573=for stopwords RPN
574
575By default you can define a C<rpnexpr> key (which emulates RPN) or
576C<expr> (an infix expression). It's also possible to write other
02d1d628
AMH
577expression parsers that will use other keys. Only one expression key
578should be defined.
579
580=head2 Instance methods
581
582The Imager::Expr::error() method is used to retrieve the error if the
583expression object cannot be created.
584
585=head2 Methods
586
587Imager::Expr provides only a few simple methods meant for external use:
588
5715f7c3
TC
589=for stopwords VM
590
ff37fc3f
TC
591=over
592
593=item Imager::Expr->type_registered($keyword)
594
595Returns true if the given expression type is available. The parameter
596is the key supplied to the new() method.
597
598 if (Imager::Expr->type_registered('expr')) {
599 # use infix expressions
600 }
02d1d628
AMH
601
602=item $expr->code()
603
604Returns the compiled code.
605
606=item $expr->nregs()
607
608Returns a reference to the array of numeric registers.
609
610=item $expr->cregs()
611
5715f7c3 612Returns a reference to the array of color registers.
02d1d628
AMH
613
614=item $expr->dumpops()
615
616Returns a string with the generated VM "machine code".
617
618=item $expr->dumpcode()
619
5715f7c3 620Returns a string with the disassembled VM "machine code".
02d1d628
AMH
621
622=back
623
624=head2 Creating a new parser
625
626I'll write this one day.
627
628Methods used by parsers:
629
d5556805
TC
630=over
631
632=item compile
633
634This is the main method you'll need to implement in a parser. See the
635existing parsers for a guide.
636
637It'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
651Return an array ref of array refs containing opcodes and operands.
02d1d628
AMH
652
653=item @vars = $self->_variables()
654
655A list (not a reference) of the input variables. This should be used
656to allocate as many registers as there are variable as input
657registers.
658
659=item $self->error($message)
660
661Set the return value of Imager::Expr::error()
662
663=item @ops = $self->stack_to_reg(@stack_ops)
664
665Converts marginally parsed RPN to register code.
666
5715f7c3 667=item assemble()
d5556805
TC
668
669Called to convert op codes into byte code.
670
5715f7c3 671=item numre()
d5556805
TC
672
673Returns a regular expression that matches floating point numbers.
674
5715f7c3 675=item optimize()
d5556805
TC
676
677Optimizes the assembly code, including attempting common subexpression
678elimination and strength reducing division by a constant into
679multiplication by a constant.
680
5715f7c3 681=item register_type()
d5556805
TC
682
683Called by a new expression parser implementation to register itself,
684call as:
685
686 YourClassName->register_type('type code');
687
688where type code is the parameter that will accept the expression.
689
02d1d628
AMH
690=back
691
692=head2 Future compatibility
693
694Try to avoid doing your own optimization beyond literal folding - if
695we add some sort of jump, the existing optimizer will need to be
696rewritten, and any optimization you perform may well be broken too
697(well, your code generation will probably be broken anyway <sigh>).
698
8ba1b8a6
TC
699=head1 AUTHOR
700
701Tony Cook <tonyc@cpan.org>, Arnar M. Hrafnkelsson
702
02d1d628 703=cut