The following patch moves all parsing of opcode_table into a
Parrot::Opcode module. It also removes all parsing of interp_guts.h.
This patch incorporates my earlier patches to prefix all C opcode
functions with "Perl_op_".
As best I can tell, everything works the same with the patch as it
did before--the assembler and disassembler both generate identical
output, and test_prog runs as well as before. (Or better on FreeBSD,
where it stops core dumping. :>)
- Damien
diff -r --new-file -u parrot.orig/Parrot/Opcode.pm parrot/Parrot/Opcode.pm
--- parrot.orig/Parrot/Opcode.pm Wed Dec 31 16:00:00 1969
+++ parrot/Parrot/Opcode.pm Mon Sep 10 23:52:35 2001
@@ -0,0 +1,86 @@
+package Parrot::Opcode;
+
+use strict;
+use Symbol;
+
+sub read_ops {
+ my $file = @_ ? shift : "opcode_table";
+
+ my $fh = gensym;
+ open $fh, $file or die "$file: $!\n";
+
+ my %opcode;
+ my $count = 1;
+ while (<$fh>) {
+ s/#.*//;
+ s/^\s+//;
+ chomp;
+ next unless $_;
+
+ my($name, @params) = split /\s+/;
+ if (@params && $params[0] =~ /^\d+$/) {
+ my $count = shift @params;
+ die "$file, line $.: opcode $name parameters don't match count\n"
+ if ($count != @params);
+ }
+
+ warn "$file, line $.: opcode $name redefined\n" if $opcode{$name};
+
+ $opcode{$name}{ARGS} = @params;
+ $opcode{$name}{TYPES} = \@params;
+ $opcode{$name}{CODE} = ($name eq "end") ? 0 : $count++;
+ $opcode{$name}{FUNC} = "Parrot_op_$name";
+
+ my $num_i = () = grep {/i/} @params;
+ my $num_n = () = grep {/n/} @params;
+ $opcode{$name}{RETURN_OFFSET} = 1 + $num_i + $num_n * 2;
+ }
+
+ return %opcode;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Parrot::Opcode - Read opcode definitions
+
+=head1 SYNOPSIS
+
+ use Parrot::Opcode;
+
+ %opcodes = Parrot::Opcode::read_ops();
+
+=head1 DESCRIPTION
+
+The read_ops() function parses the Parrot opcode_table file, and
+returns the contents as a hash. The hash key is the opcode name;
+values are hashrefs containing the following fields:
+
+=over
+
+=item CODE
+
+The opcode number.
+
+=item ARGS
+
+The opcode argument count.
+
+=item TYPES
+
+The opcode argument types, as an arrayref.
+
+=item FUNC
+
+The name of the C function implementing this op.
+
+=back
+
+read_ops() takes an optional argument: the file to read the opcode table
+from.
+
+=cut
diff -r --new-file -u parrot.orig/assemble.pl parrot/assemble.pl
--- parrot.orig/assemble.pl Mon Sep 10 14:26:08 2001
+++ parrot/assemble.pl Mon Sep 10 23:51:34 2001
@@ -3,6 +3,7 @@
# assemble.pl - take a parrot assembly file and spit out a bytecode file
use strict;
+use Parrot::Opcode;
my(%opcodes, %labels);
@@ -12,23 +13,7 @@
);
my $sizeof_packi = length(pack($pack_type{i},1024));
-open GUTS, "interp_guts.h";
-my $opcode;
-while (<GUTS>) {
- next unless /\tx\[(\d+)\] = ([a-z_]+);/;
- $opcodes{$2}{CODE} = $1;
-}
-
-open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
-while (<OPCODES>) {
- next if /^\s*#/;
- chomp;
- s/^\s+//;
- next unless $_;
- my ($name, $args, @types) = split /\s+/, $_;
- $opcodes{$name}{ARGS} = $args;
- $opcodes{$name}{TYPES} = [@types];
-}
+%opcodes = Parrot::Opcode::read_ops();
my $pc = 0;
my @code;
diff -r --new-file -u parrot.orig/build_interp_starter.pl
parrot/build_interp_starter.pl
--- parrot.orig/build_interp_starter.pl Mon Sep 10 14:26:09 2001
+++ parrot/build_interp_starter.pl Mon Sep 10 23:53:26 2001
@@ -1,10 +1,9 @@
# !/usr/bin/perl -w
use strict;
+use Parrot::Opcode;
open INTERP, "> interp_guts.h" or die "Can't open interp_guts.h, $!/$^E";
-open OPCODES, "opcode_table" or die "Can't open opcode_table, $!/$^E";
-
print INTERP <<CONST;
/*
*
@@ -18,16 +17,8 @@
#define BUILD_TABLE(x) do { \\
CONST
-my $count = 1;
-while (<OPCODES>) {
- chomp;
- s/#.*$//;
- s/^\s+//;
- next unless $_;
- my($name) = split /\s+/;
- my $num = $count;
- $num = 0 if $name eq 'end';
- print INTERP "\tx[$num] = $name; \\\n";
- $count++ unless $name eq 'end';
+my %opcodes = Parrot::Opcode::read_ops();
+for my $name (sort {$opcodes{$a}{CODE} <=> $opcodes{$b}{CODE}} keys %opcodes) {
+ print INTERP "\tx[$opcodes{$name}{CODE}] = $opcodes{$name}{FUNC}; \\\n";
}
print INTERP "} while (0);\n";
diff -r --new-file -u parrot.orig/disassemble.pl parrot/disassemble.pl
--- parrot.orig/disassemble.pl Mon Sep 10 14:45:33 2001
+++ parrot/disassemble.pl Mon Sep 10 23:57:36 2001
@@ -7,6 +7,7 @@
use strict;
my(%opcodes, @opcodes);
+use Parrot::Opcode;
my %unpack_type;
%unpack_type = (i => 'l',
@@ -16,28 +17,10 @@
n => 8,
);
-open GUTS, "interp_guts.h";
-my $opcode;
-while (<GUTS>) {
- next unless /\tx\[(\d+)\] = ([a-z_]+);/;
- $opcodes{$2}{CODE} = $1;
-}
-
-open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
-while (<OPCODES>) {
- next if /^\s*#/;
- s/^\s+//;
- chomp;
- next unless $_;
- my ($name, $args, @types) = split /\s+/, $_;
- next unless defined $name;
- $opcodes{$name}{ARGS} = $args;
- $opcodes{$name}{TYPES} = [@types];
- my $code = $opcodes{$name}{CODE};
- $opcodes[$code] = {NAME => $name,
- ARGS => $args,
- TYPES => [@types]
- }
+%opcodes = Parrot::Opcode::read_ops();
+for my $name (keys %opcodes) {
+ $opcodes[$opcodes{$name}{CODE}] = { NAME => $name,
+ %{$opcodes{$name}} };
}
$/ = \4;
diff -r --new-file -u parrot.orig/make_op_header.pl parrot/make_op_header.pl
--- parrot.orig/make_op_header.pl Mon Sep 10 14:26:09 2001
+++ parrot/make_op_header.pl Mon Sep 10 23:53:09 2001
@@ -2,11 +2,13 @@
#
# rip through opcode_table and spit out a chunk of C header for the
# functions in it
-while (<>) {
- next if /^\s*#/ or /^\s*$/;
- chomp;
- ($name, undef) = split /\t/, $_;
- print "IV *$name(IV *, struct Perl_Interp *);\n";
+
+use strict;
+use Parrot::Opcode;
+
+my %opcodes = Parrot::Opcode::read_ops();
+for my $name (sort {$opcodes{$a}{CODE}<=>$opcodes{$b}{CODE}} keys %opcodes) {
+ print "IV *$opcodes{$name}{FUNC}(IV *, struct Perl_Interp *);\n";
}
BEGIN {
diff -r --new-file -u parrot.orig/process_opfunc.pl parrot/process_opfunc.pl
--- parrot.orig/process_opfunc.pl Mon Sep 10 14:26:09 2001
+++ parrot/process_opfunc.pl Mon Sep 10 23:52:57 2001
@@ -30,40 +30,9 @@
# of the return offset, are taken from the opcode_table file
use strict;
+use Parrot::Opcode;
-my %opcode;
-
-open GUTS, "interp_guts.h";
-my $opcode;
-while (<GUTS>) {
- next unless /\tx\[(\d+)\] = ([a-z_]+);/;
- $opcode{$2}{OPNUM} = $1;
-}
-
-open OPCODE, "opcode_table" or die "Can't open opcode_table, $!/$^E";
-while (<OPCODE>) {
- s/#.*//;
- s/^\s+//;
- chomp;
- next unless $_;
- my ($name, $params, @params) = split /\s+/;
- $opcode{$name}{PARAM_COUNT} = $params;
- $opcode{$name}{PARAM_ARRAY} = \@params;
-
- my $num_i = () = grep {/i/} @params;
- my $num_n = () = grep {/n/} @params;
- $opcode{$name}{RETURN_OFFSET} = 1 + $num_i + $num_n * 2;
- my $count = 1;
- $opcode{$name}{PARAMETER_SUB} = ["",
- map {if ($_ eq "n") {
- my $temp = '*(NV *)&cur_opcode[' . $count .
']';
- $count += 2;
- $temp;
- } else {
- "cur_opcode[" . $count++ . "]"
- }
- } @params];
-}
+my %opcodes = Parrot::Opcode::read_ops();
my $file = $ARGV[0];
open INPUT, $file or die "Can't open $file, $!/$^E";
@@ -72,16 +41,29 @@
}
open OUTPUT, ">$file" or die "Can't open $file, $!/$^E";
-my($name, $footer);
+my($name, $footer, @param_sub);
while (<INPUT>) {
if (/^AUTO_OP/) {
($name, $footer) = emit_auto_header($_);
- next;
}
if (/^MANUAL_OP/) {
($name, $footer) = emit_manual_header($_);
+ }
+
+ if (/^(AUTO|MANUAL)_OP/) {
+ my $count = 1;
+ @param_sub = ("",
+ map {if ($_ eq "n") {
+ my $temp = '*(NV *)&cur_opcode[' . $count . ']';
+ $count += 2;
+ $temp;
+ } else {
+ "cur_opcode[" . $count++ . "]"
+ }
+ } @{$opcodes{$name}{TYPES}});
+
next;
}
@@ -91,7 +73,7 @@
s/RETURN\((.*)\)/return cur_opcode + $1/;
- s/\bP(\d+)\b/$opcode{$name}{PARAMETER_SUB}[$1]/g;
+ s/\bP(\d+)\b/$param_sub[$1]/g;
if (/^}/) {
print OUTPUT $footer, "\n";
@@ -104,17 +86,20 @@
sub emit_auto_header {
my $line = shift;
my ($name) = $line =~ /AUTO_OP\s+(\w+)/;
-
- print OUTPUT "IV *$name(IV cur_opcode[], struct Perl_Interp *interpreter) {\n";
- return($name, " return cur_opcode + "
- . $opcode{$name}{RETURN_OFFSET}. ";\n}\n");
+
+ my $num_i = () = grep {/i/} @{$opcodes{$name}{TYPES}};
+ my $num_n = () = grep {/n/} @{$opcodes{$name}{TYPES}};
+ my $return_offset = 1 + $num_i + $num_n * 2;
+
+ print OUTPUT "IV *$opcodes{$name}{FUNC}(IV cur_opcode[], struct Perl_Interp
+*interpreter) {\n";
+ return($name, " return cur_opcode + " . $return_offset . ";\n}\n");
}
sub emit_manual_header {
my $line = shift;
my ($name) = $line =~ /MANUAL_OP\s+(\w+)/;
- print OUTPUT "IV *$name(IV cur_opcode[], struct Perl_Interp *interpreter) {\n";
+ print OUTPUT "IV *$opcodes{$name}{FUNC}(IV cur_opcode[], struct Perl_Interp
+*interpreter) {\n";
print OUTPUT " IV return_offset = 1;\n";
return($name, " return cur_opcode + return_offset;\n}\n");
}
