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