Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
956 lines (804 sloc) 17 KB
#!/usr/bin/perl
use strict;
use warnings;
use POSIX qw/ceil/;
=for grammar
#<goal> -> ( <any_code_blk> | <const_blk> | <struct_blk> )*
#<any_code_blk> -> ( <code_blk> | <init_blk> | <main_blk> ) <str> <stmt>* .end;
#<code_blk> -> .sub
#<init_blk> -> .init
#<main_blk> -> .main
#<const_blk> -> .const <str> <const_stmt>* .end;
#<struct_blk> -> ( .struct | .data ) <str> <struct_stmt>* .end;
#<stmt> -> <label>? <dest>? <regtype>? <opcode> ( <lhs> ( ,? | , <rhs> ) )? ( : ( <imm> | <offset> | <jmp> ) )? ;
#<const_stmt> -> <label>? <const> ;
#<struct_stmt> -> <label>? size <int> ;
#<label> -> <id>? :
#<dest> -> <reg> =
#<regtype> -> ( INT | NUM | STR | PMC )
#<opcode> -> [ @OPS ]
#<lhs> -> <reg>
#<rhs> -> <reg>
#<imm> -> <int>
#<jmp> -> <id>
#<offset> -> ( <str> | <id> )? [ <id> ( [+-] <int> )? ]
#<const> -> ( <num> | <int> | <str> )
#<str> ~> m/(?:') ([^']*(?:(?:\')[^']*)*) (?:')/xms
#<str> ~> m/(?:") ([^"]*(?:(?:\")[^"]*)*) (?:")/xms
#<int> ~> m/(\d+)/xms
#<num> ~> m/( [+-]? \d+ (?: [.] \d+)? (?: [+-]? [e] \d+)? )/xms
#<id> ~> m/( [[:alpha:]] \w* )/xms
#<reg> ~> m/[$] [I | N | S | P]? ([\d]+)/xms
=cut
# Load> :r microcode.h
# Convert> :'<,'>!perl -ne 'if (m/BEGIN OPS_ENUM/..m/END OPS_ENUM/) { s[//][\#]; s/^\s*OP_/ /; s/=/=>/; print $_ }'
my %ops = (
# BEGIN OPS_ENUM
# Execution Ops
noop => 0,
end => 1,
# Math Ops
add => 2,
'sub' => 3,
mul => 4,
div => 5,
mod => 6,
and => 7,
or => 8,
xor => 9,
not => 10,
shl => 11,
shr => 12,
# Comparison Ops
iseq => 13,
isgt => 14,
isge => 15,
# Flow Control Ops
goto => 16,
if => 17,
# Register Manipulation Ops
set => 18,
load_const => 19,
load_imm => 20,
coerce_int => 21,
coerce_num => 22,
coerce_str => 23,
coerce_pmc => 43,
# PMC Ops
new => 24,
store => 25,
load => 26,
push_arg => 27,
pop_arg => 28,
cnt_arg => 42,
call => 29,
push_ret => 39,
pop_ret => 40,
cnt_ret => 41,
lookup => 35,
ctx => 36,
new_ctx => 38,
block => 37,
# Environment Ops
loadlib => 30,
read => 31,
write => 32,
say => 33,
gripe => 34,
# These Ops
hcf => 63
# END OPS_ENUM
);
my %op_types = (
PMC => 0,
STR => 1,
NUM => 2,
INT => 3
);
my %flags = (
INIT => 0x01,
MAIN => 0x02,
);
my %seg_types = (
CODE => 0,
CONST => 1,
DATADEF => 2,
);
# Start of pattern. Items common to all parsing patterns, including ignoring
# comments
my $som = qr/\G (?: \s* [#] [^\n]* $)* \s* /xms;
# Set the max position the match has gotten to and reset the position
my $max = 0;
sub max
{
my $str = shift;
my $last_pos = shift;
$max = (pos($$str) || 0) > $max ? pos($$str) : $max;
pos($$str) = $last_pos;
#warn "$max\n";
}
#<goal> -> ( <any_code_blk> | <const_blk> | <struct_blk> )*
sub goal
{
my $str = shift;
my $pos = pos $$str;
my $result = [];
$max = 0;
#while (my $code = &code($str))
while (pos($$str) || 0 != length($$str))
{
my $code_blk = &any_code_blk($str);
if (defined $code_blk)
{
push @$result, $code_blk;
next;
}
my $const_blk = &const_blk($str);
if (defined $const_blk)
{
push @$result, $const_blk;
next;
}
my $struct_blk = &struct_blk($str);
if (defined $struct_blk)
{
push @$result, $struct_blk;
next;
}
last;
}
$$str =~ m/$som /ixmsgc;
if (pos($$str) != length($$str))
{
max($str, $pos);
return;
}
return $result;
}
#<any_code_blk> -> ( <code_blk> | <init_blk> | <main_blk> ) <str> <stmt>* .end;
sub any_code_blk
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
for my $blk (\&code_blk, \&init_blk, \&main_blk)
{
my $flags = $blk->($str);
if (defined $flags)
{
$result = {%$flags};
last;
}
}
$result->{typed} = "code";
my $named = &str($str);
if (!defined $named)
{
max($str, $pos);
return;
}
$result->{named} = $named;
$result->{stmts} = [];
while (my $stmt = &stmt($str))
{
push @{$result->{stmts}}, $stmt;
}
if ($$str !~ m/$som [.]end; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<code_blk> -> .sub
sub code_blk
{
my $str = shift;
my $pos = pos $$str;
if ($$str !~ m/$som [.]sub /ixmsgc)
{
max($str, $pos);
return;
}
return { flags => 0 };
}
#<init_blk> -> .init
sub init_blk
{
my $str = shift;
my $pos = pos $$str;
if ($$str !~ m/$som [.]init /ixmsgc)
{
max($str, $pos);
return;
}
return { flags => $flags{INIT} };
}
#<main_blk> -> .main
sub main_blk
{
my $str = shift;
my $pos = pos $$str;
if ($$str !~ m/$som [.]main /ixmsgc)
{
max($str, $pos);
return;
}
return { flags => $flags{MAIN} };
}
#<const_blk> -> .const <str> <const_stmt>* .end;
sub const_blk
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
if ($$str !~ m/$som [.] const /ixmsgc)
{
max($str, $pos);
return;
}
$result->{typed} = "const";
my $named = &str($str);
if (!defined $named)
{
max($str, $pos);
return;
}
$result->{named} = $named;
$result->{consts} = [];
while (my $const_stmt = &const_stmt($str))
{
push @{$result->{consts}}, $const_stmt;
}
if ($$str !~ m/$som [.]end; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<struct_blk> -> ( .struct | .data ) <str> <struct_stmt>* .end;
sub struct_blk
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
$result->{typed} = "struct";
if ($$str !~ m/$som [.] struct /ixmsgc)
{
if ($$str !~ m/$som [.] data /ixmsgc)
{
max($str, $pos);
return;
}
$result->{typed} = "data";
}
my $named = &str($str);
if (!defined $named)
{
max($str, $pos);
return;
}
$result->{named} = $named;
$result->{consts} = [];
while (my $struct_stmt = &struct_stmt($str))
{
push @{$result->{consts}}, $struct_stmt;
}
if ($$str !~ m/$som [.]end; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<stmt> -> <label>? <dest>? <regtype>? <opcode> ( <lhs> ( ,? | , <rhs> ) )? ( : ( <imm> | <offset> | <jmp> ) )? ;
sub stmt
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
$result->{label} = label($str);
$result->{dest} = dest ($str);
$result->{regtype} = regtype($str);
$result->{opcode} = opcode($str);
if (!defined $result->{opcode})
{
max($str, $pos);
return;
}
my $lhs = lhs($str);
if (defined $lhs)
{
$result->{src1} = $lhs;
if ($$str =~ m/$som , /ixmsgc)
{
$result->{src2} = rhs($str);
}
}
if ($$str =~ m/$som : /ixmsgc)
{
my $found = 0;
if ($found == 0)
{
my $imm = imm($str);
if (defined $imm)
{
$found = 1;
$result->{imm} = $imm;
}
}
if ($found == 0)
{
my $offset = offset($str);
if (defined $offset)
{
$found = 1;
$result->{offset} = $offset;
}
}
if ($found == 0)
{
my $jmp = jmp($str);
if (defined $jmp)
{
$found = 1;
$result->{jmp} = $jmp;
}
}
}
if ($$str !~ m/$som ; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<const_stmt> -> <label>? <const> ;
sub const_stmt
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
$result->{label} = label($str);
my ($type, $const) = const($str);
if (!defined $const)
{
max($str, $pos);
return;
}
$result->{type} = $type;
$result->{const} = $const;
if ($$str !~ m/$som ; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<struct_stmt> -> <label>? size <int> ;
sub struct_stmt
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
$result->{label} = label($str);
if ($$str !~ m/$som size /ixmsgc)
{
max($str, $pos);
return;
}
my $size = &int($str);
if (!defined $size)
{
max($str, $pos);
return;
}
$result->{size} = $size;
if ($$str !~ m/$som ; /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<label> -> <id>? :
sub label
{
my $str = shift;
my $pos = pos $$str;
my $id = id($str);
if ($$str !~ m/$som : /ixmsgc)
{
max($str, $pos);
return;
}
return $id;
}
#<dest> -> <reg> =
sub dest
{
my $str = shift;
my $pos = pos $$str;
my $reg = reg($str);
if (!defined $reg)
{
max($str, $pos);
return;
}
if ($$str !~ m/$som = /ixmsgc)
{
max($str, $pos);
return;
}
return $reg;
}
#<regtype> -> ( INT | NUM | STR | PMC )
sub regtype
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som (INT | NUM | STR | PMC)/ixmsgc;
return $result;
}
#<opcode> -> [ @OPS ]
sub opcode
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som (\w*)/ixmsgc;
if (!exists $ops{lc($result)})
{
max($str, $pos);
return;
}
return lc $result;
}
#<lhs> -> <reg>
sub lhs
{
my $str = shift;
my $pos = pos $$str;
my $reg = reg($str);
if (!defined $reg)
{
max($str, $pos);
return;
}
return $reg;
}
#<rhs> -> <reg>
sub rhs
{
my $str = shift;
my $pos = pos $$str;
my $reg = reg($str);
if (!defined $reg)
{
max($str, $pos);
return;
}
return $reg;
}
#<imm> -> <int>
sub imm
{
my $str = shift;
my $pos = pos $$str;
my $reg = &int($str);
if (!defined $reg)
{
max($str, $pos);
return;
}
return $reg;
}
#<jmp> -> <id>
sub jmp
{
my $str = shift;
my $pos = pos $$str;
my $reg = id($str);
if (!defined $reg)
{
max($str, $pos);
return;
}
return $reg;
}
#<offset> -> ( <str> | <id> )? [ <id> ( [+-] <int> )? ]
sub offset
{
my $str = shift;
my $pos = pos $$str;
my $result = {};
my $block = str($str);
if (!defined $block)
{
$block = id($str);
}
$result->{block} = $block;
if ($$str !~ m/$som [[] /ixmsgc)
{
max($str, $pos);
return;
}
my $id = id($str);
if (!defined $id)
{
max($str, $pos);
return;
}
$result->{id} = $id;
if ($$str =~ m/$som ([+-]) /ixmsgc)
{
my $sign = $1;
my $int = &int($str);
if (!defined $int)
{
max($str, $pos);
return;
}
$result->{offset} = $sign.$int;
}
if ($$str !~ m/$som []] /ixmsgc)
{
max($str, $pos);
return;
}
return $result;
}
#<const> -> ( <num> | <int> | <str> )
sub const
{
my $str = shift;
my $pos = pos $$str;
my $result;
$result = num($str);
return (num => $result)
if defined $result;
$result = &int($str);
return ('int' => $result)
if defined $result;
$result = str($str);
return (str => $result)
if defined $result;
return;
}
#<str> ~> m/(?:') ([^']*(?:(?:\')[^']*)*) (?:')/xms
#<str> ~> m/(?:") ([^"]*(?:(?:\")[^"]*)*) (?:")/xms
sub str
{
my $str = shift;
my $pos = pos $$str;
my $result;
($result) = $$str =~ m/$som (?:') ([^']*(?:(?:\\')[^']*)*) (?:')/ixmsgc;
return $result
if defined $result;
($result) = $$str =~ m/$som (?:") ([^"]*(?:(?:\\")[^"]*)*) (?:")/ixmsgc;
return $result;
}
#<int> ~> m/(\d+)/xms
sub int
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som (\d+)/ixmsgc;
return $result;
}
# The num re is not exactly correct, since we also match ints, but this is
# easier to read and understand for the grammar
#<num> ~> m/( [+-]? \d+ (?: [.] \d+)? (?: [+-]? [e] \d+)? )/xms
sub num
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som (
[+-]? \d+
(?:
[.] \d+
|
[+-]? [e] \d+
|
[.] \d+ [+-]? [e] \d+
)
) /ixmsgc;
return $result;
}
#<id> ~> m/( [[:alpha:]] \w* )/xms
sub id
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som ( [[:alpha:]] \w* )/ixmsgc;
return $result;
}
#<reg> ~> m/[$] [I | N | S | P]? ([\d]+)/xms
sub reg
{
my $str = shift;
my $pos = pos $$str;
my ($result) = $$str =~ m/$som \$ [I N S P]? ([\d]+)/ixmsgc;
return $result;
}
# Given an op hash, turn it into binary
# const MUST be decided from imm|jmp|offset before calling this.
sub gen_op
{
my $stmt = shift;
# Compose the opcode
my $op = $ops{$stmt->{opcode}};
die "Could not load opcode: ".$stmt->{opcode}
unless defined $op;
return pack("CCCCI",
($op % (2**6-1)) | ( ($op_types{$stmt->{regtype} || "PMC"}) << 6 ),
($stmt->{dest} || 0)+0,
($stmt->{src1} || 0)+0,
($stmt->{src2} || 0)+0,
($stmt->{const} || 0)+0,
);
}
# Go!
my $file = do { local $/; <> };
# Parse the file
my $ast = goal(\$file);
if (!defined $ast)
{
warn "Could not parse lasm file\n";
my $to_max = substr($file, 0, $max);
my @lines = $to_max =~ m/(\n)/g;
$file =~ s/\s/ /xmsg;
warn "At line: ".scalar(@lines)."\n";
warn "Error near:\n\t".sprintf("%s[%s]%s\n", substr($file, $max-10, 10), substr($file, $max, 1), substr($file, $max+1, 10) );
exit;
}
use Data::Dumper;
#warn Dumper($ast);
# Generate the output
# Generate all the block labels
my %block;
my %block_cache;
foreach my $seg (@$ast)
{
if ($seg->{typed} eq "struct")
{
$block{$seg->{named}} = {};
my $current = $block{$seg->{named}};
my $curr_size = 0;
foreach my $const (@{$seg->{consts}})
{
if (defined $const->{label})
{
$current->{$const->{label}} = $curr_size;
}
$curr_size += $const->{size};
}
}
if ($seg->{typed} eq "data")
{
$block{$seg->{named}} = {};
my $current = $block{$seg->{named}};
my $curr_size = 0;
foreach my $const (@{$seg->{consts}})
{
if (defined $const->{label})
{
$current->{$const->{label}} = $curr_size;
}
$curr_size += $const->{size};
}
my $output = "";
$output .= pack("I", $seg_types{DATADEF});
$output .= pack("I", $seg->{flags} || 0);
$output .= pack("IZ*", length($seg->{named})+1, $seg->{named});
my $len = ceil(length($curr_size) / 8);
$output .= pack("I", $curr_size);
print $output;
}
if ($seg->{typed} eq "const")
{
$block{$seg->{named}} = {};
my $current = $block{$seg->{named}};
my $block_output = "";
foreach my $const (@{$seg->{consts}})
{
if (defined $const->{label})
{
$current->{$const->{label}} = length($block_output);
}
if ($const->{type} eq "str")
{
$block_output .= pack("U0Z*", $const->{const});
} elsif ($const->{type} eq "int") {
if ($const->{const} < 0)
{
$block_output .= pack("I", $const->{const});
} else {
$block_output .= pack("i", $const->{const});
}
} elsif ($const->{type} eq "num") {
$block_output .= pack("d", $const->{const});
}
}
if (length $block_output > 0)
{
my $output = "";
$output .= pack("I", $seg_types{CONST});
$output .= pack("I", $seg->{flags} || 0);
$output .= pack("IZ*", length($seg->{named})+1, $seg->{named});
my $len = ceil(length($block_output) / 8);
$output .= pack("I", $len);
$output .= $block_output;
$output .= pack("a".($len * 8 - length($block_output)), "");
print $output;
}
}
}
# Generate all the output for the segments
foreach my $seg (@$ast)
{
my $output = "";
if ($seg->{typed} eq "code")
{
$output .= pack("I", $seg_types{CODE});
$output .= pack("I", $seg->{flags} || 0);
$output .= pack("IZ*", length($seg->{named})+1, $seg->{named});
$output .= pack("I", scalar(@{$seg->{stmts}}));
my %labels;
# Find all the labels first
foreach my $i (0..scalar(@{$seg->{stmts}})-1)
{
my $label = $seg->{stmts}->[$i]->{label};
$labels{$label} = $i
if defined $label and $label ne "";
}
# Generate the code
foreach my $stmt (@{$seg->{stmts}})
{
# Decide const
# <imm> | <jmp> | <offset>
if (exists $stmt->{imm})
{
$stmt->{const} = $stmt->{imm}+0;
} elsif (exists $stmt->{jmp}) {
die "No such label: ". $stmt->{jmp}
unless defined $labels{$stmt->{jmp}};
$stmt->{const} = $labels{$stmt->{jmp}}+0;
} elsif (exists $stmt->{offset}) {
#die "offsets are awkward right now, sorry";
my $ref_block;
if (defined $stmt->{offset}->{block})
{
$ref_block = $block{$stmt->{offset}->{block}};
}
elsif (defined $block{$seg->{named}})
{
$ref_block = $block{$seg->{named}};
} else {
$ref_block = $block{''};
}
die "Could not find a usable block name"
if !defined $ref_block;
my $offset = $ref_block->{$stmt->{offset}->{id}};
die "Could not find a usable id in block: " . $stmt->{offset}->{id}
if !defined $offset;
$stmt->{const} = $offset + ($stmt->{offset}->{offset} || 0);
} else {
$stmt->{const} = 0;
}
$output .= gen_op($stmt);
}
}
elsif ($seg->{typed} eq "const")
{
}
elsif ($seg->{typed} eq "data")
{
#$output .= pack("I", 1);
#$output .= pack("IZ*", length($seg->{named})+1, $seg->{named});
# ...
} else {
die "Could create segment of type ".$seg->{typed};
}
print $output;
}
Jump to Line
Something went wrong with that request. Please try again.