All --
> The missing code is going to look something like this:
> Next time I'm in front of my development machine, I'll give this a try.
> If this approach works, I'll work harder to produce a version of the
> solution that we can be proud of.
OK. I got it working. I'm attaching the compile.pl and Parrot/OpFunc.pm
files. Here's what I did to make it work:
$ perl compile.pl t/test.pbc > t/test.c
$ cc -c -O3 -I ./include -o t/test.o t/test.c
$ cc -o t/test t/test.o strnative.o string.o register.o parrot.o \
memory.o interpreter.o global_setup.o bytecode.o basic_opcodes.o -lm
$ t/test
I got 150 Mop/s running this (vs. about 10 before!)
This code should be cleaned up along the lines of what Simon has been
doing lately to the assembler/disassembler and PackFile:: classes. I
can take that on later unless someone else is eager to do it.
BTW, maybe we should be using time_n instead of time_i in test.pasm?
I'm converting t/test.pasm to little_languages/mops.jako (I'll need
to add time() to jakoc to get it to work). When that works, I'll make
it use time_n instead of time_i. Then, I'll re-run stuff. Stay tuned.
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
\_____________________________________________________________________/
#! /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;
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;
STRING * constants[$nconst];
struct Parrot_Interp * interpreter;
init_world();
interpreter = make_interpreter();
Parrot_string_constants = constants;
END_C
for(my $i = 0; $i < $nconst; $i++) {
my $const = $pf->const_table->constant($i);
my $type = $const->type;
my $encoding = $const->encoding;
my $size = $const->size;
my $flags = $const->flags;
my $data = $const->data;
print <<END_C;
constants[$i] = string_make("$data", $size, $encoding, $flags, $type);
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.
#! 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;
