path: root/Master/tlpkg/tlperl.straw/lib/Imager/Expr/Assem.pm

package Imager::Expr::Assem;
use strict;
use Imager::Expr;
use Imager::Regops;
use vars qw($VERSION);

$VERSION = "1.002";

use vars qw(@ISA);
@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 regmach 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 'n' or
'num' for a numeric type or 'pixel', 'p' or 'c' for a pixel or color
type.

Variable names cannot include whitespace.

=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 regmach 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-whitespace
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 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), transform.perl, regmach.c

=head1 AUTHOR

Tony Cook <tony@develop-help.com>

=cut