On Fri, Sep 14, 2001 at 10:20:00AM +0100, Simon Cozens wrote:
> On Thu, Sep 13, 2001 at 08:54:40PM -0700, Damien Neil wrote:
> > Here's an updated version of my original patch, to account for recent
> > changes in CVS. As before, this includes opcode-munging to let Parrot
> > run on FreeBSD.
...
> These three patches didn't apply and I really want them. Hence, I'm
> taking no more patches to:
Third time's the charm, maybe? The following patch applies cleanly
against CVS.
I changed the opcode munging to match what exists in CVS--
"#define end Parrot_op_end" in the header, rather than simply renaming
all uses of the function.
I've also added a Parrot::Opcode::fingerprint() function to get the
opcode table fingerprint.
- Damien
diff --new-file -r -u old/parrot/Parrot/Opcode.pm parrot/Parrot/Opcode.pm
--- old/parrot/Parrot/Opcode.pm Wed Dec 31 16:00:00 1969
+++ parrot/Parrot/Opcode.pm Fri Sep 14 10:29:59 2001
@@ -0,0 +1,192 @@
+package Parrot::Opcode;
+
+use strict;
+use Symbol;
+use Digest::MD5 qw(&md5_hex);
+
+our %opcode;
+our $fingerprint;
+
+sub _load {
+ my $file = @_ ? shift : "opcode_table";
+
+ my $fh = gensym;
+ open $fh, $file or die "$file: $!\n";
+
+ my $md5 = Digest::MD5->new;
+ my $count = 1;
+ while (<$fh>) {
+ $md5->add($_);
+
+ 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} = $name;
+
+ my $num_i = () = grep {/i/} @params;
+ my $num_n = () = grep {/n/} @params;
+ $opcode{$name}{RETURN_OFFSET} = 1 + $num_i + $num_n * 2;
+ }
+
+ $fingerprint = $md5->hexdigest;
+}
+
+sub read_ops {
+ _load(@_) unless defined $fingerprint;
+ return %opcode;
+}
+
+
+sub fingerprint {
+ _load(@_) unless defined $fingerprint;
+ return $fingerprint;
+}
+
+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.
+
+The fingerprint() function returns the MD5 signature (in hex) of the
+opcode table.
+
+=cut
+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 --new-file -r -u old/parrot/assemble.pl parrot/assemble.pl
--- old/parrot/assemble.pl Fri Sep 14 10:27:48 2001
+++ parrot/assemble.pl Fri Sep 14 10:27:33 2001
@@ -7,6 +7,7 @@
use strict;
use Digest::MD5 qw(&md5_hex);
use Getopt::Long;
+use Parrot::Opcode;
my %options;
GetOptions(\%options,('checksyntax',
@@ -56,40 +57,12 @@
foreach (keys(%real_type)) {
$sizeof{$_}=length(pack($pack_type{$real_type{$_}},0));
}
-
-# get opcodes from guts.
-open(GUTS, "<interp_guts.h") or
- open(GUTS, "<../interp_guts.h") or
- die "Can't get opcodes from guts, $!/$^E";
-my %opcodes;
-while (<GUTS>) {
- next unless /\tx\[(\d+)\] = ([a-z0-9_]+);/;
- $opcodes{$2}{CODE} = $1;
-}
-close GUTS;
-# get opcodes and their arg lists
-open(OPCODES, "<opcode_table") or
- open(OPCODES, "<../opcode_table") or
- die "Can't get opcode table, $!/$^E";
-my $opcode_table;
-while (<OPCODES>) {
- $opcode_table .= $_;
- next if /^\s*#/;
- chomp;
- 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];
-}
-close OPCODES;
-my $opcode_fingerprint = md5_hex($opcode_table);
-constantize($opcode_fingerprint); # Make it constant zero.
+# get opcodes
+my %opcodes = Parrot::Opcode::read_ops();
+
+constantize(Parrot::Opcode::fingerprint()); # Make it constant zero.
my $listing="PARROT ASSEMBLY LISTING - ".scalar(localtime)."\n\n";
@@ -183,8 +156,8 @@
$pc+=4;
foreach (0..$#args) {
- my($rtype)=$opcodes{$opcode}{RTYPES}[$_];
- my($type)=$opcodes{$opcode}{TYPES}[$_];
+ my($rtype)=$opcodes{$opcode}{TYPES}[$_];
+ my($type)=$real_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;
diff --new-file -r -u old/parrot/build_interp_starter.pl parrot/build_interp_starter.pl
--- old/parrot/build_interp_starter.pl Fri Sep 14 10:27:48 2001
+++ parrot/build_interp_starter.pl Fri Sep 14 10:31:26 2001
@@ -1,11 +1,10 @@
# !/usr/bin/perl -w
use strict;
use Digest::MD5 qw(&md5_hex);
+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;
/*
*
@@ -19,24 +18,13 @@
#define BUILD_TABLE(x) do { \\
CONST
-my $opcode_table;
-my $count = 1;
-while (<OPCODES>) {
- $opcode_table .= $_;
- 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();
+my $opcode_fingerprint = Parrot::Opcode::fingerprint();
+
+for my $name (sort {$opcodes{$a}{CODE} <=> $opcodes{$b}{CODE}} keys %opcodes) {
+ print INTERP "\tx[$opcodes{$name}{CODE}] = $name; \\\n";
}
-close OPCODES;
-my $opcode_fingerprint = md5_hex($opcode_table);
print INTERP "} while (0);\n";
-
# Spit out the DO_OP function
print INTERP <<EOI;
diff --new-file -r -u old/parrot/disassemble.pl parrot/disassemble.pl
--- old/parrot/disassemble.pl Fri Sep 14 10:27:48 2001
+++ parrot/disassemble.pl Fri Sep 14 10:34:19 2001
@@ -6,8 +6,7 @@
use strict;
use Digest::MD5 qw(&md5_hex);
-
-my(%opcodes, @opcodes);
+use Parrot::Opcode;
my %unpack_type = (i => 'l',
I => 'l',
@@ -26,32 +25,13 @@
s => 4,
);
-open GUTS, "interp_guts.h";
-my $opcode;
-while (<GUTS>) {
- next unless /\tx\[(\d+)\] = ([a-z0-9_]+);/;
- $opcodes{$2}{CODE} = $1;
-}
-
-my $opcode_table;
-open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
-while (<OPCODES>) {
- $opcode_table .= $_;
- 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]
- }
+my %opcodes = Parrot::Opcode::read_ops();
+my $opcode_fingerprint = Parrot::Opcode::fingerprint();
+my @opcodes;
+for my $name (keys %opcodes) {
+ $opcodes[$opcodes{$name}{CODE}] = { NAME => $name,
+ %{$opcodes{$name}} };
}
-my $opcode_fingerprint = md5_hex($opcode_table);
$/ = \4;
diff --new-file -r -u old/parrot/make_op_header.pl parrot/make_op_header.pl
--- old/parrot/make_op_header.pl Fri Sep 14 10:27:48 2001
+++ parrot/make_op_header.pl Fri Sep 14 10:35:47 2001
@@ -2,10 +2,10 @@
#
# 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 /\s+/, $_;
+use strict;
+use Parrot::Opcode;
+my %opcodes = Parrot::Opcode::read_ops();
+for my $name (sort {$opcodes{$a}{CODE} <=> $opcodes{$b}{CODE}} keys %opcodes) {
print "#define $name Parrot_op_$name\n";
print "IV *$name(IV *, struct Perl_Interp *);\n";
}
diff --new-file -r -u old/parrot/process_opfunc.pl parrot/process_opfunc.pl
--- old/parrot/process_opfunc.pl Wed Sep 12 16:12:00 2001
+++ parrot/process_opfunc.pl Fri Sep 14 10:12:18 2001
@@ -30,6 +30,9 @@
# of the return offset, are taken from the opcode_table file
use strict;
+use Parrot::Opcode;
+
+my %opcodes = Parrot::Opcode::read_ops();
my %opcode;
@@ -87,16 +90,28 @@
}
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;
}
@@ -106,7 +121,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";
@@ -119,17 +134,26 @@
sub emit_auto_header {
my $line = shift;
my ($name) = $line =~ /AUTO_OP\s+(\w+)/;
+
+ my $psize=0;
+ foreach (@{$opcodes{$name}{TYPES}}) {
+ $psize+=$psize{$_};
+ }
+ my $return_offset = $psize + 1;
+
+ $opcode{$name}{RETURN_OFFSET} = 1 + $psize;
- print OUTPUT "IV *$name(IV cur_opcode[], struct Perl_Interp *interpreter) {\n";
- return($name, " return cur_opcode + "
- . $opcode{$name}{RETURN_OFFSET}. ";\n}\n");
+ 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");
}
