languages/urm/urmc

   1 #! perl -w
   2 # urmc - 2003-2005 (c) by Marcus Thiesen
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 urmc - This is just another little language for Parrot
   8
   9 =head1 LICENSE
  10
  11 This code is under the GPL
  12
  13 =head1 AUTHOR
  14
  15 Markus Thiessen - <marcus@cpan.org>
  16
  17 =cut
  18
  19 use strict;
  20 use FindBin;
  21 use lib "$FindBin::RealBin/../../lib";
  22
  23 use Data::Dumper;
  24 use Getopt::Long;
  25 use Parrot::Config;
  26
  27 # $opti is localized later
  28 use vars qw( $opti );
  29 $opti = 1; # more a debug flag
  30
  31 # globals
  32 my ( $filename, $silent );
  33 my $parrot = "$FindBin::RealBin$PConfig{slash}..$PConfig{slash}..$PConfig{slash}parrot$PConfig{exe}";
  34
  35 sub filename {
  36     my $arg = shift;
  37     if (-e $arg) {
  38         $filename = $arg;
  39     }
  40 }
  41
  42 GetOptions( "silent"     => \$silent,
  43             "<>"         => \&filename
  44           );
  45
  46 my $version = '0.4';
  47 my @pasm =
  48     ( qq{## Compiled by urmc $version},
  49       q{## 2003 (c) by Marcus Thiesen},
  50       q{## <marcus@cpan.org>},
  51       q{},
  52       q{_MAIN:},
  53       qq{\tget_params "(0)", P5    # Get command line},
  54       qq{\tshift S1, P5           # we don't need the scriptname},
  55     );
  56
  57 my $lp = qr/\s*(\d+)\s*\:/; #line prefix (1:)
  58 my (%lines, %jtarget);      # tcount lines and jump targets
  59 my $out_reg;                # save the output registers name
  60
  61 my @source;
  62 if ($filename) {
  63     open SOURCE, $filename or die "Can't get sourcefile $filename :$!";
  64     @source = <SOURCE>;
  65     close SOURCE; ### if gnu would hear that... :-)
  66 } else {
  67     die "$0 <file>"
  68 }
  69
  70 sub warning{
  71     return if $silent;
  72     my ($warning, $linenr) = @_;
  73     print STDERR "WARNING: $warning is not standard URM at line $linenr\n";
  74 }
  75
  76 ### memory managment:
  77
  78 my $stackcount = 0;
  79 my %look_tbl;
  80 my %reg_tbl;
  81 my %lra_tbl;
  82
  83 for my $i (0..31) { $reg_tbl{$i} = 0; }
  84
  85 # for debugging purposes
  86 sub dump_tables{
  87     print "\$stackcount:\t $stackcount\n";
  88
  89     print "reg_tbl:\n";
  90     map { print "$_\t => $reg_tbl{$_}\n"} sort { $a <=> $b } keys %reg_tbl;
  91
  92     print "look_tbl:\n";
  93     map { print "$_\t => $look_tbl{$_}\n"} sort { $a <=> $b } keys %look_tbl;
  94
  95     print "lra_tbl:\n";
  96 }
  97
  98 sub mmu {
  99     my $name = shift;
 100
 101     ## lookup the register
 102     if ((defined $look_tbl{$name}) &&
 103         ($look_tbl{$name} =~ /^I(\d+)/)) {
 104         return $1;
 105     }
 106
 107     ## if not on stack: get a free one
 108     foreach my $reg (sort {$a <=> $b} keys %reg_tbl) {
 109         unless ($reg_tbl{$reg}) {
 110             $reg_tbl{$reg} = $name;
 111             my $time = time();
 112             $lra_tbl{$time} = $reg;
 113             $look_tbl{$name} = "I$reg";
 114             return $reg;
 115         }
 116     }
 117
 118     ### no free registers left or on stack
 119     # on stack
 120     if (defined $look_tbl{$name}) {
 121         # get last recently allocated:
 122         my @times = sort { $a <=> $b } keys %lra_tbl;
 123         my $time = shift @times;
 124
 125         my $old = $lra_tbl{"$time"};
 126         die "\$old undefined\n" unless defined $old;
 127         delete $lra_tbl{$time};
 128         # save register nr $old on stack
 129         push @pasm, "\tsave I$old";
 130         $look_tbl{$reg_tbl{$old}} = $stackcount;
 131         $reg_tbl{$old} = 0;
 132         $stackcount++;
 133
 134
 135         # get requested register from stack
 136         $stackcount--;
 137         my $nr_on_stack = ($stackcount - $look_tbl{$name}) - 1;
 138         my $rotate_more =  $stackcount - 1 - $nr_on_stack - 1;
 139
 140         for my $i (0..$nr_on_stack) {
 141             push @pasm,  "\trotate_up $stackcount";
 142         }
 143         push @pasm, "\trestore I$old";
 144         for my $i (0..$rotate_more) {
 145             push @pasm,  "\trotate_up $stackcount";
 146         }
 147
 148
 149 #        push @pasm, "\tlookback I$old, $nr_on_stack";
 150
 151         $look_tbl{$name} = "I$old";
 152         $lra_tbl{time()} = $old;
 153         $reg_tbl{$old} = "$name";
 154
 155         return $old;
 156     }
 157
 158     # no free register left
 159     # free one and call yourself
 160     # get last recently allocated:
 161     my @times = sort { $a <=> $b } keys %lra_tbl;
 162     my $time = shift @times;
 163     my $old = $lra_tbl{"$time"};
 164     delete $lra_tbl{$time};
 165     # save register nr $old on stack
 166     push @pasm, "\tsave I$old";
 167     $look_tbl{$reg_tbl{$old}} = $stackcount;
 168     $reg_tbl{$old} = 0;
 169     $stackcount++;
 170     return mmu($name);
 171 }
 172
 173 ### The parser
 174 foreach my $line (@source) {
 175     next unless defined $line;
 176     next if $line =~ /^\#/;    # comments
 177     next if $line =~ /^\s+$/;  # spacy lines
 178     $line =~ s/\#.+//;         # stip in line comments;
 179     chomp $line;
 180     # parse in(r1,r2); out(r3); or out(r3);  or in(r34);
 181     if ( ( undef, my $in, undef, my $out ) =
 182              $line =~ m/^(\s*in\(([0-9r\ ,]*?)\);)?  # optional input registers
 183                         (\s*out\(r(\d+)\);)?         # optional output register
 184                         \s*$                         # insignificant lines are already skipped
 185                        /x ) {
 186         $in ||= '';
 187         $out_reg = $out if defined $out;
 188         foreach ( split( /\s*,\s*/, $in ) ) {
 189             my ( $in_reg ) = m/r(\d+)/;
 190             my $rn = "I" . (mmu $in_reg);
 191             push @pasm, "\t#get input for $_";
 192             push @pasm, "\tshift S0, P5";
 193             push @pasm, "\tset $rn, S0";
 194         }
 195         next;
 196     }
 197     #parse 0: r3 <- 0
 198     elsif ($line =~ /$lp\s*r(\d+)\s*<-\s*(\d+)\s*$/o) {
 199         $lines{$1} = 1;
 200         if ($3 != 0) {
 201             local $opti = 0;
 202             warning("Assigning not 0 to a register", $1);
 203         }
 204         ## parrot does the work for us....
 205         if ($opti <= 1) {
 206         push @pasm, "L$1:";
 207         push @pasm, "\tset I" . (mmu($2)) . ", $3\t\#$line";
 208         next;
 209         }
 210     }
 211     #parse 3: if r2 = 0 goto 7
 212     elsif ($line =~ /$lp\s*if\sr(\d+)\s*=\s*0\s*goto\s*(\d+)/o) {
 213         $lines{$1} = 1;
 214         push @pasm, "L$1:";
 215         push @pasm, "\teq I" . (mmu $2) . ", 0, L$3\t\#$line";
 216         $jtarget{$3} = 1;
 217         next;
 218     }
 219     elsif ($line =~ /^inline_pasm:/) {
 220         $line =~ s/^inline_pasm://;
 221         push @pasm, $line;
 222         next;
 223     }
 224     #parse 4: r2 <- r2 +|- 1
 225     elsif ($line =~
 226            /$lp\s*r(\d+)\s*<-\s*r(\d+)\s*(\+|-)\s*(?:(r(\d+))|(\d+))/o ) {
 227         $lines{$1} = 1;
 228         if ($2 != $3) {
 229             warning("Assigning one register to another", $1);
 230         }
 231         my $rn3;
 232         if (defined $6) {
 233             warning("Assigning sum of two registers", $1);
 234             $rn3 = "I" . (mmu $6);
 235         }
 236         elsif ((defined $6) && ($6 != 1)) {
 237             warning("Adding more than one", $1);
 238         }
 239
 240         push @pasm, "L$1:";
 241         my $rn1 = "I" . (mmu $2);
 242         my $rn2 = "I" . (mmu $3);
 243         $rn3 = 1 unless defined $rn3;
 244         if ($4 eq "+") {
 245             push @pasm, "\tadd $rn1, $rn2, $rn3\t\#$line";
 246         } else {
 247             push @pasm, "\tsub $rn1, $rn2, $rn3\t\#$line";
 248         }
 249         next;
 250     }
 251     #parse 5: goto 5
 252     elsif ($line =~ /$lp\s*goto\s*(\d+)/) {
 253         $lines{$1} = 1;
 254         push @pasm, "L$1:";
 255         push @pasm, "\tbranch L$2\t\#$line";
 256         $jtarget{$2} = 1;
 257         next;
 258     }
 259     else {
 260         die "SYNTAX ERROR:\n$line\nCan't parse line\n";
 261     }
 262
 263 }
 264
 265 my @newpasm;
 266
 267 ## clean up the labels
 268 if ($opti > 0) {
 269     for my $line (@pasm) {
 270         if ($line =~ /^L(\d+)/) {
 271             push @newpasm, $line if exists $jtarget{$1};
 272             next;
 273         }
 274         push @newpasm, $line;
 275     }
 276     @pasm = @newpasm;
 277 }
 278
 279 if (scalar %jtarget) {
 280     foreach my $key (keys %jtarget) {
 281         next if exists $lines{$key};
 282         if (defined $out_reg) {
 283             $out_reg = mmu($out_reg);
 284             push @pasm, "L$key:";
 285             push @pasm, "\tprint I$out_reg";
 286             push @pasm, "\tprint \"\\n\"";
 287         }
 288         push @pasm, "\tend";
 289     }
 290 } else {
 291     if (defined $out_reg) {
 292         $out_reg = mmu($out_reg);
 293         push @pasm, "\tprint I$out_reg";
 294         push @pasm, "\tprint \"\\n\"";
 295     }
 296     push @pasm, "end";
 297 }
 298
 299 # Consider this as a treewalker of an degenerate tree
 300 print join("\n", @pasm), "\n";