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