All --
Here's an updated version of my Parrot Bytecode --> C compiler. I've
updated it to work in the context of the latest commits.
NOTE: The only existing file that is modified by this patch is
MANIFEST (to add the two new files), so there's little impact on
your sandbox if you are testing other stuff for 0.0.2 release.
Here's a sample run to give you an idea of the performance boost:
$ assemble.pl t/test.pasm > t/test.pbc
$ test_prog t/test.pbc
Iterations: 100000000
Start time: 1001943537
End time: 1001943590
Count: 100000000
Elapsed time:53
Estimated ops:300000000
Estimated ops (numerically):300000000.000000
Elapsed time:53
Elapsed time:53.000000
Ops/sec:5660377.358491
$ cc -o t/test.o -c -I ./include t/test.c
$ # I Don't know why I had to link packfile.o here...
$ cc -o t/test -L . -lparrot t/test.o packfile.o
$ export LD_LIBRARY_PATH="."
$ t/test
Iterations: 100000000
Start time: 1001943640
End time: 1001943644
Count: 100000000
Elapsed time:4
Estimated ops:300000000
Estimated ops (numerically):300000000.000000
Elapsed time:4
Elapsed time:4.000000
Ops/sec:75000000.000000
$
So, 5.7 Mop/s --> 75.0 Mop/s. That's pretty good!
Regards,
-- Gregor
_____________________________________________________________________
/ perl -e 'srand(-2091643526); print chr rand 90 for (0..4)' \
Gregor N. Purdy [EMAIL PROTECTED]
Focus Research, Inc. http://www.focusresearch.com/
8080 Beckett Center Drive #203 513-860-3570 vox
West Chester, OH 45069 513-860-3579 fax
\_____________________________________________________________________/
? typescript
? compiler.patch
? gmon.out
? test_prog-old.prof
? t/test
? t/test.c
Index: MANIFEST
===================================================================
RCS file: /home/perlcvs/parrot/MANIFEST,v
retrieving revision 1.23
diff -a -u -r1.23 MANIFEST
--- MANIFEST 2001/09/30 20:25:22 1.23
+++ MANIFEST 2001/10/01 13:41:16
@@ -4,6 +4,7 @@
Makefile.in
Parrot/Assembler.pm
Parrot/Opcode.pm
+Parrot/OpFunc.pm
Parrot/PackFile.pm
Parrot/PackFile/ConstTable.pm
Parrot/PackFile/Constant.pm
@@ -53,6 +54,7 @@
opcode_table
packfile.c
parrot.c
+parrotc
pdump.c
process_opfunc.pl
register.c
Index: parrotc
===================================================================
RCS file: parrotc
diff -N parrotc
--- /dev/null Mon Oct 1 05:34:59 2001
+++ parrotc Mon Oct 1 06:41:16 2001
@@ -0,0 +1,327 @@
+#! /usr/bin/perl -w
+#
+# compile.pl
+#
+# Turn a parrot bytecode file into text.
+#
+# Copyright (C) 2001 The Parrot Team. All rights reserved.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id: $
+#
+
+use strict;
+
+use Parrot::Opcode;
+use Parrot::PackFile;
+use Parrot::PackFile::ConstTable;
+use Parrot::OpFunc;
+
+use Data::Dumper;
+$Data::Dumper::Useqq = 1;
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 0;
+
+Parrot::OpFunc->init('basic_opcodes.ops');
+
+#
+# GLOBAL VARIABLES:
+#
+
+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,
+ );
+
+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}} };
+}
+
+
+#
+# dump_const_table()
+#
+
+sub dump_const_table {
+ my ($pf) = @_;
+
+ my $count = $pf->const_table->const_count;
+
+ if ($count < 1) {
+ warn "Disassembling without opcode table fingerprint!";
+ return;
+ }
+
+ die "Cannot compile (differing opcode table)!"
+ if $pf->const_table->constant(0)->data ne $opcode_fingerprint;
+
+ print "# Constants: $count entries\n";
+ print "# ID Flags Encoding Type Size Data\n";
+
+ my $constant_num = 0;
+
+ foreach ($pf->const_table->constants) {
+ printf("%04x: %08x %08x %08x %08x %s\n",
+ $constant_num, $_->flags, $_->encoding, $_->type,
+ $_->size, $_->data);
+
+ $constant_num++;
+ }
+}
+
+
+#
+# compile_byte_code()
+#
+
+sub compile_byte_code {
+ my ($pf) = @_;
+ my $pc;
+ my $new_pc = 1;
+ my $op_size;
+
+ my $nconst = $pf->const_table->const_count;
+
+ print <<END_C;
+#include "parrot/parrot.h"
+#include "parrot/string.h"
+#include <math.h>
+
+int
+main(int argc, char **argv) {
+ int i;
+ struct Parrot_Interp * interpreter;
+ struct PackFile_Constant * c;
+ struct PackFile * pf;
+
+ init_world();
+
+ interpreter = make_interpreter();
+ pf = PackFile_new();
+
+ interpreter->code = pf;
+
+END_C
+
+ for(my $i = 0; $i < $nconst; $i++) {
+ my $const = $pf->const_table->constant($i);
+
+ if ($const->type eq Parrot::PackFile::Constant::type_code('PFC_INTEGER'))
+{ # TODO: Don't hardocde these codes.
+ print <<END_C;
+ c = PackFile_Constant_new_integer($const->value);
+END_C
+ } elsif ($const->type eq Parrot::PackFile::Constant::type_code('PFC_NUMBER')) {
+# TODO: Don't hardocde these codes.
+ print <<END_C;
+ c = PackFile_Constant_new_number($const->value);
+END_C
+ } elsif ($const->type eq Parrot::PackFile::Constant::type_code('PFC_STRING')) {
+# TODO: Don't hardocde these codes.
+ my $type = $const->value->type;
+ my $encoding = $const->value->encoding;
+ my $size = $const->value->size;
+ my $flags = $const->value->flags;
+ my $data = Dumper($const->value->data);
+
+ $data = '"' . $data . '"' unless $data =~ m/^"/;
+
+ print <<END_C;
+ c = PackFile_Constant_new_string(string_make($data, $size, $encoding, $flags,
+$type));
+END_C
+ } else {
+ die;
+ }
+
+ print <<END_C;
+ PackFile_ConstTable_push_constant(pf->const_table, c);
+
+END_C
+ }
+
+ my $cursor = 0;
+ my $length = length($pf->byte_code);
+
+ my $offset=0;
+
+ while ($offset + 4 <= $length) {
+ $pc = $new_pc;
+
+ my $op_start = $offset;
+ my $op_code = unpack "x$offset l", $pf->byte_code;
+ my $op_name = $opcodes[$op_code]{NAME};
+
+ printf "/* $opcodes[$op_code]{NAME} ";
+
+ $offset += 4;
+ $op_size = 1;
+
+ my $arg_count = $opcodes[$op_code]{ARGS};
+ my @args = ();
+ my @comment_args = ();
+
+ if ($arg_count) {
+ foreach (0 .. $arg_count - 1) {
+ my $type = $opcodes[$op_code]{TYPES}[$_];
+ my $unpack_type = $unpack_type{$type};
+ my $unpack_size = $unpack_size{$type};
+
+ die "$0: Premature end of bytecode in argument.\n"
+ if ($offset + $unpack_size) > $length;
+
+ my $arg = unpack "x$offset $unpack_type", $pf->byte_code;
+ $offset += $unpack_size;
+ $op_size += $unpack_size / 4;
+
+ if($type =~ m/^[INPS]$/) { # Register
+ push @args, $arg;
+ push @comment_args, $type . $arg;
+ } elsif($type eq "D") { # destination address
+ push @args, "$arg";
+ push @comment_args, $arg;
+ } elsif($type eq "s") { # string constant
+ push @args, $arg;
+ push @comment_args, "[String $arg]";
+ } else { # constant
+ push @args, $arg;
+ push @comment_args, $arg;
+ }
+ }
+
+ print join(", ", @comment_args);
+ }
+
+ print " */\n";
+
+# print "/* OP $op_name [$op_code] */\n";
+ my $body = $op_body{$op_name};
+
+ #
+ # Map {{@N}} ==> $args[N - 1]
+ #
+
+ while ($body =~ m/{{@(\d+)}}/m) {
+ my $rep = $args[$1 - 1];
+ $body =~ s/{{@(\d+)}}/$rep/m;
+ }
+
+ #
+ # Map {{=}} ==> PC_$pc
+ #
+
+ while ($body =~ m/{{=}}/m) {
+ my $rep = "PC_$pc";
+ $body =~ s/{{=}}/$rep/m;
+ }
+
+ #
+ # Map {{+=N}} ==> PC_$new_pc (where $new_pc = $pc + N)
+ #
+
+ $body =~ s/\+=-/-=/mg;
+
+ while ($body =~ m/{{([+-])=(\d+)}}/m) {
+ my $rep = "PC_" . ($pc + "$1$2");
+ $body =~ s/{{[+-]=(\d+)}}/$rep/m;
+ }
+
+ #
+ # Map {{N}} ==> PC_N
+ #
+
+ $body =~ s/\+=-/-=/mg;
+
+ while ($body =~ m/{{(\d+)}}/m) {
+ my $rep = "PC_$1";
+ $body =~ s/{{(\d+)}}/$rep/m;
+ }
+
+ print $body;
+
+ $new_pc = $pc + $op_size;
+ }
+
+ print <<END_C;
+
+PC_$new_pc:
+PC_0: {
+ exit(0);
+}
+
+ return 0;
+}
+END_C
+
+ return 0;
+}
+
+
+#
+# compile_file()
+#
+
+sub compile_file {
+ my ($file_name) = @_;
+
+ my $pf = Parrot::PackFile->new;
+ $pf->unpack_file($file_name);
+
+# dump_const_table($pf);
+ compile_byte_code($pf);
+
+ undef $pf;
+
+ return;
+}
+
+
+#
+# MAIN PROGRAM:
+#
+
+@ARGV = qw(-) unless @ARGV;
+
+foreach (@ARGV) {
+ compile_file($_)
+}
+
+exit 0;
+
+__END__
+
+=head1 NAME
+
+compile.pl - compile the byte code from Parrot Pack Files to C
+
+=head1 SYNOPSIS
+
+ perl compile.pl FILE
+
+=head1 DESCRIPTION
+
+Compile the Parrot Pack Files listed on the command line, or
+from standard input if no file is named.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001 The Parrot Team. All rights reserved.
+
+=head1 LICENSE
+
+This program is free software. It is subject to the same license
+as the Parrot interpreter.
+
Index: Parrot/OpFunc.pm
===================================================================
RCS file: OpFunc.pm
diff -N OpFunc.pm
--- /dev/null Mon Oct 1 05:34:59 2001
+++ OpFunc.pm Mon Oct 1 06:41:16 2001
@@ -0,0 +1,232 @@
+#! perl -w
+#
+# OpFunc.pm
+#
+# Take a file of opcode functions and create real C code for them
+#
+# 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 ...
+#
+# RETURN(x);
+#
+# }
+#
+# There may be more than one RETURN
+#
+# 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
+#
+
+use strict;
+
+package Parrot::OpFunc;
+
+use Parrot::Opcode;
+use Parrot::Config;
+
+BEGIN {
+ use Exporter;
+ use vars qw(%op_body @EXPORT @ISA);
+ @ISA = qw(Exporter);
+ @EXPORT = qw(%op_body);
+};
+
+
+my $current_name = '';
+my $current_body = '';
+
+my %opcodes = Parrot::Opcode::read_ops();
+my %opcode;
+my $opcode;
+
+my %psize = (i => 1,
+ n => $PConfig{nvsize}/$PConfig{ivsize},
+ I => 1,
+ N => 1,
+ D => 1,
+ S => 1,
+ s => 1,
+ );
+
+
+#
+# init()
+#
+
+sub init
+{
+ my ($class, $file) = @_;
+
+ die "Parrot::OpFunc::init(): No file specified!\n" unless defined $file;
+
+open GUTS, "include/parrot/interp_guts.h"
+ or die "Could not open include/parrot/interp_guts.h";
+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 $psize=0;
+ foreach (@params) {
+ $psize+=$psize{$_};
+ }
+
+
+ $opcode{$name}{RETURN_OFFSET} = 1 + $psize;
+ 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 $orig = $file;
+open INPUT, $file or die "Can't open $file, $!/$^E";
+if (! ($file =~ s/\.ops$/.c/)) {
+ $file .= ".c";
+}
+
+
+#
+# Read through the file, generating C source code:
+#
+
+my($name, $footer, @param_sub);
+while (<INPUT>) {
+ my $op_size = 1;
+
+ next if m|^\s*$|; # Skip blank lines
+ next if m|^\s*/\*.*\*/\s*$|; # Skip comment-only lines
+
+ if (/^AUTO_OP/) {
+ ($name, $footer, $op_size) = gen_auto_header($_);
+ die unless defined $op_size;
+ }
+
+ if (/^MANUAL_OP/) {
+ ($name, $footer, $op_size) = gen_manual_header($_);
+ die unless defined $op_size;
+ }
+
+ if (/^(AUTO|MANUAL)_OP/) {
+ my $count = 1;
+ @param_sub = ("",
+ map {if ($_ eq "n") {
+ my $temp = '*(NV *)&{{\@$count}}';
+ $count += 2;
+ $temp;
+ } else {
+ "{{\@" . $count++ . "}}";
+ }
+ } @{$opcodes{$name}{TYPES}});
+ next;
+ }
+
+ s/RETVAL/goto {{+=$op_size}}/;
+
+ s/RETURN\(0\);/goto {{0}};/;
+
+ s/RETURN\((.*)\)/goto {{+=$1}}/;
+
+ s/\bP(\d+)\b/$param_sub[$1]/g;
+
+ if (/^}/) {
+ $current_body .= "$footer\n";
+ next;
+ }
+
+ $current_body .= $_;
+}
+
+if ($current_name ne '') {
+ $op_body{$current_name} = $current_body;
+}
+
+#print "OPS:\n";
+#print join(', ', sort keys %op_body), "\n";
+
+ return;
+}
+
+
+sub gen_auto_header {
+ my ($line) = @_;
+ my ($name) = $line =~ /AUTO_OP\s+(\w+)/;
+
+ if ($current_name ne '') {
+ $op_body{$current_name} = $current_body;
+ }
+
+ $current_name = $name;
+ $current_body = '';
+
+ my $psize=0;
+ foreach (@{$opcodes{$name}{TYPES}}) {
+ $psize+=$psize{$_};
+ }
+ my $return_offset = $psize + 1;
+
+ $opcode{$name}{RETURN_OFFSET} = 1 + $psize;
+
+ $current_body .= "{{=}}: { /* $name */\n";
+
+ return($name, " goto {{+=$return_offset}};\n}\n", $return_offset);
+}
+
+sub gen_manual_header {
+ my ($line) = @_;
+ my ($name) = $line =~ /MANUAL_OP\s+(\w+)/;
+
+ if ($current_name ne '') {
+ $op_body{$current_name} = $current_body;
+ }
+
+ $current_name = $name;
+ $current_body = '';
+
+ my $psize=0;
+ foreach (@{$opcodes{$name}{TYPES}}) {
+ $psize+=$psize{$_};
+ }
+ my $return_offset = $psize + 1;
+
+ $opcode{$name}{RETURN_OFFSET} = 1 + $psize;
+
+ $current_body .= "{{=}}: { /* $name */\n";
+
+ return($name, " goto {{+=$return_offset}};\n}\n", $return_offset);
+}
+
+1;
+
