lib/Imager/Expr/Assem.pm

   1 package Imager::Expr::Assem;
   2 use strict;
   3 use Imager::Expr;
   4 use Imager::Regops;
   5
   6 use vars qw(@ISA);
   7 @ISA = qw(Imager::Expr);
   8
   9 __PACKAGE__->register_type('assem');
  10
  11 sub compile {
  12   my ($self, $expr, $opts) = @_;
  13   my %nregs;
  14   my @vars = $self->_variables();
  15   my @nregs = (0) x @vars;
  16   my @cregs;
  17   my %vars;
  18   @vars{@vars} = map { "r$_" } 0..$#vars;
  19   my %labels;
  20   my @ops;
  21   my @msgs;
  22   my $attr = \%Imager::Regops::Attr;
  23
  24   # initially produce [ $linenum, $result, $opcode, @parms ]
  25   my $lineno = 0;
  26   while ($expr =~ s/^([^\n]+)(?:\n|$)//) {
  27     ++$lineno;
  28     my $line = $1;
  29     $line =~ s/#.*//;
  30     next if $line =~ /^\s*$/;
  31     for my $op (split /;/, $line) {
  32       if (my ($name, $type) = $op =~ /^\s*var\s+([^:]+):(\S+)\s*$/) {
  33         if (exists $vars{$name}) {
  34           push(@msgs, "$lineno: duplicate variable name '$name'");
  35           next;
  36         }
  37         if ($type eq 'num' || $type eq 'n') {
  38           $vars{$name} = 'r'.@nregs;
  39           push(@nregs, undef);
  40           next;
  41         }
  42         elsif ($type eq 'pixel' || $type eq 'p' || $type eq 'c') {
  43           $vars{$name} = 'p'.@cregs;
  44           push(@cregs, undef);
  45           next;
  46         }
  47         push(@msgs, "$lineno: unknown variable type $type");
  48         next;
  49       }
  50       # any statement can have a label
  51       if ($op =~ s/^\s*(\w+):\s*//) {
  52         if ($labels{$1}) {
  53           push(@msgs,
  54                "$lineno: duplicate label $1 (previous on $labels{$1}[1])");
  55           next;
  56         }
  57         $labels{$1} = [ scalar @ops, $lineno ];
  58       }
  59       next if $op =~ /^\s*$/;
  60       # jumps have special operand handling
  61       if ($op =~ /^\s*jump\s+(\w+)\s*$/) {
  62         push(@ops, [$lineno, "", "jump", $1]);
  63       }
  64       elsif (my ($code, $reg, $targ) =
  65              ($op =~ /^\s*(jumpz|jumpnz)\s+(\S+)\s+(\S+)\s*$/)) {
  66         push(@ops, [$lineno, "", $code, $reg, $targ]);
  67       }
  68       elsif ($op =~ /^\s*print\s+(\S+)\s*/) {
  69         push(@ops, [$lineno, "", 'print', $1 ]);
  70       }
  71       elsif ($op =~ /^\s*ret\s+(\S+)\s*/) {
  72         push(@ops, [$lineno, "", 'ret', $1]);
  73       }
  74       elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*$//) {
  75         # simple assignment
  76         push(@ops, [$lineno, $1, "set", $2]);
  77       }
  78       elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*//) {
  79         # some normal ops finally
  80         my ($result, $opcode) = ($1, $2);
  81         unless ($attr->{$opcode}) {
  82           push(@msgs, "$lineno: unknown operator $opcode");
  83           next;
  84         }
  85         my @oper;
  86         while ($op =~ s/(\S+)\s*//) {
  87           push(@oper, $1);
  88         }
  89         push(@ops, [$lineno, $result, $opcode, @oper]);
  90       }
  91       else {
  92         push(@msgs, "$lineno: invalid statement '$op'");
  93       }
  94     }
  95   }
  96
  97   my $max_opr = $Imager::Regops::MaxOperands;
  98   my $numre = $self->numre;
  99   my $trans =
 100     sub {
 101       # translate a name/number to a <type><digits>
 102       my ($name) = @_;
 103       $name = $self->{constants}{$name}
 104         if exists $self->{constants}{$name};
 105       if ($vars{$name}) {
 106         return $vars{$name};
 107       }
 108       elsif ($name =~ /^$numre$/) {
 109         $vars{$name} = 'r'.@nregs;
 110         push(@nregs, $name);
 111         return $vars{$name};
 112       }
 113       else {
 114         push(@msgs, "$lineno: undefined variable $name");
 115         return '';
 116       }
 117     };
 118   # now to translate symbols and so on
 119  OP: for my $op (@ops) {
 120     $lineno = shift @$op;
 121     if ($op->[1] eq 'jump') {
 122       unless (exists $labels{$op->[2]}) {
 123         push(@msgs, "$lineno: unknown label $op->[2]");
 124         next;
 125       }
 126       $op = [ 'jump', "j$labels{$op->[2]}[0]", (0) x $max_opr ];
 127     }
 128     elsif ($op->[1] =~ /^jump/) {
 129       unless (exists $labels{$op->[3]}) {
 130         push(@msgs, "$lineno: unknown label $op->[2]");
 131         next;
 132       }
 133       $op = [ $op->[1], $trans->($op->[2]), "j$labels{$op->[3]}[0]",
 134               (0) x ($max_opr-1) ];
 135     }
 136     elsif ($op->[1] eq 'print') {
 137       $op = [ $op->[1], $trans->($op->[2]), (0) x $max_opr ];
 138     }
 139     elsif ($op->[1] eq 'ret') {
 140       $op = [ 'ret', $trans->($op->[2]), (0) x $max_opr ];
 141     }
 142     else {
 143       # a normal operator
 144       my ($result, $name, @parms) = @$op;
 145
 146       if ($result =~ /^$numre$/) {
 147         push(@msgs, "$lineno: target of operator cannot be a constant");
 148         next;
 149       }
 150       $result = $trans->($result);
 151       for my $parm (@parms) {
 152         $parm = $trans->($parm);
 153       }
 154       push(@parms, (0) x ($max_opr-@parms));
 155       $op = [ $op->[1], @parms, $result ];
 156     }
 157   }
 158
 159   # more validation than a real assembler
 160   # not trying to solve the halting problem...
 161   if (@ops && $ops[-1][0] ne 'ret' && $ops[-1][0] ne 'jump') {
 162     push(@msgs, ": the last instruction must be ret or jump");
 163   }
 164
 165   $self->{nregs} = \@nregs;
 166   $self->{cregs} = \@cregs;
 167
 168   if (@msgs) {
 169     $self->error(join("\n", @msgs));
 170     return 0;
 171   }
 172
 173   return \@ops;
 174 }
 175
 176 1;
 177
 178 __END__
 179
 180 =head1 NAME
 181
 182   Imager::Expr::Assem - an assembler for producing code for the Imager
 183   register machine
 184
 185 =head1 SYNOPSIS
 186
 187   use Imager::Expr::Assem;
 188   my $expr = Imager::Expr->new(assem=>'...', ...)
 189
 190 =head1 DESCRIPTION
 191
 192 This module is a simple Imager::Expr compiler that compiles a
 193 low-level language that has a nearly 1-to-1 relationship to the
 194 internal representation used for compiled regmach code.
 195
 196 =head2 Syntax
 197
 198 Each line can contain multiple statements separated by semi-colons.
 199
 200 Anything after '#' in a line is ignored.
 201
 202 Types of statements:
 203
 204 =over 4
 205
 206 =item variable definition
 207
 208 =over 4
 209
 210 C<var> I<name>:I<type>
 211
 212 =back
 213
 214 defines variable I<name> to have I<type>, which can be any of 'n' or
 215 'num' for a numeric type or 'pixel', 'p' or 'c' for a pixel or color
 216 type.
 217
 218 Variable names cannot include whitespace.
 219
 220 =item operators
 221
 222 Operators can be split into 3 basic types, those that have a result
 223 value, those that don't and the null operator, eg. jump has no value.
 224
 225 The format for operators that return a value is typically:
 226
 227 =over 4
 228
 229 I<result> = I<operator> I<operand> ...
 230
 231 =back
 232
 233 and for those that don't return a value:
 234
 235 =over 4
 236
 237 I<operator> I<operand>
 238
 239 =back
 240
 241 where operator is any valid regmach operator, result is any variable
 242 defined with C<var>, and operands are variables, constants or
 243 literals, or for jump operators, labels.
 244
 245 The set operator can be simplified to:
 246
 247 =over 4
 248
 249 I<result> = I<operator>
 250
 251 =back
 252
 253 All operators maybe preceded by a label, which is any non-whitespace
 254 text immediately followed by a colon (':').
 255
 256 =back
 257
 258 =head1 BUGS
 259
 260 Note that the current optimizer may produce incorrect optimization for
 261 your code, fortunately the optimizer will disable itself if you
 262 include any jump operator in your code.  A single jump to anywhere
 263 after your final ret operator can be used to disable the optimizer
 264 without slowing down your code.
 265
 266 There's currently no high-level code generation that can generate code
 267 with loops or real conditions.
 268
 269 =head1 SEE ALSO
 270
 271 Imager(3), transform.perl, regmach.c
 272
 273 =head1 AUTHOR
 274
 275 Tony Cook <tony@develop-help.com>
 276
 277 =cut