280 lines
6.4 KiB
Perl
280 lines
6.4 KiB
Perl
package Imager::Expr::Assem;
|
|
use 5.006;
|
|
use strict;
|
|
use Imager::Expr;
|
|
use Imager::Regops;
|
|
|
|
our $VERSION = "1.004";
|
|
|
|
our @ISA = qw(Imager::Expr);
|
|
|
|
__PACKAGE__->register_type('assem');
|
|
|
|
sub compile {
|
|
my ($self, $expr, $opts) = @_;
|
|
my %nregs;
|
|
my @vars = $self->_variables();
|
|
my @nregs = (0) x @vars;
|
|
my @cregs;
|
|
my %vars;
|
|
@vars{@vars} = map { "r$_" } 0..$#vars;
|
|
my %labels;
|
|
my @ops;
|
|
my @msgs;
|
|
my $attr = \%Imager::Regops::Attr;
|
|
|
|
# initially produce [ $linenum, $result, $opcode, @parms ]
|
|
my $lineno = 0;
|
|
while ($expr =~ s/^([^\n]+)(?:\n|$)//) {
|
|
++$lineno;
|
|
my $line = $1;
|
|
$line =~ s/#.*//;
|
|
next if $line =~ /^\s*$/;
|
|
for my $op (split /;/, $line) {
|
|
if (my ($name, $type) = $op =~ /^\s*var\s+([^:]+):(\S+)\s*$/) {
|
|
if (exists $vars{$name}) {
|
|
push(@msgs, "$lineno: duplicate variable name '$name'");
|
|
next;
|
|
}
|
|
if ($type eq 'num' || $type eq 'n') {
|
|
$vars{$name} = 'r'.@nregs;
|
|
push(@nregs, undef);
|
|
next;
|
|
}
|
|
elsif ($type eq 'pixel' || $type eq 'p' || $type eq 'c') {
|
|
$vars{$name} = 'p'.@cregs;
|
|
push(@cregs, undef);
|
|
next;
|
|
}
|
|
push(@msgs, "$lineno: unknown variable type $type");
|
|
next;
|
|
}
|
|
# any statement can have a label
|
|
if ($op =~ s/^\s*(\w+):\s*//) {
|
|
if ($labels{$1}) {
|
|
push(@msgs,
|
|
"$lineno: duplicate label $1 (previous on $labels{$1}[1])");
|
|
next;
|
|
}
|
|
$labels{$1} = [ scalar @ops, $lineno ];
|
|
}
|
|
next if $op =~ /^\s*$/;
|
|
# jumps have special operand handling
|
|
if ($op =~ /^\s*jump\s+(\w+)\s*$/) {
|
|
push(@ops, [$lineno, "", "jump", $1]);
|
|
}
|
|
elsif (my ($code, $reg, $targ) =
|
|
($op =~ /^\s*(jumpz|jumpnz)\s+(\S+)\s+(\S+)\s*$/)) {
|
|
push(@ops, [$lineno, "", $code, $reg, $targ]);
|
|
}
|
|
elsif ($op =~ /^\s*print\s+(\S+)\s*/) {
|
|
push(@ops, [$lineno, "", 'print', $1 ]);
|
|
}
|
|
elsif ($op =~ /^\s*ret\s+(\S+)\s*/) {
|
|
push(@ops, [$lineno, "", 'ret', $1]);
|
|
}
|
|
elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*$//) {
|
|
# simple assignment
|
|
push(@ops, [$lineno, $1, "set", $2]);
|
|
}
|
|
elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*//) {
|
|
# some normal ops finally
|
|
my ($result, $opcode) = ($1, $2);
|
|
unless ($attr->{$opcode}) {
|
|
push(@msgs, "$lineno: unknown operator $opcode");
|
|
next;
|
|
}
|
|
my @oper;
|
|
while ($op =~ s/(\S+)\s*//) {
|
|
push(@oper, $1);
|
|
}
|
|
push(@ops, [$lineno, $result, $opcode, @oper]);
|
|
}
|
|
else {
|
|
push(@msgs, "$lineno: invalid statement '$op'");
|
|
}
|
|
}
|
|
}
|
|
|
|
my $max_opr = $Imager::Regops::MaxOperands;
|
|
my $numre = $self->numre;
|
|
my $trans =
|
|
sub {
|
|
# translate a name/number to a <type><digits>
|
|
my ($name) = @_;
|
|
$name = $self->{constants}{$name}
|
|
if exists $self->{constants}{$name};
|
|
if ($vars{$name}) {
|
|
return $vars{$name};
|
|
}
|
|
elsif ($name =~ /^$numre$/) {
|
|
$vars{$name} = 'r'.@nregs;
|
|
push(@nregs, $name);
|
|
return $vars{$name};
|
|
}
|
|
else {
|
|
push(@msgs, "$lineno: undefined variable $name");
|
|
return '';
|
|
}
|
|
};
|
|
# now to translate symbols and so on
|
|
OP: for my $op (@ops) {
|
|
$lineno = shift @$op;
|
|
if ($op->[1] eq 'jump') {
|
|
unless (exists $labels{$op->[2]}) {
|
|
push(@msgs, "$lineno: unknown label $op->[2]");
|
|
next;
|
|
}
|
|
$op = [ 'jump', "j$labels{$op->[2]}[0]", (0) x $max_opr ];
|
|
}
|
|
elsif ($op->[1] =~ /^jump/) {
|
|
unless (exists $labels{$op->[3]}) {
|
|
push(@msgs, "$lineno: unknown label $op->[2]");
|
|
next;
|
|
}
|
|
$op = [ $op->[1], $trans->($op->[2]), "j$labels{$op->[3]}[0]",
|
|
(0) x ($max_opr-1) ];
|
|
}
|
|
elsif ($op->[1] eq 'print') {
|
|
$op = [ $op->[1], $trans->($op->[2]), (0) x $max_opr ];
|
|
}
|
|
elsif ($op->[1] eq 'ret') {
|
|
$op = [ 'ret', $trans->($op->[2]), (0) x $max_opr ];
|
|
}
|
|
else {
|
|
# a normal operator
|
|
my ($result, $name, @parms) = @$op;
|
|
|
|
if ($result =~ /^$numre$/) {
|
|
push(@msgs, "$lineno: target of operator cannot be a constant");
|
|
next;
|
|
}
|
|
$result = $trans->($result);
|
|
for my $parm (@parms) {
|
|
$parm = $trans->($parm);
|
|
}
|
|
push(@parms, (0) x ($max_opr-@parms));
|
|
$op = [ $op->[1], @parms, $result ];
|
|
}
|
|
}
|
|
|
|
# more validation than a real assembler
|
|
# not trying to solve the halting problem...
|
|
if (@ops && $ops[-1][0] ne 'ret' && $ops[-1][0] ne 'jump') {
|
|
push(@msgs, ": the last instruction must be ret or jump");
|
|
}
|
|
|
|
$self->{nregs} = \@nregs;
|
|
$self->{cregs} = \@cregs;
|
|
|
|
if (@msgs) {
|
|
$self->error(join("\n", @msgs));
|
|
return 0;
|
|
}
|
|
|
|
return \@ops;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Imager::Expr::Assem - an assembler for producing code for the Imager
|
|
register machine
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Imager::Expr::Assem;
|
|
my $expr = Imager::Expr->new(assem=>'...', ...)
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module is a simple Imager::Expr compiler that compiles a
|
|
low-level language that has a nearly 1-to-1 relationship to the
|
|
internal representation used for compiled register machine code.
|
|
|
|
=head2 Syntax
|
|
|
|
Each line can contain multiple statements separated by semi-colons.
|
|
|
|
Anything after '#' in a line is ignored.
|
|
|
|
Types of statements:
|
|
|
|
=over 4
|
|
|
|
=item variable definition
|
|
|
|
=over 4
|
|
|
|
C<var> I<name>:I<type>
|
|
|
|
=back
|
|
|
|
defines variable I<name> to have I<type>, which can be any of C<n> or
|
|
C<num> for a numeric type or C<pixel>, C<p> or C<c> for a pixel or
|
|
color type.
|
|
|
|
Variable names cannot include white-space.
|
|
|
|
=item operators
|
|
|
|
Operators can be split into 3 basic types, those that have a result
|
|
value, those that don't and the null operator, eg. jump has no value.
|
|
|
|
The format for operators that return a value is typically:
|
|
|
|
=over 4
|
|
|
|
I<result> = I<operator> I<operand> ...
|
|
|
|
=back
|
|
|
|
and for those that don't return a value:
|
|
|
|
=over 4
|
|
|
|
I<operator> I<operand>
|
|
|
|
=back
|
|
|
|
where operator is any valid register machine operator, result is any
|
|
variable defined with C<var>, and operands are variables, constants or
|
|
literals, or for jump operators, labels.
|
|
|
|
The set operator can be simplified to:
|
|
|
|
=over 4
|
|
|
|
I<result> = I<operator>
|
|
|
|
=back
|
|
|
|
All operators maybe preceded by a label, which is any non-white-space
|
|
text immediately followed by a colon (':').
|
|
|
|
=back
|
|
|
|
=head1 BUGS
|
|
|
|
Note that the current optimizer may produce incorrect optimization for
|
|
your code, fortunately the optimizer will disable itself if you
|
|
include any jump operator in your code. A single jump to anywhere
|
|
after your final C<ret> operator can be used to disable the optimizer
|
|
without slowing down your code.
|
|
|
|
There's currently no high-level code generation that can generate code
|
|
with loops or real conditions.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
Imager(3), F<transform.perl>, F<regmach.c>
|
|
|
|
=head1 AUTHOR
|
|
|
|
Tony Cook <tony@develop-help.com>
|
|
|
|
=cut
|