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