On Thu, Sep 20, 2001 at 04:24:19PM -0400, Dan Sugalski wrote:
> At 01:08 PM 9/20/2001 -0700, Damien Neil wrote:
> >Another approach would be to include a means of defining information
> >that must be included by the file implementing the ops. For example:
>
> I like that approach. I'd say go for it--got time to put this in?
It's a fairly simple change...I'm attaching an updated version. This
requires that "#define PARROT_OP_IMPLEMENTATION" be added to
interpreter.c, before interp_guts.h is included.
- Damien
#!/usr/bin/perl -w
use strict;
use Parrot::Opcode;
use Getopt::Std;
use Symbol;
####################
# Arguments.
sub usage {
print STDERR "Usage: $0 -d <function | switch> [<file> ...]\n";
exit 1;
}
my %opts = (d => "function");
getopts("d:", \%opts) or usage;
if ($opts{d} ne "function" && $opts{d} ne "switch") {
print STDERR "Supported dispatch modes: function, switch.\n";
exit 1;
}
####################
# Opcodes.
my $opcode_fingerprint = Parrot::Opcode::fingerprint();
my %opcodes = Parrot::Opcode::read_ops();
my @opcodes;
for my $name (keys %opcodes) {
my $op = $opcodes{$name};
push @opcodes, $op;
$op->{NAME} = $name;
}
@opcodes = sort { $a->{CODE} <=> $b->{CODE} } @opcodes;
my %files;
for my $f (@ARGV) {
($files{$f}{header}, $files{$f}{ops}) = read_ops($f);
}
####################
# quoted() is used to simplify generation. The leading regex /\s*#/ is
# stripped from text, to allow here-docs to be set off from the surrounding
# Perl code. Lines beginning with /\s*\#\*/ are printed once for every
# opcode. Text surrounded in curly braces, like {THIS}, is replaced with
# the value of the appropriate field in the opcode definition.
sub quoted {
my $s = "";
for (split /\n/, $_[0]) {
if (s/^\s*\#\*//) {
for my $op (@opcodes) {
my $t = $_; $t =~ s/{(\w+)}/$op->{$1}/ge;
$s .= "$t\n";
}
}
elsif (s/^\s*\# ?//) {
$s .= "$_\n";
}
}
$s;
}
####################
# op.h
open OP_H, "> include/parrot/op.h"
or die "include/parrot/op.h: $!\n";
print OP_H quoted(<<END)
# /*
# * op.h
# * Opcode header.
# * This file is autogenerated by generate.pl -- DO NOT EDIT.
# */
#
# #if !defined(PARROT_OP_H_GUARD)
# #define PARROT_OP_H_GUARD
#
# typedef IV OP;
#
# #define DEFAULT_OPCODE_TABLE NULL
#
END
;
if ($opts{d} eq "function") {
print OP_H quoted(<<END)
#*#define {NAME} Parrot_op_{NAME}
#
#*opcode_t *{NAME}(opcode_t *, struct Parrot_Interp *);
END
;
}
print OP_H quoted(<<END)
#
# #endif
END
;
####################
# interp_guts.h
open INTERP, "> include/parrot/interp_guts.h"
or die "include/parrot/interp_guts.h: $!\n";
print INTERP quoted(<<END)
# /*
# * interp_guts.h
# *
# * This file is autogenerated by generate.pl -- DO NOT EDIT.
# */
#
# #define BUILD_TABLE(x) do { \\
END
;
for my $op (@opcodes) {
if ($opts{d} eq "function") {
print INTERP "\tx[$op->{CODE}] = (void*)$op->{NAME}; \\\n";
} else {
print INTERP "\tx[$op->{CODE}] = NULL; \\\n";
}
}
print INTERP quoted(<<END)
# } while (0);
#
# #define BUILD_NAME_TABLE(x) do { \\
#* x[{CODE}] = \"{NAME}\"; \\
# } while (0);
#
# #define BUILD_ARG_TABLE(x) do { \\
#* x[{CODE}] = {ARGS}; \\
# } while(0);
#
END
;
if ($opts{d} eq "function") {
print INTERP quoted(<<END)
# #define DO_OP(code, temp, func, interp) do { \\
# temp = (void *)interp->opcode_funcs; \\
# func = (opcode_t* (*)())temp[*code]; \\
# code = (func)(code, interp); \\
# } while(0);
END
;
} elsif ($opts{d} eq "switch") {
print INTERP "#define DO_OP(cur_opcode, temp, func, interp) do { \\\n";
print INTERP " switch (*cur_opcode) { \\\n";
for my $op (@opcodes) {
if (defined $op->{IMPL_BODY}) {
my $body = $op->{IMPL_BODY};
$body =~ s/RETVAL/return_offset/g;
$body =~ s/RETURN\(0\);/;/g;
$body =~ s/RETURN\((.*)\)/cur_opcode = cur_opcode + $1; break/g;
print INTERP " case $op->{CODE}: { \\\n";
for (split /\n/, $body) {
print INTERP "$_ \\\n";
}
print INTERP " cur_opcode += $op->{IMPL_RETURN_ADDR}; } \\\n";
print INTERP " break; \\\n";
}
}
print INTERP " default: \\\n";
print INTERP " exit(1); /* XXX: Better error trapping */ \\\n";
print INTERP " } } while(0)\n\n";
print INTERP "#ifdef PARROT_OP_IMPLEMENTATION\n";
for my $f (sort keys %files) {
print INTERP "\n/* $f */\n$files{$f}{header}";
}
print INTERP "\n#endif\n";
}
print INTERP quoted(<<END)
#
# #define OPCODE_FINGERPRINT "$opcode_fingerprint"
END
;
close INTERP;
####################
# Generate opcode files.
for my $f (@ARGV) {
my $output = $f;
$output =~ s/(\.ops)?$/.c/;
open OUTPUT, "> $output" or die "$output: $!\n";
print OUTPUT quoted(<<END)
# /*
# * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# * This file is automatically generated from $f.
# * Edit it instead.
# */
#
END
;
print OUTPUT $files{$f}{header};
if ($opts{d} ne "function") {
close OUTPUT;
next;
}
for my $name (@{$files{$f}{ops}}) {
my $op = $opcodes{$name};
my $body = $op->{IMPL_BODY};
$body =~ s/RETVAL/return_offset/g;
$body =~ s/RETURN\(0\);/return 0;/g;
$body =~ s/RETURN\((.*)\)/return cur_opcode + $1/g;
print OUTPUT "#line $op->{IMPL_LINE} \"$op->{IMPL_FILE}\"\n";
print OUTPUT ("opcode_t *$op->{FUNC}(".
"opcode_t cur_opcode[], ".
"struct Parrot_Interp *interpreter".
") {\n");
print OUTPUT $body;
print OUTPUT " return cur_opcode + $op->{IMPL_RETURN_ADDR};\n}\n\n";
}
close OUTPUT;
}
####################
# Read opcode function definitions.
#
# Opcode functions are in the format:
#
# AUTO_OP opname {
#
# ... body of function ...
#
# }
#
# Where the closing brace is on its own line. Alternately, for opcode
# functions that manage their own return values:
#
# MANUAL_OP opname {
#
# ... body of function ...
#
# RETVAL = x;
#
# }
#
# There may be more than one RETVAL
#
# The functions have the magic variables Pnnn for parameters 1 through
# X. (Parameter 0 is the opcode number) Types for each, and the size
# of the return offset, are taken from the opcode_table file
sub read_ops {
my($file) = @_;
open INPUT, $file or die "$file: $!\n";
my @ops;
my $file_header = "";
my($name, $body, $footer, $offset, @param_sub);
LINE:
while (<INPUT>) {
if (/^HEADER\s+{/) {
while (<INPUT>) {
next LINE if (/^}/);
$file_header .= $_;
}
}
if (/^AUTO_OP/) {
$body = "";
($name, $footer, $offset) = auto_code($_);
}
if (/^MANUAL_OP/) {
($name, $footer, $offset) = manual_code($_);
$body = " IV return_offset = $offset;\n";
}
if (/^(AUTO|MANUAL)_OP/) {
push @ops, $name;
if (defined $opcodes{$name}{IMPL_FILE}) {
print STDERR "Warning: $name implemented multiple times:\n";
print STDERR " $opcodes{$name}{IMPL_FILE}, ",
"line $opcodes{$name}{IMPL_LINE}\n";
print STDERR " $file, line $.\n";
}
$opcodes{$name}{IMPL_FILE} = $file;
$opcodes{$name}{IMPL_LINE} = $.;
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;
}
s/\bP(\d+)\b/$param_sub[$1]/g;
if (/^\}/) {
$opcodes{$name}{IMPL_BODY} = $body;
$opcodes{$name}{IMPL_RETURN_ADDR} = $footer;
$name = undef;
$body = undef;
$footer = undef;
@param_sub = ();
}
if (defined $body) {
$body .= $_;
}
}
close INPUT;
return($file_header, \@ops);
}
my %psize;
BEGIN {
%psize = (i => 1,
n => 2,
I => 1,
N => 1,
D => 1,
S => 1,
s => 1,
);
}
sub auto_code {
my($line) = @_;
my($name) = $line =~ /^AUTO_OP\s+(\w+)/;
die "$name: unknown opcode\n" unless $opcodes{$name};
my $psize = 0;
foreach (@{$opcodes{$name}{TYPES}}) {
$psize+=$psize{$_};
}
my $return_offset = $psize + 1;
return($name, $return_offset, $return_offset);
}
sub manual_code {
my($line) = @_;
my($name) = $line =~ /^MANUAL_OP\s+(\w+)/;
die "$name: unknown opcode\n" unless $opcodes{$name};
my $psize = 0;
foreach (@{$opcodes{$name}{TYPES}}) {
$psize+=$psize{$_};
}
my $return_offset = $psize + 1;
return($name, "return_offset", $return_offset);
}
