----- Message Text -----
All.-
Now I'm sending:
* A modification to Configure.pl and Makefile.in to detect if the compiler
accepts computed gotos, also added testcomputedgoto_c.in.
* A modification to runcore_ops.c and interpreter.c adding an ifdef.
* The same ops2cgc.pl and the same modification to pbc2c.pl, but with this
one I will deal tomorrow (I have to go now), it's still throwing computed
goto C, we'll have to decide how to handle jump and ret when we don't have
computed goto without big speed consecuencies.
Hope someone find these usefull.
Daniel Grunblatt.
/*
* testcomputedgoto.c - figure out if we can use computed goto
*
* This file is automatically generated by Configure
* from testcomputedgoto_c.in.
*/
int main(int argc, char **argv) {
static void *ptr = &&LABEL;
int a;
goto *ptr;
LABEL: {
a = 1;
}
return 0;
}
#! /usr/bin/perl -w
#
# ops2cgc.pl
#
# Generate a C header and source file from the operation definitions in
# an .ops file.
#
use strict;
use Parrot::OpsFile;
#
# Process command-line argument:
#
if (@ARGV != 1) {
die "ops2cgc.pl: usage: perl ops2cgc.pl input.ops\n";
}
my $file = $ARGV[0];
my $base = $file;
$base =~ s/\.ops$//;
my $incdir = "include/parrot/oplib";
my $include = "parrot/oplib/${base}_cg_ops.h";
my $header = "include/$include";
my $source = "${base}_cg_ops.c";
#
# Read the input file:
#
my $ops = new Parrot::OpsFile $file;
die "ops2cgc.pl: Could not read ops file '$file'!\n" unless $ops;
my $num_ops = scalar $ops->ops;
my $num_entries = $num_ops + 1; # For trailing NULL
#
# Open the output files:
#
if (! -d $incdir) {
mkdir($incdir, 0755) or die "ops2cgc.pl: Could not mkdir $incdir $!!\n";
}
open HEADER, ">$header"
or die "ops2cgc.pl: Could not open header file '$header' for writing: $!!\n";
open SOURCE, ">$source"
or die "ops2cgc.pl: Could not open source file '$source' for writing: $!!\n";
#
# Print the preamble for the HEADER and SOURCE files:
#
my $preamble = <<END_C;
/*
** !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
**
** This file is generated automatically from '$file'.
** Any changes made here will be lost!
*/
END_C
print HEADER $preamble;
print HEADER <<END_C;
#include "parrot/parrot.h"
opcode_t *cg_core(opcode_t *, struct Parrot_Interp *);
END_C
print SOURCE $preamble;
print SOURCE <<END_C;
#include "$include"
opcode_t *
cg_core(opcode_t *cur_opcode, struct Parrot_Interp *interpreter)
{
static void *ops_addr[] = {
END_C
#
# Iterate over the ops, appending SOURCE fragments:
#
my @op_source;
my $index = 0;
foreach my $op ($ops->ops) {
my $definition = "PC_$index:";
my $source = $op->source(\&map_cg_abs, \&map_cg_rel, \&map_arg, \&map_res_abs,
\&map_res_rel);
print SOURCE " &&PC_" . $index++ . ",\n";
push @op_source, "$definition /* " . $op->func_name . " */\n{\n$source}\n\n";
}
#
# Finish the array and stat the execution:
#
print SOURCE <<END_C;
NULL
};
goto *ops_addr[*cur_opcode];
END_C
#
# Dump the source:
#
print SOURCE @op_source;
print SOURCE <<END_C;
};
END_C
#
# map_cg_abs()
#
sub map_cg_abs
{
my ($addr) = @_;
if ($addr eq '0') {
return "return (0);"
} else {
return "goto *ops_addr[*(cur_opcode = $addr)]";
}
}
#
# map_cg_rel()
#
sub map_cg_rel
{
my ($offset) = @_;
return "goto *ops_addr[*(cur_opcode += $offset)]";
}
#
# map_arg()
#
sub map_arg
{
my ($type, $num) = @_;
my %arg_maps = (
'op' => "cur_opcode[%ld]",
'i' => "interpreter->int_reg->registers[cur_opcode[%ld]]",
'n' => "interpreter->num_reg->registers[cur_opcode[%ld]]",
'p' => "interpreter->pmc_reg->registers[cur_opcode[%ld]]",
's' => "interpreter->string_reg->registers[cur_opcode[%ld]]",
'ic' => "cur_opcode[%ld]",
'nc' => "interpreter->code->const_table->constants[cur_opcode[%ld]]->number",
'pc' => "%ld /* ERROR: Don't know how to handle PMC constants yet! */",
'sc' => "interpreter->code->const_table->constants[cur_opcode[%ld]]->string",
);
die "Unrecognized type '$type' for num '$num'" unless exists $arg_maps{$type};
return sprintf($arg_maps{$type}, $num);
}
#
# map_res_rel()
#
sub map_res_rel
{
my ($offset) = @_;
return "interpreter->resume_addr = cur_opcode + $offset";
}
#
# map_res_abs()
#
sub map_res_abs
{
my ($addr) = @_;
return "interpreter->resume_addr = $addr";
}
Index: Configure.pl
===================================================================
RCS file: /home/perlcvs/parrot/Configure.pl,v
retrieving revision 1.31
diff -u -r1.31 Configure.pl
--- Configure.pl 2001/11/02 12:11:15 1.31
+++ Configure.pl 2001/11/05 00:28:50
@@ -95,6 +95,14 @@
platform => 'linux',
cp => 'cp',
slash => '/',
+ cg_h => '$(INC)/oplib/core_cg_ops.h',
+ cg_c => 'core_cg_ops$(O): $(H_FILES) core_ops.c
+
+core_cg_ops.c $(INC)/oplib/core_cg_ops.h: core.ops ops2cgc.pl
+ $(PERL) ops2cgc.pl core.ops',
+ cg_o => 'core_cg_ops$(O)',
+ cg_r => '$(RM_F) $(INC)/oplib/core_cg_ops.h core_cg_ops.c',
+ cg_flag => '-DHAVE_COMPUTED_GOTO',
);
#copy the things from --define foo=bar
@@ -224,6 +232,33 @@
# rewrite the config file with the updated info
buildfile("config_h", "include/parrot");
+
+
+# and now test if we can use computed goto
+print <<"END";
+
+Still everything ok, let's check if we can use computed goto,
+don't worry if you see some errors, it will be all right,
+This could take a bit...
+END
+
+{
+ buildfile("testcomputedgoto_c");
+ my $test = system("$c{cc} $c{ccflags} -o testcomputedgoto$c{exe}
+testcomputedgoto.c");
+
+ if ($test != 0) {
+ $c{"cg_h"}='';
+ $c{"cg_c"}='';
+ $c{"cg_o"}='';
+ $c{"cg_r"}='';
+ $c{"cg_flag"}='';
+ }
+
+ unlink('testcomputedgoto.c', "testcomputedgoto$c{exe}",
+"testcomputedgoto$c{o}");
+}
+
+# rewrite the Makefile with the updated info
+buildfile("Makefile");
print <<"END";
Index: Makefile.in
===================================================================
RCS file: /home/perlcvs/parrot/Makefile.in,v
retrieving revision 1.43
diff -u -r1.43 Makefile.in
--- Makefile.in 2001/11/02 12:11:15 1.43
+++ Makefile.in 2001/11/05 00:28:50
@@ -8,19 +8,19 @@
$(INC)/memory.h $(INC)/parrot.h $(INC)/stacks.h $(INC)/packfile.h \
$(INC)/global_setup.h $(INC)/vtable.h $(INC)/oplib/core_ops.h \
$(INC)/runops_cores.h $(INC)/trace.h $(INC)/oplib/vtable_ops.h \
-$(INC)/pmc.h $(INC)/resources.h $(INC)/platform.h
+$(INC)/pmc.h $(INC)/resources.h $(INC)/platform.h ${cg_h}
O_FILES = global_setup$(O) interpreter$(O) parrot$(O) register$(O) \
core_ops$(O) memory$(O) packfile$(O) stacks$(O) string$(O) encoding$(O) \
chartype$(O) runops_cores$(O) trace$(O) vtable_ops$(O) classes/intclass$(O) \
encodings/singlebyte$(O) encodings/utf8$(O) encodings/utf16$(O) \
encodings/utf32$(O) chartypes/unicode$(O) chartypes/usascii$(O) resources$(O) \
-platform$(O)
+platform$(O) ${cg_o}
#DO NOT ADD C COMPILER FLAGS HERE
#Add them in Configure.pl--look for the
#comment 'ADD C COMPILER FLAGS HERE'
-CFLAGS = ${ccflags} ${cc_debug}
+CFLAGS = ${ccflags} ${cc_debug} ${cg_flag}
C_LIBS = ${libs}
@@ -101,6 +101,8 @@
stacks$(O): $(H_FILES)
+${cg_c}
+
core_ops$(O): $(H_FILES) core_ops.c
core_ops.c $(INC)/oplib/core_ops.h: core.ops ops2c.pl
@@ -132,6 +134,7 @@
clean:
$(RM_F) *$(O) *.s core_ops.c $(TEST_PROG) $(PDISASM) $(PDUMP)
$(RM_F) $(INC)/vtable.h
+ ${cg_r}
$(RM_F) $(INC)/oplib/core_ops.h
$(RM_F) $(INC)/oplib/vtable_ops.h vtable_ops.c vtable.ops
$(RM_F) $(TEST_PROG) $(PDISASM) $(PDUMP)
Index: interpreter.c
===================================================================
RCS file: /home/perlcvs/parrot/interpreter.c,v
retrieving revision 1.33
diff -u -r1.33 interpreter.c
--- interpreter.c 2001/10/26 18:58:02 1.33
+++ interpreter.c 2001/11/05 00:28:53
@@ -13,6 +13,9 @@
#include "parrot/parrot.h"
#include "parrot/interp_guts.h"
#include "parrot/oplib/core_ops.h"
+#ifdef HAVE_COMPUTED_GOTO
+#include "parrot/oplib/core_cg_ops.h"
+#endif
#include "parrot/runops_cores.h"
Index: pbc2c.pl
===================================================================
RCS file: /home/perlcvs/parrot/pbc2c.pl,v
retrieving revision 1.3
diff -u -r1.3 pbc2c.pl
--- pbc2c.pl 2001/10/24 13:03:42 1.3
+++ pbc2c.pl 2001/11/05 00:28:55
@@ -65,9 +65,11 @@
# compile_byte_code()
#
-my $pc;
+my $pc = 1;
+my $op;
my $new_pc = 1;
my @args = ();
+my @pcs = ();
sub compile_byte_code {
my ($pf) = @_;
@@ -85,11 +87,59 @@
int
main(int argc, char **argv) {
- int i;
+ int cur_opcode;
struct Parrot_Interp * interpreter;
struct PackFile_Constant * c;
struct PackFile * pf;
+END_C
+ my $cursor = 0;
+ my $length = length($pf->byte_code);
+
+ my $offset=0;
+
+ my $op_code;
+ my @addr;
+ my @source;
+
+ while ($offset + sizeof('op') <= $length) {
+ foreach ($pc..$new_pc-2) {
+ push @addr, " NULL,\n";
+ }
+ $pc = $new_pc;
+ push @addr, " &&PC_$pc,\n";
+ $op_code = unpack "x$offset l", $pf->byte_code;
+ $op = $ops->op($op_code);
+ $offset += sizeof('op');
+ $new_pc = $pc + $op->size;
+
+ @args = ();
+ foreach (1 .. scalar($op->arg_types) - 1) {
+ die "$0: Premature end of bytecode in argument.\n"
+ if ($offset + sizeof('op')) > $length;
+ my $arg = unpack "x$offset l", $pf->byte_code;
+ $offset += sizeof('op');
+ push @args, $arg;
+ }
+
+ my $source = $op->source(\&map_ret_abs, \&map_ret_rel, \&map_arg,
+\&map_res_abs, \&map_res_rel);
+ if ($source =~ m/cur_opcode/) {
+ $source =~ s/cur_opcode \+ (\d+)/(opcode_t *)(cur_opcode + $1)/g;
+ $source = "cur_opcode = " . $pc . ";\n" . $source;
+ }
+ push @source, sprintf("PC_%d: /* %s */\n{\n%s}\n\n", $pc, $op->full_name,
+$source);
+ }
+
+ print <<END_C;
+ static void *pc_l[] = {
+ &&PC_0,
+END_C
+
+ print @addr;
+ print <<END_C;
+ NULL
+ };
+
init_world();
interpreter = make_interpreter();
@@ -98,7 +148,6 @@
interpreter->code = pf;
END_C
-
for(my $i = 0; $i < $nconst; $i++) {
my $const = $pf->const_table->constant($i);
my $value = $const->value;
@@ -133,43 +182,15 @@
END_C
}
- my $cursor = 0;
- my $length = length($pf->byte_code);
-
- my $offset=0;
-
- my $op_code;
- my $op;
-
- while ($offset + sizeof('op') <= $length) {
- $pc = $new_pc;
- $op_code = unpack "x$offset l", $pf->byte_code;
- $op = $ops->op($op_code);
- $offset += sizeof('op');
- $new_pc = $pc + $op->size;
-
- @args = ();
-
- foreach (1 .. scalar($op->arg_types) - 1) {
- die "$0: Premature end of bytecode in argument.\n"
- if ($offset + sizeof('op')) > $length;
- my $arg = unpack "x$offset l", $pf->byte_code;
- $offset += sizeof('op');
- push @args, $arg;
- }
- my $source = $op->source(\&map_ret_abs, \&map_ret_rel, \&map_arg,
\&map_res_abs, \&map_res_rel);
-
- printf("PC_%d: { /* %s */\n%s}\n\n", $pc, $op->full_name, $source);
- }
-
+ print @source;
print <<END_C;
-
-PC_$new_pc:
PC_0: {
exit(0);
}
+
+
return 0;
}
END_C
@@ -186,7 +207,11 @@
{
my ($addr) = @_;
#print STDERR "pbcc: map_ret_abs($addr)\n";
- return sprintf("goto PC_%d", $addr);
+ if ($op->full_name eq 'ret') {
+ return sprintf("goto *pc_l[(int)dest]");
+ } else {
+ return sprintf("goto PC_%d", $addr);
+ }
}
@@ -198,7 +223,11 @@
{
my ($offset) = @_;
#print STDERR "pbcc: map_ret_rel($offset)\n";
- return sprintf("goto PC_%d", $pc + $offset);
+ if ($op->full_name eq 'jump_i') {
+ return sprintf("goto *pc_l[" . $pc . "+" . $offset . "]");
+ } else {
+ return sprintf("goto PC_%d", $pc + $offset);
+ }
}
Index: runops_cores.c
===================================================================
RCS file: /home/perlcvs/parrot/runops_cores.c,v
retrieving revision 1.2
diff -u -r1.2 runops_cores.c
--- runops_cores.c 2001/10/19 01:43:00 1.2
+++ runops_cores.c 2001/11/05 00:28:57
@@ -36,7 +36,11 @@
opcode_t *
runops_t0p0b0_core (struct Parrot_Interp *interpreter, opcode_t * pc) {
+#ifdef HAVE_COMPUTED_GOTO
+ cg_core(pc, interpreter);
+#else
while (pc) { DO_OP(pc, interpreter); }
+#endif
return pc;
}
