Initial Commit

database/perl/vendor/lib/Imager/Expr/Assem.pm

@@ -0,0 +1,279 @@
+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