Imager::Expr::Assem - an assembler for producing code for the Imager

Imager documentation Contained in the Imager distribution.

Index

Code Index:

NAME

Top

  Imager::Expr::Assem - an assembler for producing code for the Imager
  register machine

SYNOPSIS

Top

  use Imager::Expr::Assem;
  my $expr = Imager::Expr->new(assem=>'...', ...)

DESCRIPTION

Top

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.

Syntax

Each line can contain multiple statements separated by semi-colons.

Anything after '#' in a line is ignored.

Types of statements:

variable definition

var name:type

defines variable name to have 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 white-space.

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:

result = operator operand ...

and for those that don't return a value:

operator operand

where operator is any valid register machine operator, result is any variable defined with var, and operands are variables, constants or literals, or for jump operators, labels.

The set operator can be simplified to:

result = operator

All operators maybe preceded by a label, which is any non-white-space text immediately followed by a colon (':').

BUGS

Top

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.

SEE ALSO

Top

Imager(3), transform.perl, regmach.c

AUTHOR

Top

Tony Cook <tony@develop-help.com>

Imager documentation Contained in the Imager distribution. 
package Imager::Expr::Assem;
use strict;
use Imager::Expr;
use Imager::Regops;
use vars qw($VERSION);

$VERSION = "1.003";

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__