eliminate use vars
[imager.git] / lib / Imager / Expr / Assem.pm
CommitLineData
02d1d628 1package Imager::Expr::Assem;
ee64a81f 2use 5.006;
02d1d628
AMH
3use strict;
4use Imager::Expr;
5use Imager::Regops;
f17b46d8 6
ee64a81f 7our $VERSION = "1.004";
02d1d628 8
ee64a81f 9our @ISA = qw(Imager::Expr);
02d1d628
AMH
10
11__PACKAGE__->register_type('assem');
12
13sub compile {
14 my ($self, $expr, $opts) = @_;
15 my %nregs;
16 my @vars = $self->_variables();
17 my @nregs = (0) x @vars;
18 my @cregs;
19 my %vars;
20 @vars{@vars} = map { "r$_" } 0..$#vars;
21 my %labels;
22 my @ops;
23 my @msgs;
24 my $attr = \%Imager::Regops::Attr;
25
26 # initially produce [ $linenum, $result, $opcode, @parms ]
27 my $lineno = 0;
28 while ($expr =~ s/^([^\n]+)(?:\n|$)//) {
29 ++$lineno;
30 my $line = $1;
31 $line =~ s/#.*//;
32 next if $line =~ /^\s*$/;
33 for my $op (split /;/, $line) {
34 if (my ($name, $type) = $op =~ /^\s*var\s+([^:]+):(\S+)\s*$/) {
35 if (exists $vars{$name}) {
36 push(@msgs, "$lineno: duplicate variable name '$name'");
37 next;
38 }
39 if ($type eq 'num' || $type eq 'n') {
40 $vars{$name} = 'r'.@nregs;
41 push(@nregs, undef);
42 next;
43 }
44 elsif ($type eq 'pixel' || $type eq 'p' || $type eq 'c') {
45 $vars{$name} = 'p'.@cregs;
46 push(@cregs, undef);
47 next;
48 }
49 push(@msgs, "$lineno: unknown variable type $type");
50 next;
51 }
52 # any statement can have a label
53 if ($op =~ s/^\s*(\w+):\s*//) {
54 if ($labels{$1}) {
55 push(@msgs,
56 "$lineno: duplicate label $1 (previous on $labels{$1}[1])");
57 next;
58 }
59 $labels{$1} = [ scalar @ops, $lineno ];
60 }
61 next if $op =~ /^\s*$/;
62 # jumps have special operand handling
63 if ($op =~ /^\s*jump\s+(\w+)\s*$/) {
64 push(@ops, [$lineno, "", "jump", $1]);
65 }
66 elsif (my ($code, $reg, $targ) =
67 ($op =~ /^\s*(jumpz|jumpnz)\s+(\S+)\s+(\S+)\s*$/)) {
68 push(@ops, [$lineno, "", $code, $reg, $targ]);
69 }
70 elsif ($op =~ /^\s*print\s+(\S+)\s*/) {
71 push(@ops, [$lineno, "", 'print', $1 ]);
72 }
73 elsif ($op =~ /^\s*ret\s+(\S+)\s*/) {
74 push(@ops, [$lineno, "", 'ret', $1]);
75 }
76 elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*$//) {
77 # simple assignment
78 push(@ops, [$lineno, $1, "set", $2]);
79 }
80 elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*//) {
81 # some normal ops finally
82 my ($result, $opcode) = ($1, $2);
83 unless ($attr->{$opcode}) {
84 push(@msgs, "$lineno: unknown operator $opcode");
85 next;
86 }
87 my @oper;
88 while ($op =~ s/(\S+)\s*//) {
89 push(@oper, $1);
90 }
91 push(@ops, [$lineno, $result, $opcode, @oper]);
92 }
93 else {
94 push(@msgs, "$lineno: invalid statement '$op'");
95 }
96 }
97 }
98
99 my $max_opr = $Imager::Regops::MaxOperands;
100 my $numre = $self->numre;
101 my $trans =
102 sub {
103 # translate a name/number to a <type><digits>
104 my ($name) = @_;
105 $name = $self->{constants}{$name}
106 if exists $self->{constants}{$name};
107 if ($vars{$name}) {
108 return $vars{$name};
109 }
110 elsif ($name =~ /^$numre$/) {
111 $vars{$name} = 'r'.@nregs;
112 push(@nregs, $name);
113 return $vars{$name};
114 }
115 else {
116 push(@msgs, "$lineno: undefined variable $name");
117 return '';
118 }
119 };
120 # now to translate symbols and so on
121 OP: for my $op (@ops) {
122 $lineno = shift @$op;
123 if ($op->[1] eq 'jump') {
124 unless (exists $labels{$op->[2]}) {
125 push(@msgs, "$lineno: unknown label $op->[2]");
126 next;
127 }
128 $op = [ 'jump', "j$labels{$op->[2]}[0]", (0) x $max_opr ];
129 }
130 elsif ($op->[1] =~ /^jump/) {
131 unless (exists $labels{$op->[3]}) {
132 push(@msgs, "$lineno: unknown label $op->[2]");
133 next;
134 }
135 $op = [ $op->[1], $trans->($op->[2]), "j$labels{$op->[3]}[0]",
136 (0) x ($max_opr-1) ];
137 }
138 elsif ($op->[1] eq 'print') {
139 $op = [ $op->[1], $trans->($op->[2]), (0) x $max_opr ];
140 }
141 elsif ($op->[1] eq 'ret') {
142 $op = [ 'ret', $trans->($op->[2]), (0) x $max_opr ];
143 }
144 else {
145 # a normal operator
146 my ($result, $name, @parms) = @$op;
147
148 if ($result =~ /^$numre$/) {
149 push(@msgs, "$lineno: target of operator cannot be a constant");
150 next;
151 }
152 $result = $trans->($result);
153 for my $parm (@parms) {
154 $parm = $trans->($parm);
155 }
156 push(@parms, (0) x ($max_opr-@parms));
157 $op = [ $op->[1], @parms, $result ];
158 }
159 }
160
161 # more validation than a real assembler
162 # not trying to solve the halting problem...
163 if (@ops && $ops[-1][0] ne 'ret' && $ops[-1][0] ne 'jump') {
164 push(@msgs, ": the last instruction must be ret or jump");
165 }
166
167 $self->{nregs} = \@nregs;
168 $self->{cregs} = \@cregs;
169
170 if (@msgs) {
171 $self->error(join("\n", @msgs));
172 return 0;
173 }
174
175 return \@ops;
176}
177
1781;
179
180__END__
181
182=head1 NAME
183
184 Imager::Expr::Assem - an assembler for producing code for the Imager
185 register machine
186
187=head1 SYNOPSIS
188
189 use Imager::Expr::Assem;
190 my $expr = Imager::Expr->new(assem=>'...', ...)
191
192=head1 DESCRIPTION
193
194This module is a simple Imager::Expr compiler that compiles a
195low-level language that has a nearly 1-to-1 relationship to the
5715f7c3 196internal representation used for compiled register machine code.
02d1d628
AMH
197
198=head2 Syntax
199
200Each line can contain multiple statements separated by semi-colons.
201
202Anything after '#' in a line is ignored.
203
204Types of statements:
205
206=over 4
207
208=item variable definition
209
210=over 4
211
212C<var> I<name>:I<type>
213
214=back
215
5715f7c3
TC
216defines variable I<name> to have I<type>, which can be any of C<n> or
217C<num> for a numeric type or C<pixel>, C<p> or C<c> for a pixel or
218color type.
02d1d628 219
5715f7c3 220Variable names cannot include white-space.
02d1d628
AMH
221
222=item operators
223
224Operators can be split into 3 basic types, those that have a result
225value, those that don't and the null operator, eg. jump has no value.
226
227The format for operators that return a value is typically:
228
229=over 4
230
231I<result> = I<operator> I<operand> ...
232
233=back
234
235and for those that don't return a value:
236
237=over 4
238
239I<operator> I<operand>
240
241=back
242
5715f7c3
TC
243where operator is any valid register machine operator, result is any
244variable defined with C<var>, and operands are variables, constants or
02d1d628
AMH
245literals, or for jump operators, labels.
246
247The set operator can be simplified to:
248
249=over 4
250
251I<result> = I<operator>
252
253=back
254
5715f7c3 255All operators maybe preceded by a label, which is any non-white-space
02d1d628
AMH
256text immediately followed by a colon (':').
257
258=back
259
260=head1 BUGS
261
262Note that the current optimizer may produce incorrect optimization for
263your code, fortunately the optimizer will disable itself if you
264include any jump operator in your code. A single jump to anywhere
5715f7c3 265after your final C<ret> operator can be used to disable the optimizer
02d1d628
AMH
266without slowing down your code.
267
268There's currently no high-level code generation that can generate code
269with loops or real conditions.
270
271=head1 SEE ALSO
272
5715f7c3 273Imager(3), F<transform.perl>, F<regmach.c>
02d1d628
AMH
274
275=head1 AUTHOR
276
277Tony Cook <tony@develop-help.com>
278
279=cut