- added VERSION numbers to most .pms
[imager.git] / lib / Imager / Expr / Assem.pm
1 package Imager::Expr::Assem;
2 use strict;
3 use Imager::Expr;
4 use Imager::Regops;
5 use vars qw($VERSION);
6
7 $VERSION = sprintf "%d.%03d", q$Revision$=~/\d+/g;
8
9 use vars qw(@ISA);
10 @ISA = qw(Imager::Expr);
11
12 __PACKAGE__->register_type('assem');
13
14 sub 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
179 1;
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
195 This module is a simple Imager::Expr compiler that compiles a
196 low-level language that has a nearly 1-to-1 relationship to the
197 internal representation used for compiled regmach code.
198
199 =head2 Syntax
200
201 Each line can contain multiple statements separated by semi-colons.
202
203 Anything after '#' in a line is ignored.
204
205 Types of statements:
206
207 =over 4
208
209 =item variable definition
210
211 =over 4
212
213 C<var> I<name>:I<type>
214
215 =back
216
217 defines 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
219 type.
220
221 Variable names cannot include whitespace.
222
223 =item operators
224
225 Operators can be split into 3 basic types, those that have a result
226 value, those that don't and the null operator, eg. jump has no value.
227
228 The format for operators that return a value is typically:
229
230 =over 4
231
232 I<result> = I<operator> I<operand> ...
233
234 =back
235
236 and for those that don't return a value:
237
238 =over 4
239
240 I<operator> I<operand>
241
242 =back
243
244 where operator is any valid regmach operator, result is any variable
245 defined with C<var>, and operands are variables, constants or
246 literals, or for jump operators, labels.
247
248 The set operator can be simplified to:
249
250 =over 4
251
252 I<result> = I<operator>
253
254 =back
255
256 All operators maybe preceded by a label, which is any non-whitespace
257 text immediately followed by a colon (':').
258
259 =back
260
261 =head1 BUGS
262
263 Note that the current optimizer may produce incorrect optimization for
264 your code, fortunately the optimizer will disable itself if you
265 include any jump operator in your code.  A single jump to anywhere
266 after your final ret operator can be used to disable the optimizer
267 without slowing down your code.
268
269 There's currently no high-level code generation that can generate code
270 with loops or real conditions.
271
272 =head1 SEE ALSO
273
274 Imager(3), transform.perl, regmach.c
275
276 =head1 AUTHOR
277
278 Tony Cook <tony@develop-help.com>
279
280 =cut