simon 01/09/12 02:54:47
Modified: . Makefile assemble.pl bytecode.c disassemble.pl
make_op_header.pl opcode_table process_opfunc.pl
Log:
Brian Wheeler's big patch:
* Changes the opcode_table file to provide additional information about
the operands. Case shouldn't be a problem since that data never becomes
a C symbol [this is pretty much as before]
* Padding errors solved: assemble.pl and bytecode.c were padding the
constants incorrectly. It should have been 4-(size % 4), not just (size
% 4). It is now fixed in both places.
* assembler has less special cases, and should be easier to hang error
checking on
* disassembler dumps constant table and the format is a bit prettier,
including register names, etc.
Revision Changes Path
1.8 +11 -3 parrot/Makefile
Index: Makefile
===================================================================
RCS file: /home/perlcvs/parrot/Makefile,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- Makefile 2001/09/11 09:44:00 1.7
+++ Makefile 2001/09/12 09:54:45 1.8
@@ -4,12 +4,12 @@
O_FILES = global_setup$(O) interpreter$(O) parrot$(O) register$(O)
basic_opcodes$(O) memory$(O) bytecode$(O) string$(O) strnative$(O)
-C_FLAGS = -Wall -o $@
+C_FLAGS = -Wall -g -o $@
CC = gcc $(C_FLAGS)
-all : $(O_FILES)
+all : $(O_FILES) test_prog
test_prog: test_main$(O) $(O_FILES)
gcc -o test_prog $(O_FILES) test_main$(O)
@@ -47,4 +47,12 @@
perl Configure.pl
clean:
- rm -f *$(O) *.s basic_opcodes.c interp_guts.h op.h test_prog
+ rm -f *$(O) *.s basic_opcodes.c interp_guts.h op.h test_prog config.h
+
+test:
+ perl assemble.pl t/test.pasm > t/test.pbc
+ ./test_prog t/test.pbc
+ perl assemble.pl t/test2.pasm > t/test2.pbc
+ ./test_prog t/test2.pbc
+ perl assemble.pl t/test3.pasm > t/test3.pbc
+ ./test_prog t/test3.pbc
1.8 +30 -19 parrot/assemble.pl
Index: assemble.pl
===================================================================
RCS file: /home/perlcvs/parrot/assemble.pl,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- assemble.pl 2001/09/11 08:38:04 1.7
+++ assemble.pl 2001/09/12 09:54:46 1.8
@@ -15,6 +15,15 @@
%pack_type = (i => 'l',
n => 'd',
);
+
+my %real_type=('i'=>'i',
+ 'n'=>'n',
+ 'N'=>'i',
+ 'I'=>'i',
+ 'S'=>'i',
+ 's'=>'i',
+ 'D'=>'i');
+
my $sizeof_packi = length(pack($pack_type{i},1024));
open GUTS, "interp_guts.h";
@@ -31,8 +40,11 @@
s/^\s+//;
next unless $_;
my ($name, $args, @types) = split /\s+/, $_;
+ my @rtypes=@types;
+ @types=map { $_ = $real_type{$_}} @types;
$opcodes{$name}{ARGS} = $args;
$opcodes{$name}{TYPES} = [@types];
+ $opcodes{$name}{RTYPES}=[@rtypes];
}
my $pc = 0;
@@ -71,24 +83,17 @@
if (@args != $opcodes{$opcode}{ARGS}) {
die "wrong arg count--got ". scalar @args. " needed " .
$opcodes{$opcode}{ARGS};
}
-
- $args[0] = fixup($args[0])
- if $opcode eq "branch_ic" and $args[0] =~ /[a-zA-Z]/;
-
-# if ($opcode eq "eq_i_ic" or $opcode eq "lt_i_ic") {
- if ($opcode =~ /^(eq|ne|lt|le|gt|ge)_i_ic$/) {
- $args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
- $args[3] = fixup($args[3]) if $args[3] =~ /[a-zA-Z]/;
- }
- if ($opcode eq "if_i_ic") {
- $args[1] = fixup($args[1]) if $args[1] =~ /[a-zA-Z]/;
- $args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
- }
-
$output .= pack "l", $opcodes{$opcode}{CODE};
foreach (0..$#args) {
- $args[$_] =~ s/^[INPS]?(\d+)$/$1/i;
- my $type = $pack_type{$opcodes{$opcode}{TYPES}[$_]};
+ my($rtype)=$opcodes{$opcode}{RTYPES}[$_];
+ my($type)=$opcodes{$opcode}{TYPES}[$_];
+ if($rtype eq "I" || $rtype eq "N" || $rtype eq "P" || $rtype eq "S") {
+ # its a register argument
+ $args[$_]=~s/^[INPS](\d+)$/$1/i;
+ } elsif($rtype eq "D") {
+ # a destination
+ $args[$_]=fixup($args[$_]);
+ }
$output .= pack $type, $args[$_];
}
$pc += 1+@args;
@@ -121,8 +126,11 @@
for (@constants) {
$size += 4*$sizeof_packi;
$size += length($_);
- $size += length($_) % $sizeof_packi; # Padding
+ my($pad)=length($_) % $sizeof_packi;
+ if($pad) {
+ $size+=$sizeof_packi-$pad;
}
+ }
$size += $sizeof_packi if @constants; # That's for the number of constants
$output .= pack($pack_type{i}, $size);
@@ -136,6 +144,9 @@
$output .= pack($pack_type{i},0) x 3; # Flags, encoding, type
$output .= pack($pack_type{i},length($_)); # Strlen followed by that many
bytes.
$output .= $_;
- $output .= "\0" x (length($_) % $sizeof_packi); # Padding;
+ my $pad=(length($_) % $sizeof_packi);
+ if($pad) {
+ $output .= "\0" x ($sizeof_packi-(length($_) % $sizeof_packi)); # Padding;
+ }
}
}
1.5 +7 -4 parrot/bytecode.c
Index: bytecode.c
===================================================================
RCS file: /home/perlcvs/parrot/bytecode.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- bytecode.c 2001/09/10 21:47:26 1.4
+++ bytecode.c 2001/09/12 09:54:46 1.5
@@ -79,6 +79,7 @@
IV encoding = GRAB_IV(program_code);
IV type = GRAB_IV(program_code);
IV buflen = GRAB_IV(program_code);
+ int pad;
len -= 4 * sizeof(IV);
@@ -87,9 +88,11 @@
len -= buflen;
/* Padding */
- if (buflen % sizeof(IV)) {
- len -= buflen % sizeof(IV);
- (char*)*program_code += buflen % sizeof(IV);
+ pad=buflen % sizeof(IV);
+ if(pad) {
+ pad=sizeof(IV)-pad;
+ len -= pad;
+ (char*)*program_code += pad;
}
num--;
if (len < 0 || (len > 0 && num == 0)) {
1.4 +55 -10 parrot/disassemble.pl
Index: disassemble.pl
===================================================================
RCS file: /home/perlcvs/parrot/disassemble.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- disassemble.pl 2001/09/10 21:45:33 1.3
+++ disassemble.pl 2001/09/12 09:54:46 1.4
@@ -8,12 +8,21 @@
my(%opcodes, @opcodes);
-my %unpack_type;
-%unpack_type = (i => 'l',
+my %unpack_type = (i => 'l',
+ I => 'l',
n => 'd',
+ N => 'l',
+ D => 'l',
+ S => 'l',
+ s => 'l',
);
my %unpack_size = (i => 4,
n => 8,
+ I => 4,
+ N => 4,
+ D => 4,
+ S => 4,
+ s => 4,
);
open GUTS, "interp_guts.h";
@@ -49,18 +58,54 @@
# No fixups yet
my $constants = unpack('l', <>);
-# Skip for now
-
+if($constants) {
+ my $count=unpack('l', <>);
+ print "# Constants: $count entries ($constants bytes)\n";
+ print "# ID Flags Encoding Type Size Data\n";
+ foreach (1..$count) {
+ my $flags=unpack('l',<>);
+ my $encoding=unpack('l',<>);
+ my $type=unpack('l',<>);
+ my $size=unpack('l',<>);
+ my $data="";
+ while(length($data) < $size) {
+ $data.=<>;
+ }
+ # strip off any padding nulls
+ $data=substr($data,0,$size);
+ printf("%04x: %08x %08x %08x %08x
%s\n",$_-1,$flags,$encoding,$type,$size,$data);
+ }
+}
+print "# Code Section\n";
+my $offset=0;
while (<>) {
my $code = unpack 'l', $_;
my $args = $opcodes[$code]{ARGS};
- print $opcodes[$code]{NAME};
+ my $op_offset=$offset;
+ print sprintf("%08x: ",$offset),$opcodes[$code]{NAME},"\t";
+ my @args=();
+ $offset+=4;
if ($args) {
foreach (1..$args) {
- local $/ = \$unpack_size{$opcodes[$code]{TYPES}[$_-1]};
+ my $type=$opcodes[$code]{TYPES}[$_-1];
+ local $/ = \$unpack_size{$type};
+ $offset+=$unpack_size{$type};
my $data = <> || die("EOF when expecting argument!\n");
- print " ", unpack $unpack_type{$opcodes[$code]{TYPES}[$_-1]}, $data;
+ if($type eq "I" || $type eq "N" || $type eq "P" || $type eq "S") {
+ # register
+ push(@args,$type.unpack($unpack_type{$type},$data));
+ } elsif($type eq "D") {
+ # destination address
+
push(@args,sprintf("%08x",$op_offset+unpack($unpack_type{$type},$data)*4));
+ } elsif($type eq "s") {
+ # string constant
+ push(@args,sprintf("[string %04x]",unpack($unpack_type{$type},$data)));
+
+ } else {
+ # constant
+ push(@args,unpack $unpack_type{$type}, $data);
+ }
}
}
- print "\n";
+ print join(", ",@args),"\n";
}
1.4 +1 -1 parrot/make_op_header.pl
Index: make_op_header.pl
===================================================================
RCS file: /home/perlcvs/parrot/make_op_header.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- make_op_header.pl 2001/09/10 21:26:09 1.3
+++ make_op_header.pl 2001/09/12 09:54:46 1.4
@@ -5,7 +5,7 @@
while (<>) {
next if /^\s*#/ or /^\s*$/;
chomp;
- ($name, undef) = split /\t/, $_;
+ ($name, undef) = split /\s+/, $_;
print "IV *$name(IV *, struct Perl_Interp *);\n";
}
1.8 +50 -40 parrot/opcode_table
Index: opcode_table
===================================================================
RCS file: /home/perlcvs/parrot/opcode_table,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- opcode_table 2001/09/11 08:26:18 1.7
+++ opcode_table 2001/09/12 09:54:46 1.8
@@ -10,72 +10,82 @@
# The arg_types are the types to be packed (integer, number, whatever)
# not the type of the register or anything. So N3 is still an i, since that
# 3 specifying the register should be packed as an integer.
+# Revised arg types:
+# i Integer constant
+# I Integer register
+# n Numeric constant
+# N Numeric register
+# s String constant?
+# S String register
+# D Destination
+
# This must be opcode zero
end 0
# Integer ops
-set_i_ic 2 i i
-set_i 2 i i
-add_i 3 i i i
-sub_i 3 i i i
-mul_i 3 i i i
-div_i 3 i i i
-inc_i 1 i
-inc_i_ic 2 i i
-dec_i 1 i
-dec_i_ic 2 i i
+set_i_ic 2 I i
+set_i 2 I I
+add_i 3 I I I
+sub_i 3 I I I
+mul_i 3 I I I
+div_i 3 I I I
+inc_i 1 I
+inc_i_ic 2 I i
+dec_i 1 I
+dec_i_ic 2 I i
# NUM ops
-set_n_nc 2 i n
-add_n 3 i i i
-sub_n 3 i i i
-mul_n 3 i i i
-div_n 3 i i i
-inc_n 1 i
-inc_n_nc 2 i n
-dec_n 1 i
-dec_n_nc 2 i n
+set_n_nc 2 N n
+add_n 3 N N N
+sub_n 3 N N N
+mul_n 3 N N N
+div_n 3 N N N
+inc_n 1 N
+inc_n_nc 2 N n
+dec_n 1 N
+dec_n_nc 2 N n
# String ops
-set_s_sc 2 i i
-print_s 1 i
-length_i_s 2 i i
-chopn_s_ic 2 i i
+set_s_sc 2 S s
+print_s 1 S
+length_i_s 2 I S
+chopn_s_ic 2 S i
# Comparators
-eq_i_ic 4 i i i i
-eq_n_ic 4 i i i i
-ne_i_ic 4 i i i i
-lt_i_ic 4 i i i i
-le_i_ic 4 i i i i
-gt_i_ic 4 i i i i
-ge_i_ic 4 i i i i
+eq_i_ic 4 I I D D
+eq_n_ic 4 N N D D
+ne_i_ic 4 I I D D
+lt_i_ic 4 I I D D
+le_i_ic 4 I I D D
+gt_i_ic 4 I I D D
+ge_i_ic 4 I I D D
# Flow control
-jump_i 1 i
-branch_ic 1 i
-if_i_ic 3 i i i
-if_n_ic 3 i i i
+jump_i 1 I
+branch_ic 1 D
+if_i_ic 3 I D D
+if_n_ic 3 N D D
# Convertors
-iton_n_i 2 i i
-ntoi_i_n 2 i i
+iton_n_i 2 N I
+ntoi_i_n 2 I N
# Miscellaneous and debugging ops
-time_i 1 i
-print_i 1 i
-time_n 1 i
-print_n 1 i
+time_i 1 I
+print_i 1 I
+time_n 1 N
+print_n 1 N
noop 0
+
# Register ops
push_i 0
1.4 +18 -3 parrot/process_opfunc.pl
Index: process_opfunc.pl
===================================================================
RCS file: /home/perlcvs/parrot/process_opfunc.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- process_opfunc.pl 2001/09/10 21:26:09 1.3
+++ process_opfunc.pl 2001/09/12 09:54:46 1.4
@@ -40,6 +40,17 @@
$opcode{$2}{OPNUM} = $1;
}
+
+my %psize = (i => 1,
+ n => 2,
+ I => 1,
+ N => 1,
+ D => 1,
+ S => 1,
+ s => 1,
+ );
+
+
open OPCODE, "opcode_table" or die "Can't open opcode_table, $!/$^E";
while (<OPCODE>) {
s/#.*//;
@@ -49,10 +60,14 @@
my ($name, $params, @params) = split /\s+/;
$opcode{$name}{PARAM_COUNT} = $params;
$opcode{$name}{PARAM_ARRAY} = \@params;
+
+ my $psize=0;
+ foreach (@params) {
+ $psize+=$psize{$_};
+ }
+
- my $num_i = () = grep {/i/} @params;
- my $num_n = () = grep {/n/} @params;
- $opcode{$name}{RETURN_OFFSET} = 1 + $num_i + $num_n * 2;
+ $opcode{$name}{RETURN_OFFSET} = 1 + $psize;
my $count = 1;
$opcode{$name}{PARAMETER_SUB} = ["",
map {if ($_ eq "n") {
