Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 762 lines (628 sloc) 18.9 KB
#!/usr/bin/perl -w
use utf8;
# Modern::Perl
use strict;
use warnings;
sub say { print "$_\n" for @_; }
use Getopt::Long;
# Command line options
my $help;
my $dest;
my $lines_until_header = 20;
my $verbose;
my $debug;
my $vhdl;
GetOptions(
'help|h' => \$help,
'destination|d=s' => \$dest,
'header|l=i' => \$lines_until_header,
'verbose|v' => \$verbose,
'debug' => \$debug,
'vhdl' => \$vhdl,
);
$dest = "code_output" if !$dest;
my $src = $ARGV[0];
if ($help || !$src) {
say "Convert control code comments to actual control code.";
say " options:";
say " -h --help Show this screen.";
say " -v --verbose Verbose output signals in a human readable format.";
say " -vhdl Makes my life easier.";
exit;
}
# Ouput format
my $h = "game FIFO IR ADR1 ADR2 OP M1 M2 mem1 mem2 mem3 mem_addr ALU1 ALU2 ALU buss PC uPC uPC_addr";
my $c = " 00 00 0 00 00 0 00 00 00 00 00 000 00 0 000 000 00 00000 00000000";
my %ALU = (
load => "001",
'+' => "010",
'-' =>"011",
'++' =>"100",
'--' => "101",
'0' => "110",
);
my %buss = (
PC => "000",
OP => "001",
M1 => "010",
M2 => "011",
ALU1 => "100",
FIFO => "101",
IN => "110",
);
# For mem1 mem2 mem3
my %mem = (
read => "01",
write => "10",
);
my %mem_map = (
OP => "mem1",
M1 => "mem2",
M2 => "mem3",
);
# Single value shorthands will be a shorthand for
# position: $position{<val>} value: $registers{<val>}->{<key>}
my %singles = (
jmp => "uPC",
jmpZ => "uPC",
jmpIN => "uPC",
jmpC => "uPC",
jmpS => "uPC",
jmpAimm => "uPC",
jmpAdir => "uPC",
jmpApre => "uPC",
jmpBimm => "uPC",
jmpBdir => "uPC",
jmpBpre => "uPC",
change_player => "FIFO",
fifo_next => "FIFO",
game_started => "game",
check_gameover => "game",
shall_load => "game",
);
my %registers = (
uPC => {
'++' => "00000",
op_addr => "00001",
jmp => "00010",
jmpZ => "00011",
jmpIN =>"00100",
jmpC => "00101",
jmpS => "00110",
jmpN => "00111",
jmpE => "01000",
jmpL => "01001", # Deprecated!
jmpO => "01010",
jmpAimm => "10000",
jmpAdir => "10001",
jmpApre => "10010",
jmpBimm => "10011",
jmpBdir => "10100",
jmpBpre => "10101",
'0' => "11111",
},
PC => {
buss => "01",
'++' => "10",
'0' => "11",
},
IR => {
buss => "1",
},
ADR1 => {
buss => "01",
M1 => "10",
ALU1 => "11",
},
ADR2 => {
buss => "01",
M2 => "10",
ALU2 => "11",
},
ALU1 => {
M1 => "00",
buss => "01",
M2 => "10",
mem_addr => "11",
},
ALU2 => {
M1 => "0",
M2 => "1",
},
OP => {
buss => "1",
},
M1 => {
buss => "01",
ALU1 => "10",
ALU2 => "11",
},
M2 => {
buss => "01",
ALU1 => "10",
ALU2 => "11",
},
mem_addr => {
buss => "001",
ALU1 => "010",
ALU2 => "011",
ADR1 => "100",
ADR2 => "101",
PC => "110",
},
FIFO => {
buss => "01",
change_player => "10",
fifo_next => "11",
},
game => {
game_started => "01",
check_gameover => "10",
shall_load => "11",
},
);
# Positions for our subsignals in the grand control scheme
my %positions;
# Calculate positions from output format
my @namechunks = split (/\s+/, trim($h));
my @codechunks = split (/\s+/, trim($c));
my $signallength = length (join "", @codechunks);
my $l = $signallength - 1;
my @vhdl_output;
for my $chunk (@codechunks) {
my $r = $l - length ($chunk) + 1;
my $name = shift @namechunks;
# Output vhdl shortcut for signals
if ($vhdl) {
if ($l == $r) {
push (@vhdl_output, "${name}_code <= signals($l);");
}
else {
push (@vhdl_output, "${name}_code <= signals($l downto $r);");
}
}
say "$name $l .. $r" if $debug;
$positions{$name} = [$r .. $l];
$l = $r - 1;
}
if ($vhdl) {
say $_ for (reverse @vhdl_output);
say "";
}
say "" if $debug;
# Reverse the positions (we're using strings 0 indexed to the left but vhdl uses bits reversed)
for my $key (keys %positions) {
my @mod;
for my $val (@{$positions{$key}}) {
push (@mod, $signallength - $val - 1);
}
# Need to reverse here as otherwise we'll assign eg (43, 42) to something which will reverse our code
$positions{$key} = [reverse @mod];
}
# Convenience function, take reference to list and a string
sub update {
my ($signal, $pos, $what) = @_;
@$signal[ @{$pos} ] = split (//, $what);
}
open my $in, '<', $src or die "Couldn't open file $src $!";
my $codeline = 0;
my $rows_since_help = 0;
my $last_was_code = 0;
my $header_shown = 0;
# Collect output here for postprocessing etc
my @output;
# Push lines here after first read through
my @lines;
# Labels with their line of code
my %labels;
# Search for labels and log their address
while (my $line = <$in>) {
chomp $line;
# Ignore comments
if ($line =~ /^;/) {
push (@lines, $line);
}
# And empty lines
elsif ($line =~ /^\s*$/) {
push (@lines, $line);
}
# It's a line of code!
else {
# Remove comments
my ($code) = $line =~ /^([^;]*)/;
# If we have a label
if ($code =~ /^:([A-Z0-9]+)\s+(.*)/) {
# Store it's address (start with 0)
$labels{$1} = $codeline;
# Remove label and push it
push (@lines, $2);
}
else {
push (@lines, $code);
}
$codeline++;
}
}
# List labels
if ($debug) {
say "Labels:";
for my $k (keys %labels) {
say "labels{$k} = " . dec2hex ($labels{$k});
}
}
if ($vhdl) {
my %instructions = (
DAT => "0000",
MOV => "0001",
ADD => "0010",
SUB => "0011",
JMP => "0100",
JMPZ => "0101",
JMPN => "0110",
CMP => "0111",
SLT => "1000",
DJN => "1001",
SPL => "1010",
);
# Create a sorted pair instr -> code
my @pairs = sort { $a->[1] cmp $b->[1] }
map { [ $_ => $instructions{$_} ] } keys %instructions;
for (@pairs) {
my ($instr, $code) = (@$_);
die "No $instr label!" if !exists $labels{$instr};
my $pos = dec2bin ($labels{$instr});
$pos = '0' x (8 - length($pos)) . $pos;
my $hpos = dec2hex ($labels{$instr});
say "\"$pos\" when \"$code\", -- $instr $hpos";
}
say '"11111111" when others;';
exit;
}
$codeline = 0;
# Process and write
for my $line (@lines) {
# Comments
if ($line =~ /^;(.*)/) {
# If we're in verbose, simply output comments
if ($verbose) {
#say $line;
push (@output, $line);
}
# Otherwise transform into vhdl comments
else {
push (@output, "-- " . trim ($1));
}
$last_was_code = 0;
next;
}
# Simply output empty lines
elsif ($line =~ /^\s*$/) {
#say $line;
push (@output, $line);
$last_was_code = 0;
next;
}
$codeline++;
my @signal = ((0) x $signallength);
my @comments;
my $buss_used = 0;
my $curr_mem_addr = "";
my $mem_data_used = 0;
my $mem_err = 0;
my $alu_op = "";
my $alu_err = 0;
for my $cmd (split /\s*,\s*/, $line)
{
$cmd = trim ($cmd);
# Don't process label definitions
if ($cmd =~ /^:/) {
push (@comments, $cmd);
}
# Grab single word affixes eg PC++, ALU--
elsif ($cmd =~ /^(\S+?)([-+<]+)$/) {
my ($reg, $op) = ($1, $2);
if (exists $registers{$reg}->{$op}) {
update (\@signal, $positions{$reg}, $registers{$reg}->{$op});
push (@comments, $cmd);
}
elsif ($reg =~ /ALU[12]?/) {
$alu_err = 1 if $alu_op && $alu_op ne $op;
$alu_op = $op;
update (\@signal, $positions{$reg}, $ALU{$op});
push (@comments, $cmd);
}
else {
die "Unknown command: $cmd";
}
}
# We have a single shorthand notation
elsif (exists $singles{$cmd}) {
my $reg = $singles{$cmd};
update (\@signal, $positions{$reg}, $registers{$reg}->{$cmd});
push (@comments, $cmd);
}
# src -> dest
elsif ($cmd =~ /(\S+)\s*[=-]>\s*(\S+)/) {
my ($src, $dest) = ($1, $2);
# src -> buss
if ($dest eq "buss" && exists $buss{$src}) {
$buss_used++;
update (\@signal, $positions{$dest}, $buss{$src});
push (@comments, $cmd);
}
# src -> mem
elsif ($dest eq "mem") {
$mem_data_used++;
if ($src =~ /OP|M1|M2/) {
# Set mem to write
update (\@signal, $positions{$mem_map{$src}}, $mem{write});
push (@comments, $cmd);
}
else {
die "Unknown command: $cmd";
}
}
# mem -> src
elsif ($src eq "mem") {
$mem_data_used++;
if ($dest =~ /OP|M1|M2/) {
# Set mem to read
update (\@signal, $positions{$mem_map{$dest}}, $mem{read});
push (@comments, $cmd);
}
else {
die "Unknown command: $cmd";
}
}
# Handle direct
elsif (exists $registers{$dest}->{$src}) {
update (\@signal, $positions{$dest}, $registers{$dest}->{$src});
# load if ALU
if ($dest =~ /^ALU/) {
my $op = "load";
update (\@signal, $positions{ALU}, $ALU{$op});
$alu_err = 1 if $alu_op && $alu_op ne $op;
}
$buss_used++ if $dest eq "buss";
if ($dest eq "mem_addr") {
$mem_err = 1 if $curr_mem_addr && $curr_mem_addr ne $src;
$curr_mem_addr = $src;
}
push (@comments, $cmd);
}
# Try to route through buss
elsif (exists $registers{$dest}->{buss} && exists $buss{$src}) {
$buss_used++;
# Update src -> buss
update (\@signal, $positions{buss}, $buss{$src});
# Update buss -> dest
update (\@signal, $positions{$dest}, $registers{$dest}->{buss});
# load if ALU
if ($dest =~ /^ALU/) {
my $op = "load";
update (\@signal, $positions{ALU}, $ALU{$op});
$alu_err = 1 if $alu_op && $alu_op ne $op;
}
# Check if mem_addr will get set
if ($dest eq "mem_addr") {
$mem_err = 1 if $curr_mem_addr && $curr_mem_addr ne $src;
$curr_mem_addr = $src;
}
# Comment as src -> buss, buss -> dest
push (@comments, "$src -> buss");
push (@comments, "buss -> $dest");
}
else {
die "Unknown command: $cmd";
}
}
# ALUx += src or ALUx -= src
elsif ($cmd =~ /^(ALU[12])\s*(\+|-)=\s*(\S+)$/) {
my ($alu, $op, $src) = ($1, $2, $3);
# Check direct connection
if (exists $registers{$alu}->{$src}) {
$alu_err = 1 if $alu_op && $alu_op ne $op;
$alu_op = $op;
# Update data
update (\@signal, $positions{$alu}, $registers{$alu}->{$src});
# Update alu action
update (\@signal, $positions{ALU}, $ALU{$op});
push (@comments, $cmd);
}
# Try to route through buss
elsif (exists $registers{$alu}->{buss} && exists $buss{$src}) {
$buss_used++;
$alu_err = 1 if $alu_op && $alu_op ne $op;
$alu_op = $op;
# Update src -> buss
update (\@signal, $positions{buss}, $buss{$src});
# Update buss -> alu
update (\@signal, $positions{$alu}, $registers{$alu}->{buss});
# load ALU
update (\@signal, $positions{ALU}, $ALU{$op});
push (@comments, $cmd);
}
else {
die "Unknown command: $cmd";
}
}
# TODO all jumps does not have addresses?
# Handle jumps eg jmp, jmp 0, jmp +1, jmpS -1, jmpIN
elsif ($cmd =~ /^(jmp\S*)\s+(\S+)/) {
my ($jmp, $where) = ($1, $2);
# Check that uPC has support for this jump
if (exists $registers{uPC}->{$jmp}) {
# Check to see if we have a relative absolute address
$where =~ /^([+-])?(.*)/;
my $op = $1;
$op = "" if ! $op;
my $val = $2;
my $label = "";
# Convert label def
if ($val =~ /^\$([A-Z0-9]+)/) {
$label = $1;
if (exists $labels{$label}) {
$val = dec2hex ($labels{$label});
}
else {
die "Unknown label: $label";
}
}
my $bin;
if ($val =~ /^[0123456789ABCDEF]{0,2}$/i) {
$bin = hex2bin ($val);
}
elsif ($val =~ /^[01]+$/) {
$bin = $val;
}
else {
die "Unknown command: $cmd";
}
if ($op =~ /^[+-]$/) {
my $curr_row = $codeline - 1;
my $off = bin2dec ($bin);
my $abs = $op eq "+" ? $curr_row + $off : $curr_row - $off;
my $new_bin = dec2bin ($abs);
my $new_hex = dec2hex ($abs);
my $currhex = dec2hex ($curr_row);
push (@output, "$curr_row($currhex) $op $off = $abs($new_hex) -> $new_bin") if $debug;
$bin = $new_bin;
}
# Force to length 8
if (length($bin) < 8) {
$bin = '0' x (8 - length($bin)) . $bin;
}
elsif (length($bin) > 8) {
# Truncate from the back so 00 1111 1111 -> 1111 1111
$bin = substr $bin, -8;
}
# Set jump address
update (\@signal, $positions{uPC_addr}, $bin);
# Set jump
update (\@signal, $positions{uPC}, $registers{uPC}->{$jmp});
# Include label name in comment
if ($label) {
my $addr = dec2hex ($labels{$label});
push (@comments, "$jmp $label($addr)");
}
else {
# Ugly I know ^^
my $dec = bin2dec ($bin);
my $hex = dec2hex ($dec);
push (@comments, "$cmd($hex)");
}
}
else {
die "Unknown command: $cmd";
}
}
# var = stuff eg uPC = 0
elsif ($cmd =~ /(\S+)\s*=\s*(\S+)/) {
my ($var, $res) = ($1, $2);
if ($var eq "uPC_addr") {
die "Unknown command: $cmd";
}
# Check special eg uPC = 0
if (exists $registers{$var} && exists $registers{$var}->{$res}) {
update (\@signal, $positions{$var}, $registers{$var}->{$res});
push (@comments, $cmd);
}
# ALU = x
elsif (exists $ALU{$res}) {
update (\@signal, $positions{ALU}, $ALU{$res});
push (@comments, $cmd);
}
else {
die "Unknown command: $cmd";
}
}
else {
die "Unknown command: $cmd";
}
}
# Can only address all memory with one address at a time
if ($mem_err) {
push (@comments, "! 2x -> mem_addr !");
}
# Check that we're only using our buss once
if ($buss_used > 1) {
push (@comments, "! 2x -> buss !");
}
# Check only one operation for the alu
if ($alu_err) {
push (@comments, "! 2x alu op !");
}
# Output verbose mode, for humans
if ($verbose) {
# Output verbose output, format lines like this with the occassional help header
if (!$header_shown || $rows_since_help > $lines_until_header && !$last_was_code) {
#say " $h";
push (@output, " $h");
$header_shown = 1;
$rows_since_help = 0;
}
$last_was_code = 1;
$rows_since_help++;
my $result = "";
my $last = 0;
my $signal = join ("", @signal);
my @codechunks = split (/\s+/, $c);
my @spacechunks = split (/\S+/, $c);
# Remove if there's an opening space
if ($c =~ /^\s/) {
$result .= shift @spacechunks;
shift @codechunks;
}
# Will split out an empty string space otherwise
else {
shift @spacechunks;
}
# Bundle a code string by alternating code/space
for my $code (@codechunks) {
my $l = length($code);
my $sig = substr ($signal, $last, $l);
$result .= $sig;
my $space = shift @spacechunks;
$result .= $space if $space;
$last += $l;
}
my $hexline = dec2hex ($codeline - 1);
#say "$hexline $result ; " . join (", ", @comments);
push (@output, "$hexline $result ; " . trim (join (", ", @comments)));
}
# Output for vhdl copy paste
else {
my $res = '"' . join ("", @signal) . '", -- ' . trim (join (", ", @comments));
#say $res;
push (@output, $res);
}
}
# Print output
my $txt = join ("\n", @output);
say $txt;
sub dec2hex { # Force at least length 2
my $d = shift;
my $h = sprintf ("%x", $d);
$h = "0$h" if length ($h) < 2;
return $h;
}
sub hex2bin {
my $h = shift;
my $hlen = length($h);
my $blen = $hlen * 4;
return unpack("B$blen", pack("H$hlen", $h));
}
sub dec2bin {
my $str = unpack("B32", pack("N", shift));
$str =~ s/^0+(?=\d)//; # otherwise you'll get leading zeros
return $str;
}
sub bin2dec {
return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
}
sub trim {
my $string = shift;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
return $string;
}
You can’t perform that action at this time.