# Copyright (C) 2007, The Perl Foundation.
# $Id: PMCEmitter.pm 23961 2007-12-16 10:35:26Z bernhard $
=head1 NAME
Parrot::Pmc2c::PMCEmitter - PMC to C Code Generation
=head1 SYNOPSIS
use Parrot::Pmc2c::PMCEmitter;
=head1 DESCRIPTION
C<Parrot::Pmc2c::PMCEmitter> is used by F<tools/build/pmc2c.pl> to generate C code from PMC files.
=head2 Functions
=over
=cut
package Parrot::Pmc2c::PMC;
use strict;
use warnings;
use Parrot::Pmc2c::Emitter;
use Parrot::Pmc2c::Method;
use Parrot::Pmc2c::MethodEmitter;
use Parrot::Pmc2c::UtilFunctions
qw( gen_ret dont_edit count_newlines dynext_load_code c_code_coda );
use Text::Balanced 'extract_bracketed';
use Parrot::Pmc2c::PCCMETHOD;
use Parrot::Pmc2c::PMC::RO;
use Parrot::Pmc2c::PMC::ParrotClass;
sub prep_for_emit {
my ( $this, $pmc, $vtable_dump ) = @_;
$pmc->vtable($vtable_dump);
$pmc->init();
$pmc;
}
sub generate {
my ($self) = @_;
my $emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new( $self->filename(".c") );
$self->generate_c_file;
$emitter->write_to_file;
$emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new( $self->filename(".h") );
$self->generate_h_file;
$emitter->write_to_file;
}
=item C<generate_c_file()>
Generates the C implementation file code for the PMC.
=cut
sub generate_c_file {
my ($self) = @_;
my $c = $self->{emitter};
$c->emit( dont_edit( $self->filename ) );
$c->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic );
$self->gen_includes;
$c->emit( $self->preamble );
$self->gen_methods;
my $ro = $self->ro;
if ($ro) {
$ro->{emitter} = $self->{emitter};
$ro->gen_methods;
}
$c->emit( $self->init_func );
$c->emit( $self->postamble );
return 1;
}
=item C<generate_h_file()>
Generates the C header file code for the PMC.
=cut
sub generate_h_file {
my ($self) = @_;
my $h = $self->{emitter};
my $name = uc $self->name;
$h->emit( dont_edit( $self->filename ) );
$h->emit(<<"EOH");
#ifndef PARROT_PMC_${name}_H_GUARD
#define PARROT_PMC_${name}_H_GUARD
EOH
$h->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic );
$h->emit( $self->hdecls );
$h->emit( $self->{ro}->hdecls ) if ( $self->{ro} );
$h->emit(<<"EOH");
#endif /* PARROT_PMC_${name}_H_GUARD */
EOH
$h->emit( c_code_coda() );
return 1;
}
=item C<hdecls()>
Returns the C code function declarations for all the methods for inclusion
in the PMC's C header file.
TODO include MMD variants.
=cut
sub hdecls {
my ($self) = @_;
my $hout;
my $name = $self->name;
# generate decls for all vtable methods in this PMC
foreach my $vt_method_name ( @{ $self->vtable->names } ) {
if ( $self->implements_vtable($vt_method_name) ) {
$hout .= $self->get_method($vt_method_name)->generate_headers($self);
}
}
# generate decls for all nci methods in this PMC
foreach my $method ( @{ $self->{methods} } ) {
next if $method->is_vtable;
$hout .= $method->generate_headers($self);
}
# class init decl
$hout .= 'PARROT_DYNEXT_EXPORT ' if ( $self->is_dynamic );
$hout .= "void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n";
$self->{hdecls} .= $hout;
$self->{hdecls};
}
=back
=head2 Instance Methods
=over
=item C<init()>
Initializes the instance.
=cut
sub init {
my ($self) = @_;
$self->fixup_singleton if $self->singleton;
#!( singleton or abstract ) everything else gets readonly version of methods too.
$self->ro( Parrot::Pmc2c::PMC::RO->new($self) ) unless ( $self->abstract or $self->singleton );
}
sub fixup_singleton {
my ($self) = @_;
# Since singletons are shared between interpreters, we need to make special effort to use
# the right namespace for method lookups.
#
# Note that this trick won't work if the singleton inherits from something else
# (because the MRO will still be shared).
unless ( $self->implements_vtable('pmc_namespace')
or $self->super_method('pmc_namespace') ne 'default' )
{
my $body = Parrot::Pmc2c::Emitter->text(
" return INTERP->vtables[SELF->vtable->base_type]->_namespace;\n");
$self->add_method(
Parrot::Pmc2c::Method->new(
{
name => 'pmc_namespace',
parent_name => $self->name,
parameters => '',
body => $body,
type => Parrot::Pmc2c::Method::VTABLE,
mmds => [],
return_type => 'PMC*',
attrs => {},
}
)
);
}
}
=item C<gen_includes()>
Returns the C C<#include> for the header file of each of the PMC's superclasses.
=cut
sub gen_includes {
my ($self) = @_;
my $c = $self->{emitter};
$c->emit(<<"EOC");
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "parrot/dynext.h"
EOC
$c->emit(qq{#include "pmc_fixedintegerarray.h"\n}) if ( $self->flag('need_fia_header') );
foreach my $parent_name ( $self->name, @{ $self->parents } ) {
$c->emit( '#include "pmc_' . lc $parent_name . ".h\"\n" );
}
foreach my $mixin_name ( @{ $self->mixins } ) {
$c->emit( '#include "pmc_' . lc $mixin_name . ".h\"\n" );
}
$c->emit( '#include "' . lc $self->name . ".str\"\n" ) unless $self->is_dynamic;
}
=item C<proto($type,$parameters)>
Determines the prototype (argument signature) for a method body
(see F<src/call_list>).
=cut
my %calltype = (
"char" => "c",
"short" => "s",
"char" => "c",
"short" => "s",
"int" => "i",
"INTVAL" => "I",
"float" => "f",
"FLOATVAL" => "N",
"double" => "d",
"STRING*" => "S",
"char*" => "t",
"PMC*" => "P",
"short*" => "2",
"int*" => "3",
"long*" => "4",
"void" => "v",
"void*" => "b",
"void**" => "B",
#"BIGNUM*" => "???" # RT#43731
);
sub proto {
my ( $type, $parameters ) = @_;
# reduce to a comma separated set of types
$parameters =~ s/\w+(,|$)/,/g;
$parameters =~ s/ //g;
# flatten whitespace before "*" in return value
$type =~ s/\s+\*$/\*/ if defined $type;
# type method(interp, self, parameters...)
my $ret = $calltype{ $type or "void" };
$ret .= "JO" . join( '', map { $calltype{$_} or "?" } split( /,/, $parameters ) );
# RT#43733
# scan src/call_list.txt if the generated signature is available
# RT#43735 report errors for "?"
# --leo
return $ret;
}
sub pre_method_gen {
}
=item C<gen_methods()>
Returns the C code for the pmc methods.
=cut
sub gen_methods {
my ($self) = @_;
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
next if $vt_method_name eq 'class_init';
if ( $self->implements_vtable($vt_method_name) ) {
$self->get_method($vt_method_name)->generate_body($self);
}
}
# non-vtable methods
foreach my $method ( @{ $self->methods } ) {
next if $method->is_vtable;
$method->generate_body($self);
}
}
# RT#43737 quick hack - to get MMD variants
sub get_super_mmds {
my ( $self, $vt_method_name, $right, $mmd_prefix ) = @_;
my @mmds;
my $super_mmd_rights = $self->{super_mmd_rights}{$vt_method_name};
if ($super_mmd_rights) {
while ( my ( $super_pmc_name, $mmd_rights ) = each %{$super_mmd_rights} ) {
for my $x ( @{$mmd_rights} ) {
next if $x eq "DEFAULT";
my $right = "enum_class_$x";
my $super_name = "Parrot_${super_pmc_name}_${vt_method_name}_$x";
push @mmds, [ $mmd_prefix, 0, $right, $super_name ];
}
}
}
return @mmds;
}
=item C<find_mmd_methods()>
Returns three values:
The first is an arrayref of <[ mmd_number, left, right, implementation_func]>
suitable for initializing the MMD list.
The second is a arrayref listing dynamic PMCs which will need to be looked up.
The third is a list of C<[index, dynamic PMC]> pairs of right entries
in the MMD table that will need to be resolved at runtime.
=cut
sub find_mmd_methods {
my $self = shift;
my $pmcname = $self->name;
my ( @mmds, @init_mmds, %init_mmds );
foreach my $vt_method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $vt_method->name;
next unless $vt_method->is_mmd;
my $implementor;
if ( !$self->implements_vtable($vt_method_name) ) {
my $class = $self->{super}{$vt_method_name};
next
if $class =~ /^[A-Z]/
or $class eq 'default'
or $class eq 'delegate';
$implementor = $class;
}
else {
$implementor = $pmcname;
}
my ( $mmd_method_name, $func, $left, $right );
$mmd_method_name = "Parrot_${implementor}_$vt_method_name";
$func = $vt_method->mmd_prefix;
# dynamic PMCs need the runtime type which is passed in entry to class_init
$left = 0; # set to 'entry' below in initialization loop.
$right = $vt_method->right;
if ( exists $self->{super}{$vt_method_name} ) {
push @mmds, $self->get_super_mmds( $vt_method_name, $right, $func );
}
push @mmds, [ $func, $left, $right, $mmd_method_name ];
my $pmc_method = $self->get_method($vt_method_name);
if ($pmc_method) {
foreach my $mmd ( @{ $pmc_method->mmds } ) {
my $right = $mmd->right;
if ( $self->is_dynamic($right) ) {
$right = 0;
push @init_mmds, [ $#mmds + 1, $mmd->right ];
$init_mmds{ $mmd->right } = 1;
}
else {
$right = "enum_class_$right";
}
$mmd_method_name = "Parrot_" . $self->name . "_" . $mmd->name;
push @mmds, [ $func, $left, $right, $mmd_method_name ];
}
#$self->{mmds} = @mmds; # RT#43739
}
}
return ( \@mmds, \@init_mmds, [ keys %init_mmds ] );
}
sub build_full_c_vt_method_name {
my ( $self, $vt_method_name ) = @_;
my $implementor;
if ( $self->implements_vtable($vt_method_name) ) {
return $self->get_method($vt_method_name)
->full_method_name( $self->name . $self->{variant} );
}
elsif ( $self->{super}{$vt_method_name} ) {
$implementor = $self->{super}{$vt_method_name};
}
else {
$implementor = "default";
}
return "Parrot_${implementor}_$vt_method_name";
}
=item C<vtable_decl($name)>
Returns the C code for the declaration of a vtable temporary named
C<$name> with the functions for this class.
=cut
sub vtable_decl {
my ( $self, $temp_struct_name, $enum_name ) = @_;
# gen vtable flags
my $vtbl_flag = 0;
$vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT' if $self->flag('need_ext');
$vtbl_flag .= '|VTABLE_PMC_IS_SINGLETON' if $self->flag('singleton');
$vtbl_flag .= '|VTABLE_IS_SHARED_FLAG' if $self->flag('is_shared');
$vtbl_flag .= '|VTABLE_IS_READONLY_FLAG' if $self->flag('is_ro');
$vtbl_flag .= '|VTABLE_HAS_READONLY_FLAG' if $self->flag('has_ro');
my @vt_methods;
foreach my $vt_method ( @{ $self->vtable->methods } ) {
next if $vt_method->is_mmd;
push @vt_methods, $self->build_full_c_vt_method_name( $vt_method->name );
}
my $methlist = join( ",\n ", @vt_methods );
my $cout = <<ENDOFCODE;
const VTABLE $temp_struct_name = {
NULL, /* namespace */
$enum_name, /* base_type */
NULL, /* whoami */
$vtbl_flag, /* flags */
NULL, /* does_str */
NULL, /* isa_str */
NULL, /* class */
NULL, /* mro */
NULL, /* ro_variant_vtable */
$methlist
};
ENDOFCODE
return $cout;
}
=item C<init_func()>
Returns the C code for the PMC's initialization method, or an empty
string if the PMC has a C<no_init> flag.
=cut
sub init_func {
my ($self) = @_;
return "" if $self->no_init;
my $cout = "";
my $classname = $self->name;
my ( $mmds, $init_mmds, $dyn_mmds ) = $self->find_mmd_methods();
my $enum_name = $self->is_dynamic ? -1 : "enum_class_$classname";
my $vtable_decl = $self->vtable_decl( 'temp_base_vtable', $enum_name );
my $mmd_list =
join( ",\n ", map { "{ $_->[0], $_->[1], $_->[2], (funcptr_t) $_->[3] }" } @$mmds );
my $isa = join( " ", $classname, @{ $self->parents } );
$isa =~ s/\s?default$//;
my $does = join( " ", keys( %{ $self->{flags}{does} } ) );
my $class_init_code = "";
$class_init_code = $self->get_method('class_init')->body if $self->has_method('class_init');
$class_init_code =~ s/INTERP/interp/g;
$class_init_code =~ s/^/ /mg; #fix indenting
my %extra_vt;
if ( $self->{ro} ) {
$extra_vt{ro} = $self->{ro};
}
$cout .= <<"EOC";
void
Parrot_${classname}_class_init(PARROT_INTERP, int entry, int pass)
{
$vtable_decl
EOC
for my $k ( keys %extra_vt ) {
$cout .= $extra_vt{$k}->vtable_decl( "temp_${k}_vtable", $enum_name );
}
my $const = ( $self->{flags}{dynpmc} ) ? " " : " const ";
if ( scalar @$mmds ) {
$cout .= <<"EOC";
$const MMD_init _temp_mmd_init[] = {
$mmd_list
};
/* Dynamic PMCs need the runtime type which is passed in entry to class_init. */
EOC
}
$cout .= <<"EOC";
if (pass == 0) {
EOC
$cout .= <<"EOC";
/* create vtable - clone it - we have to set a few items */
VTABLE *vt_clone = Parrot_clone_vtable(interp, &temp_base_vtable);
EOC
for my $k ( keys %extra_vt ) {
$cout .= <<"EOC";
VTABLE *vt_${k}_clone = Parrot_clone_vtable(interp, &temp_${k}_vtable);
EOC
}
# init vtable slot
if ( $self->is_dynamic ) {
$cout .= <<"EOC";
vt_clone->base_type = entry;
vt_clone->whoami = string_make(interp, "$classname", @{[length($classname)]}, "ascii",
PObj_constant_FLAG|PObj_external_FLAG);
vt_clone->isa_str = string_make(interp, "$isa", @{[length($isa)]}, "ascii",
PObj_constant_FLAG|PObj_external_FLAG);
vt_clone->does_str = string_make(interp, "$does", @{[length($does)]}, "ascii",
PObj_constant_FLAG|PObj_external_FLAG);
EOC
}
else {
$cout .= <<"EOC";
vt_clone->whoami = CONST_STRING(interp, "$classname");
vt_clone->isa_str = CONST_STRING(interp, "$isa");
vt_clone->does_str = CONST_STRING(interp, "$does");
EOC
}
for my $k ( keys %extra_vt ) {
$cout .= <<"EOC";
vt_${k}_clone->base_type = entry;
vt_${k}_clone->whoami = vt_clone->whoami;
vt_${k}_clone->isa_str = vt_clone->isa_str;
vt_${k}_clone->does_str = vt_clone->does_str;
EOC
}
if ( $extra_vt{ro} ) {
$cout .= <<"EOC";
vt_clone->ro_variant_vtable = vt_ro_clone;
vt_ro_clone->ro_variant_vtable = vt_clone;
EOC
}
$cout .= <<"EOC";
interp->vtables[entry] = vt_clone;
EOC
$cout .= <<"EOC";
}
else { /* pass */
EOC
# To make use of the .HLL directive, register any mapping...
if ( $self->{flags}{hll} && $self->{flags}{maps} ) {
my $hll = $self->{flags}{hll};
$cout .= <<"EOC";
{
/* Register this PMC as a HLL mapping */
INTVAL pmc_id = Parrot_get_HLL_id( interp, const_string(interp, "$hll")
);
if (pmc_id > 0) {
EOC
foreach my $maps ( sort keys %{ $self->{flags}{maps} } ) {
$cout .= <<"EOC";
Parrot_register_HLL_type( interp, pmc_id, enum_class_$maps, entry);
EOC
}
$cout .= <<"EOC";
}
} /* Register */
EOC
}
$cout .= <<"EOC";
/* setup MRO and _namespace */
Parrot_create_mro(interp, entry);
EOC
# declare each nci method for this class
foreach my $method ( @{ $self->{methods} } ) {
next unless $method->type eq Parrot::Pmc2c::Method::NON_VTABLE;
my $proto = proto( $method->return_type, $method->parameters );
my $method_name = $method->name;
my $symbol_name = defined $method->symbol ? $method->symbol : $method->name;
if ( exists $method->{PCCMETHOD} ) {
$cout .= <<"EOC";
register_raw_nci_method_in_ns(interp, entry,
F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name");
EOC
}
else {
$cout .= <<"EOC";
register_nci_method(interp, entry,
F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name", "$proto");
EOC
}
if ( $method->{attrs}{write} ) {
$cout .= <<"EOC";
Parrot_mark_method_writes(interp, entry, "$symbol_name");
EOC
}
}
# include any class specific init code from the .pmc file
$cout .= <<"EOC";
/* class_init */
EOC
$cout .= <<"EOC" if $class_init_code;
{
$class_init_code
}
EOC
$cout .= <<"EOC";
{
EOC
# declare auxiliary variables for dyncpmc IDs
foreach my $dynpmc (@$dyn_mmds) {
next if $dynpmc eq $classname;
$cout .= <<"EOC";
int my_enum_class_$dynpmc = pmc_type(interp, string_from_literal(interp, "$dynpmc"));
EOC
}
# init MMD "right" slots with the dynpmc types
foreach my $entry (@$init_mmds) {
if ( $entry->[1] eq $classname ) {
$cout .= <<"EOC";
_temp_mmd_init[$entry->[0]].right = entry;
EOC
}
else {
$cout .= <<"EOC";
_temp_mmd_init[$entry->[0]].right = my_enum_class_$entry->[1];
EOC
}
}
# just to be safe
foreach my $dynpmc (@$dyn_mmds) {
next if $dynpmc eq $classname;
$cout .= <<"EOC";
PARROT_ASSERT(my_enum_class_$dynpmc != enum_class_default);
EOC
}
if ( scalar @$mmds ) {
$cout .= <<"EOC";
#define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
Parrot_mmd_register_table(interp, entry,
_temp_mmd_init, N_MMD_INIT);
EOC
}
$cout .= <<"EOC";
}
} /* pass */
} /* Parrot_${classname}_class_init */
EOC
if ( $self->is_dynamic ) {
$cout .= dynext_load_code( $classname, $classname => {} );
}
$cout;
}
sub is_vtable_method {
my ( $self, $vt_method_name ) = @_;
return 1 if $self->vtable->has_method($vt_method_name);
return 0;
}
sub vtable {
my ( $self, $value ) = @_;
$self->{vtable} = $value if $value;
return $self->{vtable};
}
1;
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
syntax highlighted by Code2HTML, v. 0.9.1