develooper Front page | perl.perl6.internals | Postings from October 2001

pbc2c.pl

From:
Daniel Grunblatt
Date:
October 28, 2001 11:36
Subject:
pbc2c.pl
Message ID:
Pine.BSO.4.33.0110281310380.15770-200000@trinity.mali.com.ar
#! /usr/bin/perl -w
#
# pbc2c.pl
#
# Turn a parrot bytecode file into a C program.
#
# 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: pbc2c.pl,v 1.3 2001/10/24 13:03:42 gregor Exp $
#

use strict;

use Parrot::Types;
use Parrot::PackFile;
use Parrot::PackFile::ConstTable;
use Parrot::OpsFile;


use Data::Dumper;
$Data::Dumper::Useqq  = 1;
$Data::Dumper::Terse  = 1;
$Data::Dumper::Indent = 0;

my $ops = new Parrot::OpsFile 'core.ops';


#
# 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;
    }

=no
    die "Cannot compile (differing opcode table)!"
        if $pf->const_table->constant(0)->data ne $opcode_fingerprint;
=cut

    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()
#

my $pc;
my $new_pc = 1;
my @args = ();
my @functions = ();

sub compile_byte_code {
    my ($pf) = @_;

    my $nconst = $pf->const_table->const_count;

    print <<END_C;
#include "parrot/parrot.h"
#include "parrot/string.h"

void start();
END_C

    print $ops->preamble;

    print <<END_C;

struct Parrot_Interp *     interpreter;

int
main(int argc, char **argv) {
    int                        i;
    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);
      my $value = $const->value;

      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($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($value);
END_C
      } elsif ($const->type eq Parrot::PackFile::Constant::type_code('PFC_STRING')) { # TODO: Don't hardocde these codes.
        my $type     = $value->type;
        my $encoding = $value->encoding;
        my $size     = $value->size;
        my $flags    = $value->flags;
        my $data     = Dumper($value->data);

        $data = '"' . $data . '"' unless $data =~ m/^"/;

        print <<END_C;
    c = PackFile_Constant_new_string(interpreter, string_make(interpreter, $data, $size, $encoding, $flags, $type));
END_C
      } else {
        die;
      }

     print <<END_C;
    PackFile_ConstTable_push_constant(pf->const_table, c);

END_C
    }
print <<END_C;
    start();
    return 0;
}
END_C

    my $cursor = 0;
    my $length = length($pf->byte_code);

    my $offset=0;

    my $op_code;
    my $op;
    my $n = 0;

    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);

        $functions[$n++] = $pc;
        printf("int\nPC_%d(int cur_opcode) /* %s */\n{\n%s}\n\n", $pc, $op->full_name, $source);
    }

    print <<END_C;

void
start()
{
    int                        (*functions[$pc])(int);
    int                        j = 1;

END_C
    foreach (0..scalar(@functions) - 1) {
        print "    functions[" . $functions[$_] . "] = (int (*)(int))PC_" . $functions[$_] . ";\n";
    }

    print <<END_C;

    while (j) { j = (*functions[j])(j); };
    exit(0);
}
END_C

    return 0;
}


#
# map_ret_abs()
#

sub map_ret_abs
{
  my ($addr) = @_;
#print STDERR "pbcc: map_ret_abs($addr)\n";
  return sprintf "return (" . $addr . ")";
}


#
# map_ret_rel()
#

sub map_ret_rel
{
  my ($offset) = @_;
#print STDERR "pbcc: map_ret_rel($offset)\n";
  return sprintf "return (cur_opcode+" . $offset . ")";
}


#
# map_arg()
#

my %arg_maps = (
  'i'  => "interpreter->int_reg->registers[%ld]",
  'n'  => "interpreter->num_reg->registers[%ld]",
  'p'  => "interpreter->pmc_reg->registers[%ld]",
  's'  => "interpreter->string_reg->registers[%ld]",

  'ic' => "%ld",
  'nc' => "interpreter->code->const_table->constants[%ld]->number",
  'pc' => "%ld /* ERROR: Don't know how to handle PMC constants yet! */",
  'sc' => "interpreter->code->const_table->constants[%ld]->string",
);

sub map_arg
{
  my ($type, $num) = @_;
#print STDERR "pbcc: map_arg($type, $num)\n";
  return sprintf($arg_maps{$type}, $args[$num - 1]);
}


#
# map_res_abs()
#

sub map_res_abs
{
  my ($addr) = @_;
  die "pbc2c.pl: Cannot handle RESUME ops!";
}


#
# map_res_rel()
#

sub map_res_rel
{
  my ($offset) = @_;
  die "pbc2c.pl: Cannot handle RESUME ops!";
}




#
# 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

pbcc - Parrot byte code compiler

=head1 SYNOPSIS

  pbcc foo.pbc > foo.c

=head1 DESCRIPTION

Compile the Parrot Pack File listed on the command line, or
from standard input if no file is named.

=head1 AUTHOR

Gregor N. Purdy E<lt>gregor@focusresearch.comE<gt>

=head1 COPYRIGHT

Copyright (C) 2001 Gregor N. Purdy. All rights reserved.

=head1 LICENSE

This program is free software. It is subject to the same license
as the Parrot interpreter.




nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About